module Type.NbE where

open import Context
open import Type.Core

open import Function
open import Data.Empty
open import Data.Sum.Base

infix  3 _⊢ᵗⁿᵉ_ _⊢ᵗⁿᶠ_ _⊨ᵗ_
infixl 9 _[_]ᵗ

mutual
  Starⁿᵉ : Conᵏ -> Set
  Starⁿᵉ Θ = Θ ⊢ᵗⁿᵉ ⋆

  Starⁿᶠ : Conᵏ -> Set
  Starⁿᶠ Θ = Θ ⊢ᵗⁿᶠ ⋆

  data _⊢ᵗⁿᵉ_ Θ : Kind -> Set where
    Varⁿᵉ : ∀ {σ} -> σ ∈ Θ -> Θ ⊢ᵗⁿᵉ σ
    _∙ⁿᵉ_ : ∀ {σ τ} -> Θ ⊢ᵗⁿᵉ σ ⇒ᵏ τ -> Θ ⊢ᵗⁿᶠ σ -> Θ ⊢ᵗⁿᵉ τ
    _⇒ⁿᵉ_ : Starⁿᵉ Θ -> Starⁿᵉ Θ -> Starⁿᵉ Θ
    πⁿᵉ   : ∀ σ -> Starⁿᵉ (Θ ▻ σ) -> Starⁿᵉ Θ
    μⁿᵉ   : ∀ {κ} -> Θ ⊢ᵗⁿᶠ (κ ⇒ᵏ ⋆) ⇒ᵏ κ ⇒ᵏ ⋆ -> Θ ⊢ᵗⁿᶠ κ -> Starⁿᵉ Θ

  data _⊢ᵗⁿᶠ_ Θ : Kind -> Set where
    Neⁿᶠ   : ∀ {σ} -> Θ ⊢ᵗⁿᵉ σ -> Θ ⊢ᵗⁿᶠ σ
    Lamⁿᶠ_ : ∀ {σ τ} -> Θ ▻ σ ⊢ᵗⁿᶠ τ -> Θ ⊢ᵗⁿᶠ σ ⇒ᵏ τ

mutual
  embᵗⁿᵉ : ∀ {Θ σ} -> Θ ⊢ᵗⁿᵉ σ -> Θ ⊢ᵗ σ
  embᵗⁿᵉ (Varⁿᵉ v) = Var v
  embᵗⁿᵉ (φ ∙ⁿᵉ α) = embᵗⁿᵉ φ ∙ embᵗⁿᶠ α
  embᵗⁿᵉ (α ⇒ⁿᵉ β) = embᵗⁿᵉ α ⇒ embᵗⁿᵉ β
  embᵗⁿᵉ (πⁿᵉ σ α) = π σ (embᵗⁿᵉ α)
  embᵗⁿᵉ (μⁿᵉ ψ α) = μ (embᵗⁿᶠ ψ) (embᵗⁿᶠ α)

  embᵗⁿᶠ : ∀ {Θ σ} -> Θ ⊢ᵗⁿᶠ σ -> Θ ⊢ᵗ σ
  embᵗⁿᶠ (Neⁿᶠ α)  = embᵗⁿᵉ α
  embᵗⁿᶠ (Lamⁿᶠ β) = Lam (embᵗⁿᶠ β)

mutual
  renᵗⁿᵉ : ∀ {Θ Ξ σ} -> Θ ⊆ Ξ -> Θ ⊢ᵗⁿᵉ σ -> Ξ ⊢ᵗⁿᵉ σ
  renᵗⁿᵉ ι (Varⁿᵉ v) = Varⁿᵉ (renᵛ ι v)
  renᵗⁿᵉ ι (φ ∙ⁿᵉ α) = renᵗⁿᵉ ι φ ∙ⁿᵉ renᵗⁿᶠ ι α
  renᵗⁿᵉ ι (α ⇒ⁿᵉ β) = renᵗⁿᵉ ι α ⇒ⁿᵉ renᵗⁿᵉ ι β
  renᵗⁿᵉ ι (πⁿᵉ σ α) = πⁿᵉ σ (renᵗⁿᵉ (keep ι) α)
  renᵗⁿᵉ ι (μⁿᵉ ψ α) = μⁿᵉ (renᵗⁿᶠ ι ψ) (renᵗⁿᶠ ι α)

  renᵗⁿᶠ : ∀ {Θ Ξ σ} -> Θ ⊆ Ξ -> Θ ⊢ᵗⁿᶠ σ -> Ξ ⊢ᵗⁿᶠ σ
  renᵗⁿᶠ ι (Neⁿᶠ α)  = Neⁿᶠ (renᵗⁿᵉ ι α)
  renᵗⁿᶠ ι (Lamⁿᶠ β) = Lamⁿᶠ (renᵗⁿᶠ (keep ι) β)

mutual
  _⊨ᵗ_ : Conᵏ -> Kind -> Set
  Θ ⊨ᵗ σ = Θ ⊢ᵗⁿᵉ σ ⊎ Kripke Θ σ

  Kripke : Conᵏ -> Kind -> Set
  Kripke Θ  ⋆       = ⊥
  Kripke Θ (σ ⇒ᵏ τ) = ∀ {Ξ} -> Θ ⊆ Ξ -> Ξ ⊨ᵗ σ -> Ξ ⊨ᵗ τ

Neˢ : ∀ {σ Θ} -> Θ ⊢ᵗⁿᵉ σ -> Θ ⊨ᵗ σ
Neˢ = inj₁

Varˢ : ∀ {σ Θ} -> σ ∈ Θ -> Θ ⊨ᵗ σ
Varˢ = Neˢ ∘ Varⁿᵉ

renᵗˢ : ∀ {σ Θ Δ} -> Θ ⊆ Δ -> Θ ⊨ᵗ σ -> Δ ⊨ᵗ σ
renᵗˢ          ι (inj₁ α)  = inj₁ (renᵗⁿᵉ ι α)
renᵗˢ {⋆}      ι (inj₂ ())
renᵗˢ {σ ⇒ᵏ τ} ι (inj₂ k)  = inj₂ λ κ -> k (κ ∘ ι)

readbackᵗ : ∀ {σ Θ} -> Θ ⊨ᵗ σ -> Θ ⊢ᵗⁿᶠ σ
readbackᵗ          (inj₁ α)  = Neⁿᶠ α
readbackᵗ {⋆}      (inj₂ ())
readbackᵗ {σ ⇒ᵏ τ} (inj₂ k)  = Lamⁿᶠ (readbackᵗ (k topᵒ (Varˢ vz)))

_∙ˢ_ : ∀ {Θ σ τ} -> Θ ⊨ᵗ σ ⇒ᵏ τ -> Θ ⊨ᵗ σ -> Θ ⊨ᵗ τ
inj₁ f ∙ˢ x = Neˢ (f ∙ⁿᵉ readbackᵗ x)
inj₂ k ∙ˢ x = k idᵒ x

groundⁿᵉ : ∀ {Θ} -> Θ ⊨ᵗ ⋆ -> Θ ⊢ᵗⁿᵉ ⋆
groundⁿᵉ (inj₁ α)  = α
groundⁿᵉ (inj₂ ())

environmentᵗˢ : Environment _⊨ᵗ_
environmentᵗˢ = record
  { varᵈ = Varˢ
  ; renᵈ = renᵗˢ
  }

module _ where
  open Environment environmentᵗˢ

  mutual
    evalᵗ : ∀ {Θ Ξ σ} -> Ξ ⊢ᵉ Θ -> Θ ⊢ᵗ σ -> Ξ ⊨ᵗ σ
    evalᵗ ρ (Var v) = lookupᵉ v ρ
    evalᵗ ρ (Lam β) = inj₂ λ ι α -> evalᵗ (renᵉ ι ρ ▷ α) β
    evalᵗ ρ (φ ∙ α) = evalᵗ ρ φ ∙ˢ evalᵗ ρ α
    evalᵗ ρ (α ⇒ β) = inj₁ $ groundⁿᵉ (evalᵗ ρ α) ⇒ⁿᵉ groundⁿᵉ (evalᵗ ρ β)
    evalᵗ ρ (π σ α) = inj₁ $ πⁿᵉ σ ∘ groundⁿᵉ $ evalᵗ (keepᵉ ρ) α
    evalᵗ ρ (μ ψ α) = inj₁ $ μⁿᵉ (nfᵗ ρ ψ) (nfᵗ ρ α)

    nfᵗ : ∀ {Θ Ξ σ} -> Ξ ⊢ᵉ Θ -> Θ ⊢ᵗ σ -> Ξ ⊢ᵗⁿᶠ σ
    nfᵗ ρ = readbackᵗ ∘ evalᵗ ρ

  normalize : ∀ {Θ σ} -> Θ ⊢ᵗ σ -> Θ ⊢ᵗ σ
  normalize = embᵗⁿᶠ ∘ nfᵗ idᵉ

_[_]ᵗ : ∀ {Θ σ τ} -> Θ ▻ σ ⊢ᵗ τ -> Θ ⊢ᵗ σ -> Θ ⊢ᵗ τ
β [ α ]ᵗ = normalize $ Lam β ∙ α
{-# DISPLAY normalize (Lam β ∙ α) = β [ α ]ᵗ #-}


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

open import BaseOver

module Spaces.Flattening {i j k}
  (A : Set i) (B : Set j) (f g : B → A)
  (C : A → Set k) (D : (b : B) → C (f b) ≃ C (g b)) where

open import Spaces.FlatteningTypes A B f g C D

-- The family of paths used in the definition of [flatten]
paths-flatten : (b : B) → (cct (f b) == cct (g b) [ (λ w → (P w → Wt)) ↓ pp b ])
paths-flatten b =
  ↓-app→cst-in (λ q → ppt b _ ∘' ap (cct (g b)) (↓-pp-out q))

flatten-curried : (w : W) → (P w → Wt)
flatten-curried = W-rec _ cct paths-flatten

flatten : Σ W P → Wt
flatten (w , x) = flatten-curried w x

unflatten : Wt → Σ W P
unflatten = Wt-rec-nondep _ (λ a c → (cc a , c))
                            (λ b d → Σ-eq (pp b) (↓-pp-in refl))

--

flatten-unflatten : (w : Wt) → flatten (unflatten w) ≡ w
flatten-unflatten =
  Wt-rec _
    (λ _ _ → refl)
    (λ b d → ↓-◯=id-in unflatten flatten
      (ap flatten (ap unflatten (ppt b d))
                 ≡⟨ Wt-rec-nondep-β _ (λ a c → (cc a , c)) (λ b d → Σ-eq (pp b) (↓-pp-in refl)) b d |in-ctx ap flatten ⟩
       ap flatten (Σ-eq (pp b) (↓-pp-in refl))
                 ≡⟨ split-ap2 flatten (pp b) (↓-pp-in refl) ⟩
       ↓-app→cst-out (apd flatten-curried (pp b)) (↓-pp-in refl)
                 ≡⟨ W-rec-β _ cct paths-flatten b |in-ctx (λ u → ↓-app→cst-out u (↓-pp-in refl)) ⟩
       ↓-app→cst-out (paths-flatten b) (↓-pp-in refl)
                 ≡⟨ refl ⟩
       ↓-app→cst-out (↓-app→cst-in
         (λ q → ppt b _ ∘' ap (cct (g b)) (↓-pp-out q))) (↓-pp-in refl)
                 ≡⟨ ↓-app→cst-β (λ q → ppt b _ ∘' ap (cct (g b)) (↓-pp-out q)) (↓-pp-in refl) ⟩
       ppt b d ∘' ap (cct (g b)) (↓-pp-out (↓-pp-in refl))
                 ≡⟨ ↓-pp-β refl |in-ctx (λ u → ppt b d ∘' ap (cct (g b)) u) ⟩
       ppt b d ∎))

unflatten-flatten-curried : (w : W) (x : P w)
  →  unflatten (flatten-curried w x) ≡ (w , x)
unflatten-flatten-curried =
  W-rec _ (λ a x → refl)
    (λ b → ↓-Π-in
    (λ q → ↓-◯=id-in flatten unflatten
      (ap unflatten (ap flatten (Σ-eq (pp b) q))
                 ≡⟨ split-ap2 flatten (pp b) q |in-ctx ap unflatten ⟩
       ap unflatten (↓-app→cst-out (apd flatten-curried (pp b)) q)
                 ≡⟨ W-rec-β _ cct paths-flatten b |in-ctx (λ u → ap unflatten (↓-app→cst-out u q)) ⟩
       ap unflatten (↓-app→cst-out (paths-flatten b) q)
                 ≡⟨ refl ⟩
       ap unflatten (↓-app→cst-out (↓-app→cst-in (λ qq → ppt b _ ∘' ap (cct (g b)) (↓-pp-out qq))) q)
                 ≡⟨ ↓-app→cst-β (λ qq → ppt b _ ∘' ap (cct (g b)) (↓-pp-out qq)) q |in-ctx ap unflatten ⟩
       ap unflatten (ppt b _ ∘' ap (cct (g b)) (↓-pp-out q))
                 ≡⟨ ap-∘' unflatten (ppt b _) (ap (cct (g b)) (↓-pp-out q)) ⟩
       ap unflatten (ppt b _) ∘' ap unflatten (ap (cct (g b)) (↓-pp-out q))
                 ≡⟨ Wt-rec-nondep-β _ (λ a c → (cc a , c)) (λ b d → Σ-eq (pp b) (↓-pp-in refl)) b _ |in-ctx (λ u → u ∘' ap unflatten (ap (cct (g b)) (↓-pp-out q))) ⟩
       Σ-eq (pp b) (↓-pp-in refl) ∘' ap unflatten (ap (cct (g b)) (↓-pp-out q))
                 ≡⟨ compose-ap unflatten (cct (g b)) (↓-pp-out q) |in-ctx (λ u → (Σ-eq (pp b) (↓-pp-in refl) ∘' u)) ⟩
       Σ-eq (pp b) (↓-pp-in refl) ∘' ap (unflatten ◯ cct (g b)) (↓-pp-out q)
                 ≡⟨ refl ⟩
       Σ-eq (pp b) (↓-pp-in refl) ∘' ap (λ x → (cc (g b), x)) (↓-pp-out q)
                 ≡⟨ ap-cst,id P (↓-pp-out q) |in-ctx (λ u → Σ-eq (pp b) (↓-pp-in refl) ∘' u) ⟩
       Σ-eq (pp b) (↓-pp-in refl) ∘' Σ-eq refl (↓-pp-out q)
                 ≡⟨ Σ-∘' (↓-pp-in refl) (↓-pp-out q) ⟩
       Σ-eq (pp b) (↓-pp-in refl ∘'dep ↓-pp-out q)
                 ≡⟨ to-transp-weird q (pp-path _ _) |in-ctx Σ-eq (pp b) ⟩
       Σ-eq (pp b) q ∎)))

unflatten-flatten : (wx : Σ W P) → unflatten (flatten wx) ≡ wx
unflatten-flatten (w , x) = unflatten-flatten-curried w x

eqv : Σ W P ≃ Wt
eqv = (flatten , iso-is-eq flatten unflatten flatten-unflatten unflatten-flatten)


------------------------------------------------------------------------
-- A function that runs computations
------------------------------------------------------------------------

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

open import Prelude hiding (⊥)

module Partiality-monad.Inductive.Approximate {a} {A : Type a} where

open import Equality.Propositional.Cubical

open import H-level.Truncation.Propositional equality-with-paths

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Eliminators

-- Runs the computation. The given number is used to decide which
-- element to choose in sequences that are encountered.

approximate : A ⊥ → ℕ → ∥ Maybe A ∥
approximate x n = ⊥-rec-⊥
  (record
     { pe = ∣ nothing ∣
     ; po = λ x → ∣ just x ∣
     ; pl = λ _ rec → rec n
     ; pp = λ _ → truncation-is-proposition
     })
  x


{-# OPTIONS --safe #-}
module Cubical.Algebra.DirectSum.DirectSumHIT.PseudoNormalForm where

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

open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_)
open import Cubical.Data.Sigma
open import Cubical.Data.List
open import Cubical.Data.Vec.DepVec

open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.DirectSumHIT
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base

private variable
  ℓ : Level

open AbGroupStr
open AbGroupTheory

-----------------------------------------------------------------------------
-- Notation

module DefPNF
  (G : (n : ℕ) → Type ℓ)
  (Gstr : (n : ℕ) → AbGroupStr (G n))
  where

  open AbGroupStr (snd (⊕HIT-AbGr ℕ G Gstr)) using ()
    renaming
    ( 0g       to 0⊕HIT
    ; _+_      to _+⊕HIT_
    ; -_       to -⊕HIT_
    ; +Assoc    to +⊕HIT-Assoc
    ; +IdR     to +⊕HIT-IdR
    ; +IdL     to +⊕HIT-IdL
    ; +InvR    to +⊕HIT-InvR
    ; +InvL    to +⊕HIT-InvL
    ; +Comm     to +⊕HIT-Comm
    ; is-set   to isSet⊕HIT)

-----------------------------------------------------------------------------
-- Lemma

  -- def pseudo normal form
  sumHIT : {n : ℕ} → depVec G n → ⊕HIT ℕ G Gstr
  sumHIT {0} ⋆ = 0⊕HIT
  sumHIT {suc n} (a □ dv) = (base n a) +⊕HIT (sumHIT dv)

  -- 0 and sum
  replicate0g : (n : ℕ) → depVec G n
  replicate0g (zero) = ⋆
  replicate0g (suc n) = (0g (Gstr n)) □ (replicate0g n)

  sumHIT0g : (n : ℕ) → sumHIT (replicate0g n) ≡ 0⊕HIT
  sumHIT0g (zero) = refl
  sumHIT0g (suc n) = cong₂ _+⊕HIT_ (base-neutral n) (sumHIT0g n)
                     ∙ +⊕HIT-IdL _

  -- extension and sum
  extendDVL : (k l : ℕ) → (dv : depVec G l) → depVec G (k +n l)
  extendDVL zero  l dv = dv
  extendDVL (suc k) l dv = (0g (Gstr (k +n l))) □ (extendDVL k l dv)

  extendDVLeq : (k l : ℕ) → (dv : depVec G l) → sumHIT (extendDVL k l dv) ≡ sumHIT dv
  extendDVLeq (zero)  l dv = refl
  extendDVLeq (suc k) l dv = cong (λ X → X +⊕HIT sumHIT (extendDVL k l dv)) (base-neutral (k +n l))
                             ∙ +⊕HIT-IdL _
                             ∙ extendDVLeq k l dv

  extendDVR : (k l : ℕ) → (dv : depVec G k) → depVec G (k +n l)
  extendDVR k l dv = subst (λ X → depVec G X) (+-comm l k) (extendDVL l k dv)

  extendDVReq : (k l : ℕ) → (dv : depVec G k) → sumHIT (extendDVR k l dv) ≡ sumHIT dv
  extendDVReq k l dv = J (λ m p → sumHIT (subst (λ X → depVec G X) p (extendDVL l k dv)) ≡ sumHIT dv)
                       (sumHIT (subst (λ X → depVec G X) refl (extendDVL l k dv))
                               ≡⟨ cong sumHIT (transportRefl (extendDVL l k dv)) ⟩
                       sumHIT (extendDVL l k dv)
                               ≡⟨ extendDVLeq l k dv ⟩
                       sumHIT dv ∎)
                       (+-comm l k)

  -- pointwise add
  _pt+DV_ : {n : ℕ} → (dva dvb : depVec G n) → depVec G n
  _pt+DV_ {0} ⋆ ⋆ = ⋆
  _pt+DV_ {suc n} (a □ dva) (b □ dvb) = Gstr n ._+_ a b □ (dva pt+DV dvb)

  sumHIT+ : {n : ℕ} → (dva dvb : depVec G n) → sumHIT (dva pt+DV dvb) ≡ sumHIT dva +⊕HIT sumHIT dvb
  sumHIT+ {0} ⋆ ⋆ = sym (+⊕HIT-IdR _)
  sumHIT+ {suc n} (a □ dva) (b □ dvb) = cong₂ _+⊕HIT_ (sym (base-add _ _ _)) (sumHIT+ dva dvb)
                                        ∙ comm-4 (⊕HIT-AbGr ℕ G Gstr) _ _ _ _

-----------------------------------------------------------------------------
-- Case Traduction

  {- WARNING :
     The pseudo normal form is not unique.
     It is actually not unique enough so that it is not possible to raise one from ⊕HIT.
     Hence we actually need to make it a prop to be able to eliminate.
  -}

  untruncatedPNF : (x : ⊕HIT ℕ G Gstr) → Type ℓ
  untruncatedPNF x = Σ[ m ∈ ℕ ] Σ[ dv ∈ depVec G m ] x ≡ sumHIT dv

  PNF : (x : ⊕HIT ℕ G Gstr) → Type ℓ
  PNF x = ∥ untruncatedPNF x ∥₁

  untruncatedPNF2 : (x y : ⊕HIT ℕ G Gstr) → Type ℓ
  untruncatedPNF2 x y = Σ[ m ∈ ℕ ] Σ[ a ∈ depVec G m ] Σ[ b ∈ depVec G m ] (x ≡ sumHIT a) × (y ≡ sumHIT b)

  PNF2 :  (x y : ⊕HIT ℕ G Gstr) → Type ℓ
  PNF2 x y = ∥ untruncatedPNF2 x y ∥₁

-----------------------------------------------------------------------------
-- Translation

  ⊕HIT→PNF : (x : ⊕HIT ℕ G Gstr) → ∥ Σ[ m ∈ ℕ ] Σ[ a ∈ depVec G m ] x ≡ sumHIT a ∥₁
  ⊕HIT→PNF = DS-Ind-Prop.f _ _ _ _
        (λ _ → squash₁)
        ∣ (0 , (⋆ , refl)) ∣₁
        base→PNF
        add→PNF
    where
    base→PNF : (n : ℕ) → (a : G n) → PNF (base n a)
    base→PNF n a = ∣ (suc n) , ((a □ replicate0g n) , sym (cong (λ X → base n a +⊕HIT X) (sumHIT0g n)
                    ∙ +⊕HIT-IdR _)) ∣₁

    add→PNF : {U V : ⊕HIT ℕ G Gstr} → (ind-U : PNF U) → (ind-V : PNF V) → PNF (U +⊕HIT V)
    add→PNF {U} {V} = elim2 (λ _ _ → squash₁)
                      (λ { (k , dva , p) →
                      λ { (l , dvb , q) →
                      ∣ ((k +n l)
                        , (((extendDVR k l dva) pt+DV (extendDVL k l dvb))
                        , cong₂ _+⊕HIT_ p q
                          ∙ cong₂ _+⊕HIT_ (sym (extendDVReq k l dva)) (sym (extendDVLeq k l dvb))
                          ∙ sym (sumHIT+ (extendDVR k l dva) (extendDVL k l dvb)) )) ∣₁}})

  ⊕HIT→PNF2 : (x y : ⊕HIT ℕ G Gstr) → ∥ Σ[ m ∈ ℕ ] Σ[ a ∈ depVec G m ] Σ[ b ∈ depVec G m ] (x ≡ sumHIT a) × (y ≡ sumHIT b) ∥₁
  ⊕HIT→PNF2 x y = helper (⊕HIT→PNF x) (⊕HIT→PNF y)
    where
    helper : PNF x → PNF y →
             ∥ Σ[ m ∈ ℕ ] Σ[ a ∈ depVec G m ] Σ[ b ∈ depVec G m ] (x ≡ sumHIT a) × (y ≡ sumHIT b) ∥₁
    helper = elim2 (λ _ _ → squash₁)
                   (λ { (k , dva , p) →
                   λ { (l , dvb , q) →
                       ∣   ((k +n l)
                         , ((extendDVR k l dva)
                         , (extendDVL k l dvb
                         , p ∙ sym (extendDVReq k l dva)
                         , q ∙ sym (extendDVLeq k l dvb)))) ∣₁}})

-----------------------------------------------------------------------------
-- Some idea

{-
   This file should be generalizable to a general decidable index by adding a second vector
-}

{-
   It maybe possible to give a normal for without need the prop truncation.
   The issue with the current one is that we rely on a underline data type depVec
   which forces us to give an explict length. That's what forces the ∥_∥₁.
   Hence by getting rid of it and be rewrittinf the term it might be possible
   to get a normal form without the PT.

   Indeed this basically about pemuting and summing them by G n
   ∑ base (σ i) a (σ i) -> ∑[i ∈ ℕ] ∑[j ∈ I] base i (b i j) -> ∑ base i (c i)
   where a b c are informal "sequences"

   Then prove that if we extract the integer, we get an inceasing list
   with no coefficient being present twice.
-}


{-

Index a structure S by the type variable: X ↦ X → S X

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure
open import Cubical.Foundations.Univalence
open import Cubical.Functions.FunExtEquiv
open import Cubical.Data.Sigma
open import Cubical.Relation.Binary.Base
open import Cubical.Relation.ZigZag.Base
open import Cubical.HITs.SetQuotients
open import Cubical.HITs.PropositionalTruncation as Trunc

open import Cubical.Structures.NAryOp

private
  variable
    ℓ ℓ₁ ℓ₁' : Level

-- Structured relations

preservesSetsUnaryFun : {S : Type ℓ → Type ℓ₁}
  → preservesSets S → preservesSets (NAryFunStructure 1 S)
preservesSetsUnaryFun p setX = isSetΠ λ _ → p setX

UnaryFunRelStr : {S : Type ℓ → Type ℓ₁} {ℓ₁' : Level}
  → StrRel S ℓ₁' → StrRel (NAryFunStructure 1 S) (ℓ-max ℓ ℓ₁')
UnaryFunRelStr ρ R f g =
  ∀ {x y} → R x y → ρ R (f x) (g y)

open BinaryRelation
open isEquivRel
open isQuasiEquivRel
open SuitableStrRel

private
  composeWith[_] : {A : Type ℓ} (R : EquivPropRel A ℓ)
    → compPropRel (R .fst) (quotientPropRel (R .fst .fst)) .fst ≡ graphRel [_]
  composeWith[_] R =
    funExt₂ λ a t →
    hPropExt squash (squash/ _ _)
      (Trunc.rec (squash/ _ _) (λ {(b , r , p) → eq/ a b r ∙ p }))
      (λ p → ∣ a , R .snd .reflexive a , p ∣)

unaryFunSuitableRel : {S : Type ℓ → Type ℓ₁} (p : preservesSets S) {ρ : StrRel S ℓ₁'}
  → SuitableStrRel S ρ
  → SuitableStrRel (NAryFunStructure 1 S) (UnaryFunRelStr ρ)
unaryFunSuitableRel pres {ρ} θ .quo (X , f) R h .fst =
  f₀ ,
  λ {x} → J (λ y p → ρ (graphRel [_]) (f x) (f₀ y)) (θ .quo (X , f x) R (href x) .fst .snd)
  where
  href = h ∘ R .snd .reflexive

  f₀ : _
  f₀ [ x ] = θ .quo (X , f x) R (href x) .fst .fst
  f₀ (eq/ x₀ x₁ r i) = path i
    where
    path : θ .quo (X , f x₀) R (href x₀) .fst .fst ≡ θ .quo (X , f x₁) R (href x₁) .fst .fst
    path =
      cong fst
        (θ .quo (X , f x₀) R (href x₀) .snd
          ( θ .quo (X , f x₁) R (href x₁) .fst .fst
          , subst
            (λ T → ρ T (f x₀) (θ .quo (X , f x₁) R (href x₁) .fst .fst))
            (composeWith[_] R)
            (θ .transitive (R .fst) (quotientPropRel (R .fst .fst))
              (h r)
              (θ .quo (X , f x₁) R (href x₁) .fst .snd))
          ))
  f₀ (squash/ _ _ p q j i) =
    pres squash/ _ _ (cong f₀ p) (cong f₀ q) j i
unaryFunSuitableRel pres {ρ} θ .quo (X , f) R h .snd (f' , c) =
  Σ≡Prop
    (λ _ → isPropImplicitΠ λ _ → isPropImplicitΠ λ _ → isPropΠ λ _ →
      θ .prop (λ _ _ → squash/ _ _) _ _)
    (funExt
      (elimProp (λ _ → pres squash/ _ _)
        (λ x → cong fst (θ .quo (X , f x) R (href x) .snd (f' [ x ] , c refl)))))
  where
  href = h ∘ R .snd .reflexive
unaryFunSuitableRel pres {ρ} θ .symmetric R h {x} {y} r = θ .symmetric R (h r)
unaryFunSuitableRel pres {ρ} θ .transitive R R' h h' {x} {z} =
  Trunc.rec
    (θ .prop (λ _ _ → squash) _ _)
    (λ {(y , r , r') → θ .transitive R R' (h r) (h' r')})
unaryFunSuitableRel pres {ρ} θ .prop propR f g =
  isPropImplicitΠ λ x →
  isPropImplicitΠ λ y →
  isPropΠ λ _ → θ .prop propR (f x) (g y)

unaryFunRelMatchesEquiv : {S : Type ℓ → Type ℓ₁}
  (ρ : StrRel S ℓ₁') {ι : StrEquiv S ℓ₁'}
  → StrRelMatchesEquiv ρ ι
  → StrRelMatchesEquiv (UnaryFunRelStr ρ) (UnaryFunEquivStr ι)
unaryFunRelMatchesEquiv ρ μ (X , f) (Y , g) e =
  compEquiv (isoToEquiv isom) (equivPi λ _ → μ _ _ e)
  where
  open Iso

  isom : Iso _ _
  isom .fun h x = h refl
  isom .inv k {x} = J (λ y _ → ρ (graphRel (e .fst)) (f x) (g y)) (k x)
  isom .rightInv k i x = JRefl (λ y _ → ρ (graphRel (e .fst)) (f x) (g y)) (k x) i
  isom .leftInv h =
    implicitFunExt λ {x} →
    implicitFunExt λ {y} →
    funExt λ p →
    J (λ y p →  isom .inv (isom .fun h) p ≡ h p)
      (funExt⁻ (isom .rightInv (isom .fun h)) x)
      p


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

open import Agda.Primitive

module Basic where

data False : Set where

record True : Set where

data _||_ {a b : _} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inl : A → A || B
  inr : B → A || B
infix 1 _||_


{-# OPTIONS --cubical #-}
module _ where
open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub
open import Agda.Builtin.Cubical.Sub using () renaming (Sub to _[_↦_]; primSubOut to ouc)
open import Agda.Primitive renaming (_⊔_ to ℓ-max)
open import Agda.Builtin.Sigma

transpFill : ∀ {ℓ} {A' : Set ℓ} (φ : I)
               (A : (i : I) → Set ℓ [ φ ↦ (\ _ → A') ]) →
               (u0 : ouc (A i0)) →
               PathP (λ i → ouc (A i)) u0 (primTransp (λ i → ouc (A i)) φ u0)
transpFill φ A u0 i = primTransp (\ j → ouc (A (i ∧ j))) (~ i ∨ φ) u0

-- private
--   internalFiber : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) (y : B) → Set (ℓ-max ℓ ℓ')
--   internalFiber {A = A} f y = Σ A \ x → y ≡ f x

-- infix 4 _≃_

-- postulate
--   _≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ-max ℓ ℓ')
--   equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B
--   equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)
--                → ∀ ψ → (Partial ψ (internalFiber (equivFun w) a)) → internalFiber (equivFun w) a

-- {-# BUILTIN EQUIV _≃_ #-}
-- {-# BUILTIN EQUIVFUN  equivFun #-}
-- {-# BUILTIN EQUIVPROOF equivProof #-}

-- -- This is a module so we can easily rename the primitives.
-- module GluePrims where
--   primitive
--     primGlue    : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}
--       → (T : Partial φ (Set ℓ')) → (e : PartialP φ (λ o → T o ≃ A))
--       → Set ℓ'
--     prim^glue   : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
--       → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
--       → PartialP φ T → A → primGlue A T e
--     prim^unglue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
--       → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
--       → primGlue A T e → A

--     -- Needed for transp in Glue.
--     primFaceForall : (I → I) → I

open import Agda.Builtin.Cubical.Glue public
  renaming ( prim^glue to glue
           ; prim^unglue to unglue)

-- We uncurry Glue to make it a bit more pleasant to use
Glue : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}
       → (Te : Partial φ (Σ (Set ℓ') \ T →  T ≃ A))
       → Set ℓ'
Glue A Te = primGlue A (λ x → Te x .fst) (λ x → Te x .snd)

module TestHComp {ℓ ℓ'} (A : Set ℓ) {φ : I} (Te : Partial φ (Σ (Set ℓ') \ T →  T ≃ A))
         (ψ : I) (u : I → Partial ψ (Glue A Te)) (u0 : Sub (Glue A Te) ψ (u i0) ) where
  result : Glue A Te
  result = glue {φ = φ} (\ { (φ = i1) → primHComp {A = Te itIsOne .fst} u (primSubOut u0) })
                        (primHComp {A = A} (\ i → \ { (ψ = i1) → unglue {φ = φ} (u i itIsOne)
                                                    ; (φ = i1) → equivFun (Te itIsOne .snd)
                                                                          (primHComp (\ j → \ { (ψ = i1) → u (i ∧ j) itIsOne
                                                                                ; (i = i0) → primSubOut u0 })
                                                                                (primSubOut u0)) })
                                           (unglue {φ = φ} (primSubOut u0)))

  test : primHComp {A = Glue A Te} {ψ} u (primSubOut u0) ≡ result
  test i = primHComp {A = Glue A Te} {ψ} u (primSubOut u0)

module TestTransp {ℓ ℓ'} (A : Set ℓ) {φ : I} (Te : Partial φ (Σ (Set ℓ') \ T →  T ≃ A))
         (u0 : (Glue A Te)) where
  ψ = i0

  a0 = unglue {φ = φ} u0
  a1 = primComp (\ _ → A)
         φ
         (\ { i (φ = i1) → equivFun (Te itIsOne .snd) (transpFill {A' = Te itIsOne .fst} ψ (\ i → inc (Te itIsOne .fst)) u0 i) })
         a0

  pair : PartialP φ λ o → Helpers.fiber (Te o .snd .fst) a1
  pair o = equivProof (Te o .fst) A (Te o .snd) a1 φ \ { (φ = i1) → _ , Helpers.refl }

  result : Glue A Te
  result = glue {φ = φ} (λ o → pair o .fst) (primHComp (\ { j (φ = i1) → pair itIsOne .snd j}) a1)

  test : primTransp (\ _ → Glue A Te) ψ u0 ≡ result
  test = Helpers.refl


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Fundamental.Reducibility {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Reducibility
open import Definition.LogicalRelation.Fundamental

open import Tools.Product

-- Well-formed types are reducible.
reducible : ∀ {A Γ} → Γ ⊢ A → Γ ⊩⟨ ¹ ⟩ A
reducible A = let [Γ] , [A] = fundamental A
              in  reducibleᵛ [Γ] [A]

-- Well-formed equality is reducible.
reducibleEq : ∀ {A B Γ} → Γ ⊢ A ≡ B
            → ∃₂ λ [A] ([B] : Γ ⊩⟨ ¹ ⟩ B) → Γ ⊩⟨ ¹ ⟩ A ≡ B / [A]
reducibleEq {A} {B} A≡B =
  let [Γ] , [A] , [B] , [A≡B] = fundamentalEq A≡B
  in  reducibleᵛ [Γ] [A]
  ,   reducibleᵛ [Γ] [B]
  ,   reducibleEqᵛ {A} {B} [Γ] [A] [A≡B]

-- Well-formed terms are reducible.
reducibleTerm : ∀ {t A Γ} → Γ ⊢ t ∷ A → ∃ λ [A] → Γ ⊩⟨ ¹ ⟩ t ∷ A / [A]
reducibleTerm {t} {A} ⊢t =
  let [Γ] , [A] , [t] = fundamentalTerm ⊢t
  in  reducibleᵛ [Γ] [A] , reducibleTermᵛ {t} {A} [Γ] [A] [t]

-- Well-formed term equality is reducible.
reducibleEqTerm : ∀ {t u A Γ} → Γ ⊢ t ≡ u ∷ A → ∃ λ [A] → Γ ⊩⟨ ¹ ⟩ t ≡ u ∷ A / [A]
reducibleEqTerm {t} {u} {A} t≡u =
  let [Γ] , modelsTermEq [A] [t] [u] [t≡u] = fundamentalTermEq t≡u
  in  reducibleᵛ [Γ] [A] , reducibleEqTermᵛ {t} {u} {A} [Γ] [A] [t≡u]


------------------------------------------------------------------------
-- A variant of weak bisimilarity that can be used to relate the
-- number of steps in two computations
------------------------------------------------------------------------

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

open import Prelude hiding (_+_; _*_)

module Delay-monad.Quantitative-weak-bisimilarity {a} {A : Type a} where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Conat equality-with-J as Conat
  using (Conat; zero; suc; force; ⌜_⌝; _+_; _*_;
         [_]_≤_; step-≤; step-∼≤; _∎≤; step-∼; _∎∼)
open import Function-universe equality-with-J as F hiding (id; _∘_)

open import Delay-monad
open import Delay-monad.Bisimilarity as B
  using (now; later; laterˡ; laterʳ; force)

------------------------------------------------------------------------
-- The relation

mutual

  -- Quantitative weak bisimilarity. [ ∞ ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y
  -- is a variant of x B.≈ y for which the number of later
  -- constructors in x is bounded by nˡ plus 1 + mˡ times the number
  -- of later constructors in y, and the number of later constructors
  -- in y is bounded by nʳ plus 1 + mʳ times the number of later
  -- constructors in x (see ≈⇔≈×steps≤steps² below).

  infix 4 [_∣_∣_∣_∣_]_≈_ [_∣_∣_∣_∣_]_≈′_

  data [_∣_∣_∣_∣_]_≈_
         (i : Size) (mˡ mʳ : Conat ∞) :
         Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a where
    now    : ∀ {x nˡ nʳ} → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] now x ≈ now x
    later  : ∀ {x y nˡ nʳ} →
             [ i ∣ mˡ ∣ mʳ ∣ nˡ + mˡ ∣ nʳ + mʳ ] x .force ≈′ y .force →
             [ i ∣ mˡ ∣ mʳ ∣ nˡ      ∣ nʳ      ] later x  ≈  later y
    laterˡ : ∀ {x y nˡ nʳ} →
             [ i ∣ mˡ ∣ mʳ ∣ nˡ .force ∣ nʳ ] x .force ≈ y →
             [ i ∣ mˡ ∣ mʳ ∣ suc nˡ    ∣ nʳ ] later x  ≈ y
    laterʳ : ∀ {x y nˡ nʳ} →
             [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ .force ] x ≈ y .force →
             [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ suc nʳ    ] x ≈ later y

  record [_∣_∣_∣_∣_]_≈′_
           (i : Size) (mˡ mʳ nˡ nʳ : Conat ∞)
           (x y : Delay A ∞) : Type a where
    coinductive
    field
      force : {j : Size< i} → [ j ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y

open [_∣_∣_∣_∣_]_≈′_ public

-- Specialised variants of [_∣_∣_∣_∣_]_≈_ and [_∣_∣_∣_∣_]_≈′_.

infix 4 [_∣_∣_]_≈_ [_∣_∣_]_≈′_

[_∣_∣_]_≈_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ mˡ ∣ mʳ ] x ≈ y = [ i ∣ mˡ ∣ mʳ ∣ zero ∣ zero ] x ≈ y

[_∣_∣_]_≈′_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ mˡ ∣ mʳ ] x ≈′ y = [ i ∣ mˡ ∣ mʳ ∣ zero ∣ zero ] x ≈′ y

-- Quantitative expansion.

infix 4 [_∣_∣_]_≳_ [_∣_∣_]_≳′_ [_∣_]_≳_ [_∣_]_≳′_

[_∣_∣_]_≳_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ∣ n ] x ≳ y = [ i ∣ m ∣ zero ∣ n ∣ zero ] x ≈ y

[_∣_∣_]_≳′_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ∣ n ] x ≳′ y = [ i ∣ m ∣ zero ∣ n ∣ zero ] x ≈′ y

[_∣_]_≳_ : Size → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ] x ≳ y = [ i ∣ m ∣ zero ] x ≳ y

[_∣_]_≳′_ : Size → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ] x ≳′ y = [ i ∣ m ∣ zero ] x ≳′ y

-- The converse of quantitative expansion.

infix 4 [_∣_∣_]_≲_ [_∣_∣_]_≲′_ [_∣_]_≲_ [_∣_]_≲′_

[_∣_∣_]_≲_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ∣ n ] x ≲ y = [ i ∣ m ∣ n ] y ≳ x

[_∣_∣_]_≲′_ : Size → Conat ∞ → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ∣ n ] x ≲′ y = [ i ∣ m ∣ n ] y ≳′ x

[_∣_]_≲_ : Size → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ] x ≲ y = [ i ∣ m ] y ≳ x

[_∣_]_≲′_ : Size → Conat ∞ → Delay A ∞ → Delay A ∞ → Type a
[ i ∣ m ] x ≲′ y = [ i ∣ m ] y ≳′ x

------------------------------------------------------------------------
-- Conversions

-- Weakening.

weaken :
  ∀ {i mˡ mˡ′ mʳ mʳ′ nˡ nˡ′ nʳ nʳ′ x y} →
  [ ∞ ] mˡ ≤ mˡ′ → [ ∞ ] mʳ ≤ mʳ′ →
  [ ∞ ] nˡ ≤ nˡ′ → [ ∞ ] nʳ ≤ nʳ′ →
  [ i ∣ mˡ  ∣ mʳ  ∣ nˡ  ∣ nʳ  ] x ≈ y →
  [ i ∣ mˡ′ ∣ mʳ′ ∣ nˡ′ ∣ nʳ′ ] x ≈ y
weaken pˡ pʳ = λ where
  qˡ       qʳ       now        → now
  (suc qˡ) qʳ       (laterˡ r) → laterˡ (weaken pˡ pʳ (qˡ .force) qʳ r)
  qˡ       (suc qʳ) (laterʳ r) → laterʳ (weaken pˡ pʳ qˡ (qʳ .force) r)
  qˡ       qʳ       (later r)  → later λ { .force →
                                   weaken pˡ pʳ
                                     (qˡ Conat.+-mono pˡ)
                                     (qʳ Conat.+-mono pʳ)
                                     (r .force) }

weakenˡʳ :
  ∀ {i mˡ mʳ nˡ nˡ′ nʳ nʳ′ x y} →
  [ ∞ ] nˡ ≤ nˡ′ → [ ∞ ] nʳ ≤ nʳ′ →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ  ∣ nʳ  ] x ≈ y →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ′ ∣ nʳ′ ] x ≈ y
weakenˡʳ = weaken (_ ∎≤) (_ ∎≤)

weakenˡ :
  ∀ {i mˡ mʳ nˡ nˡ′ nʳ x y} →
  [ ∞ ] nˡ ≤ nˡ′ →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ  ∣ nʳ ] x ≈ y →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ′ ∣ nʳ ] x ≈ y
weakenˡ p = weakenˡʳ p (_ ∎≤)

weakenʳ :
  ∀ {i mˡ mʳ nˡ nʳ nʳ′ x y} →
  [ ∞ ] nʳ ≤ nʳ′ →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ  ] x ≈ y →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ′ ] x ≈ y
weakenʳ p = weakenˡʳ (_ ∎≤) p

-- Strong bisimilarity is contained in quantitative weak bisimilarity.

∼→≈ : ∀ {i mˡ mʳ nˡ nʳ x y} →
      B.[ i ] x ∼ y → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y
∼→≈ now       = now
∼→≈ (later p) = later λ { .force → ∼→≈ (p .force) }

-- Quantitative expansion is contained in expansion.

≳→≳ : ∀ {i m n x y} →
      [ i ∣ m ∣ n ] x ≳ y → B.[ i ] x ≳ y
≳→≳ now        = now
≳→≳ (later p)  = later λ { .force → ≳→≳ (p .force) }
≳→≳ (laterˡ p) = laterˡ (≳→≳ p)

-- Quantitative weak bisimilarity is contained in weak bisimilarity.

≈→≈ : ∀ {i mˡ mʳ nˡ nʳ x y} →
      [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y → B.[ i ] x ≈ y
≈→≈ now        = now
≈→≈ (later p)  = later λ { .force → ≈→≈ (p .force) }
≈→≈ (laterˡ p) = laterˡ (≈→≈ p)
≈→≈ (laterʳ p) = laterʳ (≈→≈ p)

-- In some cases expansion is contained in quantitative expansion.

≳→≳-steps :
  ∀ {m x y i} → B.[ i ] x ≳ y → [ i ∣ m ∣ steps x ] x ≳ y
≳→≳-steps     now               = now
≳→≳-steps     (laterˡ p)        = laterˡ (≳→≳-steps p)
≳→≳-steps {m} (later {x = x} p) = later λ { .force →
  weakenˡ lemma (≳→≳-steps (p .force)) }
  where
  lemma =
    steps (x .force)     ≤⟨ Conat.≤suc ⟩
    steps (later x)      ≤⟨ Conat.m≤m+n ⟩
    steps (later x) + m  ∎≤

-- In some cases weak bisimilarity is contained in quantitative weak
-- bisimilarity.

≈→≈-steps :
  ∀ {mˡ mʳ x y i} →
  B.[ i ] x ≈ y → [ i ∣ mˡ ∣ mʳ ∣ steps x ∣ steps y ] x ≈ y
≈→≈-steps           now                       = now
≈→≈-steps           (laterˡ p)                = laterˡ (≈→≈-steps p)
≈→≈-steps           (laterʳ p)                = laterʳ (≈→≈-steps p)
≈→≈-steps {mˡ} {mʳ} (later {x = x} {y = y} p) = later λ { .force →
  weakenˡʳ x-lemma y-lemma (≈→≈-steps (p .force)) }
  where
  x-lemma =
    steps (x .force)      ≤⟨ Conat.≤suc ⟩
    steps (later x)       ≤⟨ Conat.m≤m+n ⟩
    steps (later x) + mˡ  ∎≤

  y-lemma =
    steps (y .force)      ≤⟨ Conat.≤suc ⟩
    steps (later y)       ≤⟨ Conat.m≤m+n ⟩
    steps (later y) + mʳ  ∎≤

-- In some cases quantitative weak bisimilarity is contained in strong
-- bisimilarity.

never≈→∼ :
  ∀ {i mˡ mʳ nˡ nʳ x} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] never ≈ x → B.[ i ] never ∼ x
never≈→∼ (later  p) = later λ { .force → never≈→∼ (p .force) }
never≈→∼ (laterˡ p) = never≈→∼ p
never≈→∼ (laterʳ p) = later λ { .force → never≈→∼ p }

≈never→∼ :
  ∀ {i mˡ mʳ nˡ nʳ x} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ never → B.[ i ] x ∼ never
≈never→∼ (later  p) = later λ { .force → ≈never→∼ (p .force) }
≈never→∼ (laterˡ p) = later λ { .force → ≈never→∼ p }
≈never→∼ (laterʳ p) = ≈never→∼ p

≈→∼ : ∀ {i x y} → [ i ∣ zero ∣ zero ] x ≈ y → B.[ i ] x ∼ y
≈→∼ now       = now
≈→∼ (later p) = later λ { .force → ≈→∼ (p .force) }

------------------------------------------------------------------------
-- Reflexivity, symmetry/antisymmetry, transitivity

-- Quantitative weak bisimilarity is reflexive.

reflexive-≈ : ∀ {i mˡ mʳ nˡ nʳ} x → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ x
reflexive-≈ (now _)   = now
reflexive-≈ (later x) = later λ { .force → reflexive-≈ (x .force) }

-- Quantitative weak bisimilarity is symmetric (in a certain sense).

symmetric-≈ :
  ∀ {i mˡ mʳ nˡ nʳ x y} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
  [ i ∣ mʳ ∣ mˡ ∣ nʳ ∣ nˡ ] y ≈ x
symmetric-≈ now        = now
symmetric-≈ (later p)  = later λ { .force → symmetric-≈ (p .force) }
symmetric-≈ (laterˡ p) = laterʳ (symmetric-≈ p)
symmetric-≈ (laterʳ p) = laterˡ (symmetric-≈ p)

-- Four variants of transitivity.

transitive-≳∼ :
  ∀ {i m n x y z} →
  [ i ∣ m ∣ n ] x ≳ y → B.[ i ] y ∼ z → [ i ∣ m ∣ n ] x ≳ z
transitive-≳∼ = λ where
  now        now       → now
  (laterˡ p) q         → laterˡ (transitive-≳∼ p q)
  (later  p) (later q) → later λ { .force →
                           transitive-≳∼ (p .force) (q .force) }

transitive-∼≲ :
  ∀ {i m n x y z} →
  B.[ i ] x ∼ y → [ i ∣ m ∣ n ] y ≲ z → [ i ∣ m ∣ n ] x ≲ z
transitive-∼≲ p q = transitive-≳∼ q (B.symmetric p)

transitive-≈∼ :
  ∀ {i mˡ mʳ nˡ nʳ x y z} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y → y B.∼ z →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ z
transitive-≈∼ = λ where
  now        now       → now
  (later  p) (later q) → later λ { .force →
                           transitive-≈∼ (p .force) (q .force) }
  (laterˡ p) q         → laterˡ (transitive-≈∼ p q)
  (laterʳ p) (later q) → laterʳ (transitive-≈∼ p (q .force))

transitive-∼≈ :
  ∀ {i mˡ mʳ nˡ nʳ x y z} →
  x B.∼ y → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] y ≈ z →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ z
transitive-∼≈ = λ where
  now       now        → now
  (later p) (later q)  → later λ { .force →
                           transitive-∼≈ (p .force) (q .force) }
  (later p) (laterˡ q) → laterˡ (transitive-∼≈ (p .force) q)
  p         (laterʳ q) → laterʳ (transitive-∼≈ p q)

-- Equational reasoning combinators.

infix  -1 _∎ˢ
infixr -2 step-∼≈ˢ step-≳∼ˢ step-≈∼ˢ _≳⟨⟩ˢ_ step-≡≈ˢ _∼⟨⟩ˢ_

_∎ˢ : ∀ {i mˡ mʳ nˡ nʳ} x → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ x
_∎ˢ = reflexive-≈

step-∼≈ˢ : ∀ {i mˡ mʳ nˡ nʳ} x {y z} →
           [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] y ≈ z → x B.∼ y →
           [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ z
step-∼≈ˢ _ y≈z x∼y = transitive-∼≈ x∼y y≈z

syntax step-∼≈ˢ x y≈z x∼y = x ∼⟨ x∼y ⟩ˢ y≈z

step-≳∼ˢ : ∀ {i m n} x {y z} →
           B.[ i ] y ∼ z → [ i ∣ m ∣ n ] x ≳ y →
           [ i ∣ m ∣ n ] x ≳ z
step-≳∼ˢ _ y∼z x≳y = transitive-≳∼ x≳y y∼z

syntax step-≳∼ˢ x y∼z x≳y = x ≳⟨ x≳y ⟩ˢ y∼z

step-≈∼ˢ : ∀ {i mˡ mʳ nˡ nʳ} x {y z} →
           y B.∼ z → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
           [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ z
step-≈∼ˢ _ y∼z x≈y = transitive-≈∼ x≈y y∼z

syntax step-≈∼ˢ x y∼z x≈y = x ≈⟨ x≈y ⟩ˢ y∼z

_≳⟨⟩ˢ_ : ∀ {i mˡ mʳ nˡ nʳ} x {y} →
         [ i ∣ mˡ ∣ mʳ ∣ nˡ         ∣ nʳ ] drop-later x ≈ y →
         [ i ∣ mˡ ∣ mʳ ∣ ⌜ 1 ⌝ + nˡ ∣ nʳ ] x ≈ y
now _   ≳⟨⟩ˢ p = weakenˡ Conat.≤suc p
later _ ≳⟨⟩ˢ p = laterˡ p

step-≡≈ˢ : ∀ {i mˡ mʳ nˡ nʳ} x {y z} →
           [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] y ≈ z → x ≡ y →
           [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ z
step-≡≈ˢ _ y≈z refl = y≈z

syntax step-≡≈ˢ x y≈z x≡y = x ≡⟨ x≡y ⟩ˢ y≈z

_∼⟨⟩ˢ_ : ∀ {i mˡ mʳ nˡ nʳ} x {y} →
         [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
         [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y
_ ∼⟨⟩ˢ x≈y = x≈y

------------------------------------------------------------------------
-- Some results related to the steps function

-- If y is a quantitative expansion of x, then it contains at least as
-- many later constructors as x.

steps-mono :
  ∀ {i m n x y} → [ i ∣ m ∣ n ] x ≲ y → [ i ] steps x ≤ steps y
steps-mono = B.steps-mono ∘ ≳→≳

-- If [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y holds, then the number of later
-- constructors in x is bounded by nˡ plus 1 + mˡ times the number of
-- later constructors in y.

steps-+-*ʳ :
  ∀ {mˡ mʳ nˡ nʳ i x y} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
  [ i ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y
steps-+-*ʳ {mˡ} {mʳ} {nˡ} {nʳ} = λ where
  now → zero

  (later {x = x} {y = y} p) →
    steps (later x)                                                 ∼⟨ suc (λ { .force → _ ∎∼ }) ⟩≤
    suc (λ { .force → steps (x .force) })                           ≤⟨ suc (λ { .force → steps-+-*ʳ (p .force) }) ⟩
    suc (λ { .force → nˡ + mˡ + (⌜ 1 ⌝ + mˡ) * steps (y .force) })  ∼⟨ suc (λ { .force → Conat.symmetric-∼ (Conat.+-assoc nˡ) }) ⟩≤
    ⌜ 1 ⌝ + nˡ + (mˡ + (⌜ 1 ⌝ + mˡ) * steps (y .force))             ∼⟨ Conat.suc+∼+suc ⟩≤
    nˡ + ((⌜ 1 ⌝ + mˡ) + (⌜ 1 ⌝ + mˡ) * steps (y .force))           ∼⟨ (nˡ ∎∼) Conat.+-cong Conat.symmetric-∼ Conat.*suc∼+* ⟩≤
    nˡ + (⌜ 1 ⌝ + mˡ) * steps (later y)                             ∎≤

  (laterˡ {x = x} {y = y} {nˡ = nˡ} p) →
    steps (later x)                               ∼⟨ suc (λ { .force → _ ∎∼ }) ⟩≤
    ⌜ 1 ⌝ + steps (x .force)                      ≤⟨ (_ Conat.∎≤) Conat.+-mono steps-+-*ʳ p ⟩
    ⌜ 1 ⌝ + (nˡ .force + (⌜ 1 ⌝ + mˡ) * steps y)  ∼⟨ suc (λ { .force → _ ∎∼ }) ⟩≤
    suc nˡ + (⌜ 1 ⌝ + mˡ) * steps y               ∎≤

  (laterʳ {x = x} {y = y} {nʳ = nʳ} p) →
    steps x                                                ≤⟨ steps-+-*ʳ p ⟩
    nˡ + (⌜ 1 ⌝ + mˡ) * steps (y .force)                   ≤⟨ (nˡ ∎≤) Conat.+-mono Conat.m≤n+m ⟩
    nˡ + ((⌜ 1 ⌝ + mˡ) + (⌜ 1 ⌝ + mˡ) * steps (y .force))  ∼⟨ (nˡ ∎∼) Conat.+-cong Conat.symmetric-∼ Conat.*suc∼+* ⟩≤
    nˡ + (⌜ 1 ⌝ + mˡ) * steps (later y)                    ∎≤

-- If [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y holds, then the number of later
-- constructors in y is bounded by nʳ plus 1 + mʳ times the number of
-- later constructors in x.

steps-+-*ˡ :
  ∀ {mˡ mʳ nˡ nʳ i x y} →
  [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
  [ i ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x
steps-+-*ˡ = steps-+-*ʳ ∘ symmetric-≈

-- [ ∞ ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y holds iff x and y are weakly
-- bisimilar and the number of later constructors in x and y are
-- related in a certain way.

≈⇔≈×steps≤steps² :
  ∀ {mˡ mʳ nˡ nʳ x y} →
  [ ∞ ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y ⇔
  x B.≈ y ×
  [ ∞ ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y ×
  [ ∞ ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x
≈⇔≈×steps≤steps² {mˡ} {mʳ} {x = x} {y} = record
  { to   = λ p → ≈→≈ p , steps-+-*ʳ p , steps-+-*ˡ p
  ; from = λ { (p , q , r) → from p q r }
  }
  where
  from-lemma :
    ∀ {m n} {x y : Delay′ A ∞} {i} {j : Size< i} →
    [ i ] steps (later x) ≤ n + (⌜ 1 ⌝ + m) * steps (later y) →
    [ j ] steps (x .force) ≤ n + m + (⌜ 1 ⌝ + m) * steps (y .force)
  from-lemma {m} {n} {x} {y} hyp = Conat.cancel-suc-≤ lemma .force
    where
    lemma =
      ⌜ 1 ⌝ + steps (x .force)                            ∼⟨ suc (λ { .force → _ ∎∼ }) ⟩≤
      steps (later x)                                     ≤⟨ hyp ⟩
      n + (⌜ 1 ⌝ + m) * steps (later y)                   ∼⟨ (n ∎∼) Conat.+-cong Conat.*suc∼+* ⟩≤
      n + ((⌜ 1 ⌝ + m) + (⌜ 1 ⌝ + m) * steps (y .force))  ∼⟨ Conat.symmetric-∼ Conat.suc+∼+suc ⟩≤
      ⌜ 1 ⌝ + n + (m + (⌜ 1 ⌝ + m) * steps (y .force))    ∼⟨ suc (λ { .force → _ ∎∼ }) ⟩≤
      ⌜ 1 ⌝ + (n + (m + (⌜ 1 ⌝ + m) * steps (y .force)))  ∼⟨ suc (λ { .force → Conat.+-assoc n }) ⟩≤
      ⌜ 1 ⌝ + (n + m + (⌜ 1 ⌝ + m) * steps (y .force))    ∎≤

  from :
    ∀ {nˡ nʳ i x y} →
    B.[ i ] x ≈ y →
    [ ∞ ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y →
    [ ∞ ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x →
    [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y
  from now _ _ = now

  from (later p) q r = later λ { .force →
    from (p .force) (from-lemma q) (from-lemma r) }

  from (laterˡ {y = later _} p) q r = later λ { .force →
    from (B.laterʳ⁻¹ p) (from-lemma q) (from-lemma r) }

  from (laterʳ {x = later _} p) q r = later λ { .force →
    from (B.laterˡ⁻¹ p) (from-lemma q) (from-lemma r) }

  from {nˡ = zero}  (laterˡ {y = now _} p) ()
  from {nˡ = suc _} (laterˡ {y = now _} p) (suc q) _ =
    laterˡ (from p (q .force) zero)

  from {nʳ = zero}  (laterʳ {x = now _} p) _ ()
  from {nʳ = suc _} (laterʳ {x = now _} p) _ (suc r) =
    laterʳ (from p zero (r .force))

-- [ ∞ ∣ m ∣ n ] x ≳ y holds iff x is an expansion of y and the number
-- of later constructors in x and y are related in a certain way.

≳⇔≳×steps≤steps :
  ∀ {m n x y} →
  [ ∞ ∣ m ∣ n ] x ≳ y ⇔
  x B.≳ y × [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y
≳⇔≳×steps≤steps {m} {n} {x} {y} =
  [ ∞ ∣ m ∣ n ] x ≳ y                                  ↝⟨ ≈⇔≈×steps≤steps² ⟩

  x B.≈ y ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y ×
  [ ∞ ] steps y ≤ (⌜ 1 ⌝ + ⌜ 0 ⌝) * steps x            ↝⟨ F.id ×-cong F.id ×-cong (_ ∎∼) Conat.≤-cong-∼ lemma ⟩

  x B.≈ y ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y ×
  [ ∞ ] steps y ≤ steps x                              ↝⟨ record { to = B.symmetric; from = B.symmetric } ×-cong from-isomorphism ×-comm ⟩

  y B.≈ x ×
  [ ∞ ] steps y ≤ steps x ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y            ↔⟨ ×-assoc ⟩

  (y B.≈ x ×
   [ ∞ ] steps y ≤ steps x) ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y            ↝⟨ inverse B.≲⇔≈×steps≤steps ×-cong F.id ⟩□

  x B.≳ y × [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y  □
  where
  lemma =
    (⌜ 1 ⌝ + ⌜ 0 ⌝) * steps x  ∼⟨ suc (λ { .force → _ ∎∼ }) Conat.*-cong (_ ∎∼) ⟩
    ⌜ 1 ⌝ * steps x            ∼⟨ Conat.*-left-identity _ ⟩
    steps x                    ∎∼

-- [ ∞ ∣ m ∣ n ] x ≳ y holds iff x is weakly bisimilar to y and the
-- number of later constructors in x and y are related in a certain
-- way.

≳⇔≈×steps≤steps² :
  ∀ {m n x y} →
  [ ∞ ∣ m ∣ n ] x ≳ y ⇔
  x B.≈ y ×
  [ ∞ ] steps y ≤ steps x ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y
≳⇔≈×steps≤steps² {m} {n} {x} {y} =
  [ ∞ ∣ m ∣ n ] x ≳ y                        ↝⟨ ≳⇔≳×steps≤steps ⟩

  x B.≳ y ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y  ↝⟨ B.≲⇔≈×steps≤steps ×-cong F.id ⟩

  (y B.≈ x ×
   [ ∞ ] steps y ≤ steps x) ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y  ↔⟨ inverse ×-assoc ⟩

  y B.≈ x ×
  [ ∞ ] steps y ≤ steps x ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y  ↝⟨ record { to = B.symmetric; from = B.symmetric } ×-cong F.id ⟩□

  x B.≈ y ×
  [ ∞ ] steps y ≤ steps x ×
  [ ∞ ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y  □

-- The left-to-right direction of ≳⇔≳×steps≤steps can be made
-- size-preserving.

≳→≳×steps≤steps :
  ∀ {i m n x y} →
  [ i ∣ m ∣ n ] x ≳ y →
  B.[ i ] x ≳ y × [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y
≳→≳×steps≤steps x≳y = ≳→≳ x≳y , steps-+-*ʳ x≳y

-- The right-to-left direction of ≳⇔≳×steps≤steps can be made
-- size-preserving iff A is uninhabited.

≳×steps≤steps→≳⇔uninhabited :
  (∀ {i m n x y} →
   B.[ i ] x ≳ y ×
   [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y →
   [ i ∣ m ∣ n ] x ≳ y)
    ⇔
  ¬ A
≳×steps≤steps→≳⇔uninhabited = record
  { to   = flip to
  ; from =
    ¬ A                                           ↝⟨ (λ ¬A {_ _ _ _ _} → ∼→≈ (B.uninhabited→trivial ¬A _ _)) ⟩

    (∀ {i m n x y} → [ i ∣ m ∣ n ] x ≳ y)         ↝⟨ (λ hyp {_ _ _ _ _} _ → hyp {_}) ⟩□

    (∀ {i m n x y} →
     B.[ i ] x ≳ y ×
     [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y →
     [ i ∣ m ∣ n ] x ≳ y)                         □
  }
  where
  strengthen-≳now :
    ∀ {i m n x y} →
    [ i ∣ m ∣ n ] x ≳ now y →
    [ ∞ ∣ m ∣ n ] x ≳ now y
  strengthen-≳now now        = now
  strengthen-≳now (laterˡ p) = laterˡ (strengthen-≳now p)

  to :
    A →
    ¬ (∀ {i m n x y} →
       B.[ i ] x ≳ y ×
       [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y →
       [ i ∣ m ∣ n ] x ≳ y)
  to x =
    (∀ {i m n x y} →
     B.[ i ] x ≳ y ×
     [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y →
     [ i ∣ m ∣ n ] x ≳ y)                                         ↝⟨ (λ hyp → curry hyp) ⟩

    (∀ {i m n} →
     B.[ i ] f m ≳ now x →
     [ i ] steps (f m) ≤ n + zero →
     [ i ∣ zero ∣ n ] f m ≳ now x)                                ↝⟨ (λ hyp {_ _ _} p → hyp (≳now _) (complicate p)) ⟩

    (∀ {i m n} → [ i ] ⌜ m ⌝ ≤ n → [ i ∣ zero ∣ n ] f m ≳ now x)  ↝⟨ strengthen-≳now ∘_ ⟩

    (∀ {i m n} → [ i ] ⌜ m ⌝ ≤ n → [ ∞ ∣ zero ∣ n ] f m ≳ now x)  ↝⟨ (λ hyp {_ _ _} p → steps-+-*ʳ (hyp p)) ⟩

    (∀ {i m n} → [ i ] ⌜ m ⌝ ≤ n → [ ∞ ] steps (f m) ≤ n + zero)  ↝⟨ (λ hyp {_ _ _} p → simplify (hyp p)) ⟩

    (∀ {i m n} → [ i ] ⌜ m ⌝ ≤ n → [ ∞ ] ⌜ m ⌝ ≤ n)               ↝⟨ (λ hyp → hyp) ⟩

    (∀ {i} → [ i ] ⌜ 2 ⌝ ≤ ⌜ 1 ⌝ → [ ∞ ] ⌜ 2 ⌝ ≤ ⌜ 1 ⌝)           ↝⟨ Conat.no-strengthening-≤-21 ⟩□

    ⊥                                                             □
    where
    f : ∀ {i} → ℕ → Delay A i
    f zero    = now x
    f (suc n) = later λ { .force → f n }

    ≳now : ∀ {i} n → B.[ i ] f n ≳ now x
    ≳now zero    = now
    ≳now (suc n) = laterˡ (≳now n)

    ∼steps : ∀ {i} n → Conat.[ i ] ⌜ n ⌝ ∼ steps (f n)
    ∼steps zero    = zero
    ∼steps (suc n) = suc λ { .force → ∼steps n }

    complicate :
      ∀ {m n i} → [ i ] ⌜ m ⌝ ≤ n → [ i ] steps (f m) ≤ n + zero
    complicate {m} {n} p =
      steps (f m) ∼⟨ Conat.symmetric-∼ (∼steps m) ⟩≤
      ⌜ m ⌝       ≤⟨ p ⟩
      n           ∼⟨ Conat.symmetric-∼ (Conat.+-right-identity _) ⟩≤
      n + zero    ∎≤

    simplify :
      ∀ {m n i} → [ i ] steps (f m) ≤ n + zero → [ i ] ⌜ m ⌝ ≤ n
    simplify {m} {n} p =
      ⌜ m ⌝        ∼⟨ ∼steps m ⟩≤
      steps (f m)  ≤⟨ p ⟩
      n + zero     ∼⟨ Conat.+-right-identity _ ⟩≤
      n            ∎≤

-- The left-to-right direction of ≈⇔≈×steps≤steps² can be made
-- size-preserving.

≈→≈×steps≤steps² :
  ∀ {i mˡ mʳ nˡ nʳ x y} →
  [ ∞ ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y →
  B.[ i ] x ≈ y ×
  [ i ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y ×
  [ i ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x
≈→≈×steps≤steps² x≈y = ≈→≈ x≈y , steps-+-*ʳ x≈y , steps-+-*ˡ x≈y

-- The right-to-left direction of ≈⇔≈×steps≤steps² can be made
-- size-preserving iff A is uninhabited.

≈×steps≤steps²→≈⇔uninhabited :
  (∀ {i mˡ mʳ nˡ nʳ x y} →
   B.[ i ] x ≈ y ×
   [ i ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y ×
   [ i ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x →
   [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y)
    ⇔
  ¬ A
≈×steps≤steps²→≈⇔uninhabited = record
  { to =
    (∀ {i mˡ mʳ nˡ nʳ x y} →
     B.[ i ] x ≈ y ×
     [ i ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y ×
     [ i ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x →
     [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y)               ↝⟨ (λ { hyp (p , q) → hyp (B.≳→ p , q , lemma (B.steps-mono p)) }) ⟩

    (∀ {i m n x y} →
     B.[ i ] x ≳ y ×
     [ i ] steps x ≤ n + (⌜ 1 ⌝ + m) * steps y →
     [ i ∣ m ∣ n ] x ≳ y)                           ↝⟨ _⇔_.to ≳×steps≤steps→≳⇔uninhabited ⟩□

    ¬ A                                             □
  ; from =
    ¬ A                                                        ↝⟨ (λ ¬A {_ _ _ _ _} → ∼→≈ (B.uninhabited→trivial ¬A _ _)) ⟩

    (∀ {i mˡ mʳ nˡ nʳ x y} → [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y)  ↝⟨ (λ hyp {_ _ _ _ _ _ _} _ → hyp {_}) ⟩□

    (∀ {i mˡ mʳ nˡ nʳ x y} →
     B.[ i ] x ≈ y ×
     [ i ] steps x ≤ nˡ + (⌜ 1 ⌝ + mˡ) * steps y ×
     [ i ] steps y ≤ nʳ + (⌜ 1 ⌝ + mʳ) * steps x →
     [ i ∣ mˡ ∣ mʳ ∣ nˡ ∣ nʳ ] x ≈ y)                          □
  }
  where
  lemma :
    ∀ {m n i} →
    [ i ] m ≤ n →
    [ i ] m ≤ (⌜ 1 ⌝ + ⌜ 0 ⌝) * n
  lemma {m} {n} p =
    m                    ≤⟨ p ⟩
    n                    ∼⟨ Conat.symmetric-∼ (Conat.*-left-identity _) ⟩≤
    ⌜ 1 ⌝ * n            ∼⟨ Conat.symmetric-∼ (Conat.+-right-identity _) Conat.*-cong (_ ∎∼) ⟩≤
    (⌜ 1 ⌝ + ⌜ 0 ⌝) * n  ∎≤


------------------------------------------------------------------------
-- Total recognisers which can handle left recursion
------------------------------------------------------------------------

-- The recognisers are parametrised on the alphabet.

module TotalRecognisers.LeftRecursion (Tok : Set) where

open import Algebra
open import Codata.Musical.Notation
open import Data.Bool as Bool hiding (_∧_; _≤_)
import Data.Bool.Properties as Bool
private
  module BoolCS = CommutativeSemiring Bool.∧-∨-commutativeSemiring
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq
  using (_⇔_; equivalence; module Equivalence)
  renaming (_∘_ to _⟨∘⟩_)
open import Data.List using (List; []; _∷_; _++_; [_])
import Data.List.Properties
private
  module ListMonoid {A : Set} =
    Monoid (Data.List.Properties.++-monoid A)
open import Data.Product as Prod
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Decidable as Decidable

------------------------------------------------------------------------
-- A "right-strict" variant of _∧_

-- If the left-strict variant of _∧_ were used to type _·_ below, then
-- the inferred definition of D-nullable would not be total; it would
-- contain expressions of the form "D-nullable t (♭ p₁) ∧ false". With
-- the right-strict definition of _∧_ such expressions reduce to
-- "false".

infixr 6 _∧_

_∧_ : Bool → Bool → Bool
b ∧ true  = b
b ∧ false = false

-- A lemma.

left-zero : ∀ b → false ∧ b ≡ false
left-zero true  = refl
left-zero false = refl

------------------------------------------------------------------------
-- Recogniser combinators

infixl 10 _·_
infixl  5 _∣_

mutual

  -- The index is true if the corresponding language contains the empty
  -- string (is nullable).

  data P : Bool → Set where
    fail     : P false
    empty    : P true
    sat      : (Tok → Bool) → P false
    _∣_      : ∀ {n₁ n₂} →        P n₁ →        P n₂ → P (n₁ ∨ n₂)
    _·_      : ∀ {n₁ n₂} → ∞⟨ n₂ ⟩P n₁ → ∞⟨ n₁ ⟩P n₂ → P (n₁ ∧ n₂)
    nonempty : ∀ {n} → P n → P false
    cast     : ∀ {n₁ n₂} → n₁ ≡ n₂ → P n₁ → P n₂

  -- Delayed if the index is /false/.

  ∞⟨_⟩P : Bool → Bool → Set
  ∞⟨ false ⟩P n = ∞ (P n)
  ∞⟨ true  ⟩P n =    P n

-- Note that fail, nonempty and cast could be defined as derived
-- combinators. (For cast this is obvious, fail could be defined
-- either using sat or the combinator leftRight below, and nonempty is
-- defined in the module AlternativeNonempty. Note also that the proof
-- in TotalRecognisers.LeftRecursion.ExpressiveStrength does not rely
-- on these constructors.) However, Agda uses /guarded/ corecursion,
-- so the fact that nonempty and cast are constructors can be very
-- convenient when constructing other recognisers.

-- For an example of the use of nonempty, see the Kleene star example
-- in TotalRecognisers.LeftRecursion.Lib. For examples of the use of
-- cast, see TotalRecognisers.LeftRecursion.ExpressiveStrength and
-- TotalRecognisers.LeftRecursion.NotOnlyContextFree.

------------------------------------------------------------------------
-- Helpers

♭? : ∀ {b n} → ∞⟨ b ⟩P n → P n
♭? {b = false} x = ♭ x
♭? {b = true}  x =   x

♯? : ∀ {b n} → P n → ∞⟨ b ⟩P n
♯? {b = false} x = ♯ x
♯? {b = true}  x =   x

forced? : ∀ {b n} → ∞⟨ b ⟩P n → Bool
forced? {b = b} _ = b

-- A lemma.

♭?♯? : ∀ b {n} {p : P n} → ♭? {b} (♯? p) ≡ p
♭?♯? false = refl
♭?♯? true  = refl

------------------------------------------------------------------------
-- Semantics

-- The semantics is defined inductively: s ∈ p iff the string s is
-- contained in the language defined by p.

infix 4 _∈_

data _∈_ : ∀ {n} → List Tok → P n → Set where
  empty    : [] ∈ empty
  sat      : ∀ {f t} → T (f t) → [ t ] ∈ sat f
  ∣-left   : ∀ {s n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
             s ∈ p₁ → s ∈ p₁ ∣ p₂
  ∣-right  : ∀ {s n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
             s ∈ p₂ → s ∈ p₁ ∣ p₂
  _·_      : ∀ {s₁ s₂ n₁ n₂}
               {p₁ : ∞⟨ n₂ ⟩P n₁} {p₂ : ∞⟨ n₁ ⟩P n₂} →
             s₁ ∈ ♭? p₁ → s₂ ∈ ♭? p₂ → s₁ ++ s₂ ∈ p₁ · p₂
  nonempty : ∀ {n t s} {p : P n} →
             t ∷ s ∈ p → t ∷ s ∈ nonempty p
  cast     : ∀ {n₁ n₂ s} {p : P n₁} {eq : n₁ ≡ n₂} →
             s ∈ p → s ∈ cast eq p

infix 4 _≤_ _≈_

-- p₁ ≤ p₂ iff the language (defined by) p₂ contains all the strings
-- in the language p₁.

_≤_ : ∀ {n₁ n₂} → P n₁ → P n₂ → Set
p₁ ≤ p₂ = ∀ {s} → s ∈ p₁ → s ∈ p₂

-- p₁ ≈ p₂ iff the languages p₁ and p₂ contain the same strings.

_≈_ : ∀ {n₁ n₂} → P n₁ → P n₂ → Set
p₁ ≈ p₂ = ∀ {s} → s ∈ p₁ ⇔ s ∈ p₂

-- p₁ ≈ p₂ iff both p₁ ≤ p₂ and p₂ ≤ p₁.

≈⇔≤≥ : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
       p₁ ≈ p₂ ⇔ (p₁ ≤ p₂ × p₂ ≤ p₁)
≈⇔≤≥ = equivalence
         (λ p₁≈p₂  → ((λ {s} → _⟨$⟩_ (Equivalence.to   (p₁≈p₂ {s = s})))
                     , λ {s} → _⟨$⟩_ (Equivalence.from (p₁≈p₂ {s = s}))))
         (λ p₁≤≥p₂ {s} → equivalence (proj₁ p₁≤≥p₂ {s = s})
                                     (proj₂ p₁≤≥p₂ {s = s}))

-- Some lemmas.

cast∈ : ∀ {n} {p p′ : P n} {s s′} → s ≡ s′ → p ≡ p′ → s ∈ p → s′ ∈ p′
cast∈ refl refl s∈ = s∈

drop-♭♯ : ∀ n {n′} {p : P n′} → ♭? (♯? {n} p) ≤ p
drop-♭♯ n = cast∈ refl (♭?♯? n)

add-♭♯ : ∀ n {n′} {p : P n′} → p ≤ ♭? (♯? {n} p)
add-♭♯ n = cast∈ refl (sym $ ♭?♯? n)

------------------------------------------------------------------------
-- Example: A definition which is left and right recursive

leftRight : P false
leftRight = ♯ leftRight · ♯ leftRight

-- Note that leftRight is equivalent to fail, so fail does not need to
-- be a primitive combinator.

leftRight≈fail : leftRight ≈ fail
leftRight≈fail = equivalence ≤fail (λ ())
  where
  ≤fail : ∀ {s A} → s ∈ leftRight → A
  ≤fail (∈₁ · ∈₂) = ≤fail ∈₁

-- For more examples, see TotalRecognisers.LeftRecursion.Lib.

------------------------------------------------------------------------
-- Nullability

-- The nullability index is correct.

⇒ : ∀ {n} {p : P n} → [] ∈ p → n ≡ true
⇒ pr = ⇒′ pr refl
  where
  ⇒′ : ∀ {n s} {p : P n} → s ∈ p → s ≡ [] → n ≡ true
  ⇒′ empty                   refl = refl
  ⇒′ (sat _)                 ()
  ⇒′ (∣-left            pr₁) refl with ⇒ pr₁
  ⇒′ (∣-left            pr₁) refl | refl = refl
  ⇒′ (∣-right           pr₂) refl with ⇒ pr₂
  ⇒′ (∣-right {n₁ = n₁} pr₂) refl | refl = proj₂ BoolCS.zero n₁
  ⇒′ (nonempty p)            ()
  ⇒′ (cast {eq = refl} p)    refl = ⇒′ p refl
  ⇒′ (_·_ {[]}    pr₁ pr₂)   refl = cong₂ _∧_ (⇒ pr₁) (⇒ pr₂)
  ⇒′ (_·_ {_ ∷ _} pr₁ pr₂)   ()

⇐ : ∀ {n} (p : P n) → n ≡ true → [] ∈ p
⇐ fail                        ()
⇐ empty                       refl = empty
⇐ (sat f)                     ()
⇐ (_∣_ {true}          p₁ p₂) refl = ∣-left            (⇐ p₁ refl)
⇐ (_∣_ {false} {true}  p₁ p₂) refl = ∣-right {p₁ = p₁} (⇐ p₂ refl)
⇐ (_∣_ {false} {false} p₁ p₂) ()
⇐ (nonempty p)                ()
⇐ (cast refl p)               refl = cast (⇐ p refl)
⇐ (_·_ {.true} {true}  p₁ p₂) refl = ⇐ p₁ refl · ⇐ p₂ refl
⇐ (_·_ {_}     {false} p₁ p₂) ()

index-correct : ∀ {n} {p : P n} → [] ∈ p ⇔ n ≡ true
index-correct = equivalence ⇒ (⇐ _)

-- We can decide if the empty string belongs to a given language.

nullable? : ∀ {n} (p : P n) → Dec ([] ∈ p)
nullable? {n} p = Decidable.map (Eq.sym index-correct) (Bool._≟_ n true)

------------------------------------------------------------------------
-- Derivative

-- The index of the derivative.

D-nullable : ∀ {n} → Tok → P n → Bool
D-nullable t fail         = false
D-nullable t empty        = false
D-nullable t (sat f)      = f t
D-nullable t (p₁ ∣ p₂)    = D-nullable t p₁ ∨ D-nullable t p₂
D-nullable t (nonempty p) = D-nullable t p
D-nullable t (cast _ p)   = D-nullable t p
D-nullable t (p₁ · p₂)    with forced? p₁ | forced? p₂
... | true  | false = D-nullable t p₁
... | false | false = false
... | true  | true  = D-nullable t p₁ ∨ D-nullable t p₂
... | false | true  = D-nullable t p₂

-- D t p is the "derivative" of p with respect to t. It is specified
-- by the equivalence s ∈ D t p ⇔ t ∷ s ∈ p (proved below).

D : ∀ {n} (t : Tok) (p : P n) → P (D-nullable t p)
D t fail         = fail
D t empty        = fail
D t (sat f)      with f t
...              | true  = empty
...              | false = fail
D t (p₁ ∣ p₂)    = D t p₁ ∣ D t p₂
D t (nonempty p) = D t p
D t (cast _ p)   = D t p
D t (p₁ · p₂)    with forced? p₁ | forced? p₂
... | true  | false =   D t    p₁  · ♯? (♭ p₂)
... | false | false = ♯ D t (♭ p₁) · ♯? (♭ p₂)
... | true  | true  =   D t    p₁  · ♯?    p₂ ∣ D t p₂
... | false | true  = ♯ D t (♭ p₁) · ♯?    p₂ ∣ D t p₂

-- D is correct.

D-sound : ∀ {n s t} {p : P n} → s ∈ D t p → t ∷ s ∈ p
D-sound s∈ = D-sound′ _ _ s∈
  where
  sat-lemma : ∀ {s} f t → s ∈ D t (sat f) → T (f t) × s ≡ []
  sat-lemma f t ∈ with f t
  sat-lemma f t empty | true  = (_ , refl)
  sat-lemma f t ()    | false

  D-sound′ : ∀ {s n} (p : P n) t → s ∈ D t p → t ∷ s ∈ p
  D-sound′ fail         t ()
  D-sound′ empty        t ()
  D-sound′ (sat f)      t s∈                  with sat-lemma f t s∈
  ...                                         | (ok , refl) = sat ok
  D-sound′ (p₁ ∣ p₂)    t (∣-left  ∈₁)        = ∣-left (D-sound′ p₁ t ∈₁)
  D-sound′ (p₁ ∣ p₂)    t (∣-right ∈₂)        = ∣-right {p₁ = p₁} (D-sound′ p₂ t ∈₂)
  D-sound′ (nonempty p) t ∈                   = nonempty (D-sound ∈)
  D-sound′ (cast _ p)   t ∈                   = cast (D-sound ∈)
  D-sound′ (p₁ · p₂)    t s∈                  with forced? p₁ | forced? p₂
  D-sound′ (p₁ · p₂)    t (∣-left  (∈₁ · ∈₂)) | true  | true  = D-sound ∈₁ · drop-♭♯ (D-nullable t p₁) ∈₂
  D-sound′ (p₁ · p₂)    t (∣-right ∈₂)        | true  | true  = ⇐ p₁ refl · D-sound′ p₂ t ∈₂
  D-sound′ (p₁ · p₂)    t (∣-left  (∈₁ · ∈₂)) | false | true  = D-sound ∈₁ · drop-♭♯ (D-nullable t (♭ p₁)) ∈₂
  D-sound′ (p₁ · p₂)    t (∣-right ∈₂)        | false | true  = ⇐ (♭ p₁) refl · D-sound′ p₂ t ∈₂
  D-sound′ (p₁ · p₂)    t (∈₁ · ∈₂)           | true  | false = D-sound ∈₁ · drop-♭♯ (D-nullable t    p₁ ) ∈₂
  D-sound′ (p₁ · p₂)    t (∈₁ · ∈₂)           | false | false = D-sound ∈₁ · drop-♭♯ (D-nullable t (♭ p₁)) ∈₂

D-complete : ∀ {n s t} {p : P n} → t ∷ s ∈ p → s ∈ D t p
D-complete {t = t} t∷s∈ = D-complete′ _ t∷s∈ refl
  where
  D-complete′ : ∀ {s s′ n} (p : P n) → s′ ∈ p → s′ ≡ t ∷ s → s ∈ D t p
  D-complete′ fail         ()                   refl
  D-complete′ empty        ()                   refl
  D-complete′ (sat f)      (sat ok)             refl with f t
  D-complete′ (sat f)      (sat ok)             refl | true  = empty
  D-complete′ (sat f)      (sat ())             refl | false
  D-complete′ (p₁ ∣ p₂)    (∣-left  ∈₁)         refl = ∣-left                (D-complete ∈₁)
  D-complete′ (p₁ ∣ p₂)    (∣-right ∈₂)         refl = ∣-right {p₁ = D t p₁} (D-complete ∈₂)
  D-complete′ (nonempty p) (nonempty ∈)         refl = D-complete ∈
  D-complete′ (cast _ p)   (cast ∈)             refl = D-complete ∈
  D-complete′ (p₁ · p₂)    _                    _    with forced? p₁ | forced? p₂
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | true  | true  = ∣-right {p₁ = D t p₁ · _} (D-complete ∈₂)
  D-complete′ (p₁ · p₂)    (_·_ {._ ∷ _} ∈₁ ∈₂) refl | true  | true  = ∣-left (D-complete ∈₁ · add-♭♯ (D-nullable t p₁) ∈₂)
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | true  | false with ⇒ ∈₁
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | true  | false | ()
  D-complete′ (p₁ · p₂)    (_·_ {._ ∷ _} ∈₁ ∈₂) refl | true  | false = D-complete ∈₁ · add-♭♯ (D-nullable t p₁) ∈₂
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | false | true  = ∣-right {p₁ = _·_ {n₂ = false} _ _} (D-complete ∈₂)
  D-complete′ (p₁ · p₂)    (_·_ {._ ∷ _} ∈₁ ∈₂) refl | false | true  = ∣-left (D-complete ∈₁ · add-♭♯ (D-nullable t (♭ p₁)) ∈₂)
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | false | false with ⇒ ∈₁
  D-complete′ (p₁ · p₂)    (_·_ {[]}     ∈₁ ∈₂) refl | false | false | ()
  D-complete′ (p₁ · p₂)    (_·_ {._ ∷ _} ∈₁ ∈₂) refl | false | false = D-complete ∈₁ · add-♭♯ (D-nullable t (♭ p₁)) ∈₂

D-correct : ∀ {n s t} {p : P n} → s ∈ D t p ⇔ t ∷ s ∈ p
D-correct = equivalence D-sound D-complete

------------------------------------------------------------------------
-- _∈_ is decidable

-- _∈?_ runs a recogniser. Note that the result is yes or no plus a
-- /proof/ verifying that the answer is correct.

infix 4 _∈?_

_∈?_ : ∀ {n} (s : List Tok) (p : P n) → Dec (s ∈ p)
[]    ∈? p = nullable? p
t ∷ s ∈? p with s ∈? D t p
t ∷ s ∈? p | yes s∈Dtp = yes (D-sound s∈Dtp)
t ∷ s ∈? p | no  s∉Dtp = no  (s∉Dtp ∘ D-complete)

-- The last three lines could be replaced by the following one:
--
-- t ∷ s ∈? p = Decidable.map D-correct (s ∈? D t p)

------------------------------------------------------------------------
-- Alternative characterisation of equality

infix 5 _∷_
infix 4 _≈′_

-- Two recognisers/languages are equal if their nullability indices
-- are equal and all their derivatives are equal (coinductively). Note
-- that the elements of this type are bisimulations.

data _≈′_ {n₁ n₂} (p₁ : P n₁) (p₂ : P n₂) : Set where
  _∷_ : n₁ ≡ n₂ → (∀ t → ∞ (D t p₁ ≈′ D t p₂)) → p₁ ≈′ p₂

-- This definition is equivalent to the one above.

≈′-sound : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} → p₁ ≈′ p₂ → p₁ ≈ p₂
≈′-sound (refl ∷ rest) {[]}    = Eq.sym index-correct ⟨∘⟩ index-correct
≈′-sound (refl ∷ rest) {t ∷ s} =
  D-correct ⟨∘⟩ ≈′-sound (♭ (rest t)) ⟨∘⟩ Eq.sym D-correct

same-nullability : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
                   p₁ ≈ p₂ → n₁ ≡ n₂
same-nullability p₁≈p₂ =
  Bool.⇔→≡ (index-correct ⟨∘⟩ p₁≈p₂ ⟨∘⟩ Eq.sym index-correct)

D-cong : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} {t} →
         p₁ ≈ p₂ → D t p₁ ≈ D t p₂
D-cong p₁≈p₂ = Eq.sym D-correct ⟨∘⟩ p₁≈p₂ ⟨∘⟩ D-correct

≈′-complete : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} → p₁ ≈ p₂ → p₁ ≈′ p₂
≈′-complete p₁≈p₂ =
  same-nullability p₁≈p₂ ∷ λ _ → ♯ ≈′-complete (D-cong p₁≈p₂)

≈′-correct : ∀ {n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} → p₁ ≈′ p₂ ⇔ p₁ ≈ p₂
≈′-correct = equivalence ≈′-sound ≈′-complete

------------------------------------------------------------------------
-- The combinator nonempty does not need to be primitive

-- The variant of nonempty which is defined below (nonempty′) makes
-- many recognisers larger, though.

module AlternativeNonempty where

  nonempty′ : ∀ {n} → P n → P false
  nonempty′ fail         = fail
  nonempty′ empty        = fail
  nonempty′ (sat f)      = sat f
  nonempty′ (p₁ ∣ p₂)    = nonempty′ p₁ ∣ nonempty′ p₂
  nonempty′ (nonempty p) = nonempty′ p
  nonempty′ (cast eq p)  = nonempty′ p
  nonempty′ (p₁ · p₂)    with forced? p₁ | forced? p₂
  ... | false | _     = p₁ · p₂
  ... | true  | false = p₁ · p₂
  ... | true  | true  = nonempty′ p₁ ∣ nonempty′ p₂
                      ∣ ♯ nonempty′ p₁ · ♯ nonempty′ p₂

  sound : ∀ {n} {p : P n} → nonempty′ p ≤ nonempty p
  sound {s = []}    pr with ⇒ pr
  ... | ()
  sound {s = _ ∷ _} pr = nonempty (sound′ _ pr refl)
    where
    sound′ : ∀ {n t s s′} (p : P n) →
             s′ ∈ nonempty′ p → s′ ≡ t ∷ s → t ∷ s ∈ p
    sound′ fail         ()                              refl
    sound′ empty        ()                              refl
    sound′ (sat f)      (sat ok)                        refl = sat ok
    sound′ (p₁ ∣ p₂)    (∣-left  pr)                    refl = ∣-left            (sound′ p₁ pr refl)
    sound′ (p₁ ∣ p₂)    (∣-right pr)                    refl = ∣-right {p₁ = p₁} (sound′ p₂ pr refl)
    sound′ (nonempty p) pr                              refl = nonempty (sound′ p pr refl)
    sound′ (cast _ p)   pr                              refl = cast (sound′ p pr refl)
    sound′ (p₁ · p₂)    pr                              _    with forced? p₁ | forced? p₂
    sound′ (p₁ · p₂)    pr                              refl | false | _     = pr
    sound′ (p₁ · p₂)    pr                              refl | true  | false = pr
    sound′ (p₁ · p₂)    (∣-left (∣-left  pr))           refl | true  | true  = cast∈ (proj₂ ListMonoid.identity _) refl $
                                                                                sound′ p₁ pr refl · ⇐ p₂ refl
    sound′ (p₁ · p₂)    (∣-left (∣-right pr))           refl | true  | true  = ⇐ p₁ refl · sound′ p₂ pr refl
    sound′ (p₁ · p₂)    (∣-right (_·_ {[]}    pr₁ pr₂)) refl | true  | true  with ⇒ pr₁
    ... | ()
    sound′ (p₁ · p₂)    (∣-right (_·_ {_ ∷ _} pr₁ pr₂)) refl | true  | true  with sound {p = p₂} pr₂
    ... | nonempty pr₂′ = sound′ p₁ pr₁ refl · pr₂′

  complete : ∀ {n} {p : P n} → nonempty p ≤ nonempty′ p
  complete (nonempty pr) = complete′ _ pr refl
    where
    complete′ : ∀ {n t s s′} (p : P n) →
                s ∈ p → s ≡ t ∷ s′ → t ∷ s′ ∈ nonempty′ p
    complete′ fail         ()                            refl
    complete′ empty        ()                            refl
    complete′ (sat f)      (sat ok)                      refl = sat ok
    complete′ (p₁ ∣ p₂)    (∣-left pr)                   refl = ∣-left               (complete′ p₁ pr refl)
    complete′ (p₁ ∣ p₂)    (∣-right pr)                  refl = ∣-right {n₁ = false} (complete′ p₂ pr refl)
    complete′ (nonempty p) (nonempty pr)                 refl = complete′ p pr refl
    complete′ (cast _ p)   (cast pr)                     refl = complete′ p pr refl
    complete′ (p₁ · p₂)    pr                            _    with forced? p₁ | forced? p₂
    complete′ (p₁ · p₂)    pr                            refl | false | _     = pr
    complete′ (p₁ · p₂)    pr                            refl | true  | false = pr
    complete′ (p₁ · p₂)    (_·_ {[]}            pr₁ pr₂) refl | true  | true  = ∣-left (∣-right {n₁ = false} (complete′ p₂ pr₂ refl))
    complete′ (p₁ · p₂)    (_·_ {_ ∷ _} {[]}    pr₁ pr₂) refl | true  | true  = cast∈ (sym $ proj₂ ListMonoid.identity _) refl $
                                                                                ∣-left (∣-left {n₂ = false} (complete′ p₁ pr₁ refl))
    complete′ (p₁ · p₂)    (_·_ {_ ∷ _} {_ ∷ _} pr₁ pr₂) refl | true  | true  = ∣-right {n₁ = false} (complete′ p₁ pr₁ refl ·
                                                                                complete′ p₂ pr₂ refl)

  correct : ∀ {n} {p : P n} → nonempty′ p ≈ nonempty p
  correct = equivalence sound complete


{-# OPTIONS --safe #-}

-- This is a file for dealing with Monuses: these are monoids that are like the
-- positive half of a group. Much of my info on them comes from these papers:
--
-- * Wehrung, Friedrich. ‘Injective Positively Ordered Monoids I’. Journal of
--   Pure and Applied Algebra 83, no. 1 (11 November 1992): 43–82.
--   https://doi.org/10.1016/0022-4049(92)90104-N.
-- * Wehrung, Friedrich. ‘Embedding Simple Commutative Monoids into Simple
--   Refinement Monoids’. Semigroup Forum 56, no. 1 (January 1998): 104–29.
--   https://doi.org/10.1007/s00233-002-7008-0.
-- * Amer, K. ‘Equationally Complete Classes of Commutative Monoids with Monus’.
--   Algebra Universalis 18, no. 1 (1 February 1984): 129–31.
--   https://doi.org/10.1007/BF01182254.
-- * Wehrung, Friedrich. ‘Metric Properties of Positively Ordered Monoids’.
--   Forum Mathematicum 5, no. 5 (1993).
--   https://doi.org/10.1515/form.1993.5.183.
-- * Wehrung, Friedrich. ‘Restricted Injectivity, Transfer Property and
--   Decompositions of Separative Positively Ordered Monoids.’ Communications in
--   Algebra 22, no. 5 (1 January 1994): 1747–81.
--   https://doi.org/10.1080/00927879408824934.
--
-- These monoids have a preorder defined on them, the algebraic preorder:
--
--   x ≤ y = ∃ z × (y ≡ x ∙ z)
--
-- The _∸_ operator extracts the z from above, if it exists.

module Algebra.Monus where

open import Prelude
open import Algebra
open import Relation.Binary
open import Path.Reasoning
open import Function.Reasoning

-- Positively ordered monoids.
--
-- These are monoids which have a preorder that respects the monoid operation
-- in a straightforward way.
record POM ℓ₁ ℓ₂ : Type (ℓsuc (ℓ₁ ℓ⊔ ℓ₂)) where
  field commutativeMonoid : CommutativeMonoid ℓ₁
  open CommutativeMonoid commutativeMonoid public
  field preorder : Preorder 𝑆 ℓ₂
  open Preorder preorder public renaming (refl to ≤-refl)
  field
    positive : ∀ x → ε ≤ x
    ≤-cong : ∀ x {y z} → y ≤ z → x ∙ y ≤ x ∙ z

  x≤x∙y : ∀ {x y} → x ≤ x ∙ y
  x≤x∙y {x} {y} = subst (_≤ x ∙ y) (∙ε x) (≤-cong x (positive y))

  ≤-congʳ : ∀ x {y z} → y ≤ z → y ∙ x ≤ z ∙ x
  ≤-congʳ x {y} {z} p = subst₂ _≤_ (comm x y) (comm x z) (≤-cong x p)

  alg-≤-trans : ∀ {x y z k₁ k₂} → y ≡ x ∙ k₁ → z ≡ y ∙ k₂ → z ≡ x ∙ (k₁ ∙ k₂)
  alg-≤-trans {x} {y} {z} {k₁} {k₂} y≡x∙k₁ z≡y∙k₂ =
    z             ≡⟨ z≡y∙k₂ ⟩
    y ∙ k₂        ≡⟨ cong (_∙ k₂) y≡x∙k₁ ⟩
    (x ∙ k₁) ∙ k₂ ≡⟨ assoc x k₁ k₂ ⟩
    x ∙ (k₁ ∙ k₂) ∎

  infix 4 _≺_
  _≺_ : 𝑆 → 𝑆 → Type _
  x ≺ y = ∃ k × (y ≡ x ∙ k) × (k ≢ ε)

-- Total Antisymmetric POM
record TAPOM ℓ₁ ℓ₂ : Type (ℓsuc (ℓ₁ ℓ⊔ ℓ₂)) where
  field pom : POM ℓ₁ ℓ₂
  open POM pom public using (preorder; _≤_; ≤-cong; ≤-congʳ; x≤x∙y; commutativeMonoid; positive)
  open CommutativeMonoid commutativeMonoid public
  field
    _≤|≥_   : Total _≤_
    antisym : Antisymmetric _≤_

  totalOrder : TotalOrder 𝑆 ℓ₂ ℓ₂
  totalOrder = fromPartialOrder (record { preorder = preorder ; antisym = antisym }) _≤|≥_
  open TotalOrder totalOrder public hiding (_≤|≥_; antisym) renaming (refl to ≤-refl)

-- Every commutative monoid generates a positively ordered monoid
-- called the "algebraic" or "minimal" pom
module AlgebraicPOM {ℓ} (mon : CommutativeMonoid ℓ) where
  commutativeMonoid = mon
  open CommutativeMonoid mon

  infix 4 _≤_
  _≤_ : 𝑆 → 𝑆 → Type _
  x ≤ y = ∃ z × (y ≡ x ∙ z)

  -- The snd here is the same proof as alg-≤-trans, so could be refactored out.
  ≤-trans : Transitive _≤_
  ≤-trans (k₁ , _) (k₂ , _) .fst = k₁ ∙ k₂
  ≤-trans {x} {y} {z} (k₁ , y≡x∙k₁) (k₂ , z≡y∙k₂) .snd =
    z             ≡⟨ z≡y∙k₂ ⟩
    y ∙ k₂        ≡⟨ cong (_∙ k₂) y≡x∙k₁ ⟩
    (x ∙ k₁) ∙ k₂ ≡⟨ assoc x k₁ k₂ ⟩
    x ∙ (k₁ ∙ k₂) ∎

  preorder : Preorder 𝑆 ℓ
  Preorder._≤_ preorder = _≤_
  Preorder.refl preorder = ε , sym (∙ε _)
  Preorder.trans preorder = ≤-trans

  positive : ∀ x → ε ≤ x
  positive x = x , sym (ε∙ x)

  ≤-cong : ∀ x {y z} → y ≤ z → x ∙ y ≤ x ∙ z
  ≤-cong x (k , z≡y∙k) = k , cong (x ∙_) z≡y∙k ; sym (assoc x _ k)

algebraic-pom : ∀ {ℓ} → CommutativeMonoid ℓ → POM ℓ ℓ
algebraic-pom mon = record { AlgebraicPOM mon }

-- Total Minimal POM
record TMPOM ℓ : Type (ℓsuc ℓ) where
  field commutativeMonoid : CommutativeMonoid ℓ

  pom : POM _ _
  pom = algebraic-pom commutativeMonoid

  open POM pom public

  infix 4 _≤|≥_
  field _≤|≥_ : Total _≤_

  <⇒≺ : ∀ x y → y ≰ x → x ≺ y
  <⇒≺ x y x<y with x ≤|≥ y
  ... | inr y≤x = ⊥-elim (x<y y≤x)
  ... | inl (k , y≡x∙k) = λ
    where
    .fst → k
    .snd .fst → y≡x∙k
    .snd .snd k≡ε → x<y (ε , sym (∙ε y ; y≡x∙k ; cong (x ∙_) k≡ε ; ∙ε x))

  infixl 6 _∸_
  _∸_ : 𝑆 → 𝑆 → 𝑆
  x ∸ y = either′ (const ε) fst (x ≤|≥ y)

  x∸y≤x : ∀ x y → x ∸ y ≤ x
  x∸y≤x x y with x ≤|≥ y
  ... | inl (k , p) = positive x
  ... | inr (k , x≡y∙k) = y , x≡y∙k ; comm y k

-- Total Minimal Antisymmetric POM
record TMAPOM ℓ : Type (ℓsuc ℓ) where
  field tmpom : TMPOM ℓ
  open TMPOM tmpom public using (_≤_; _≤|≥_; positive; alg-≤-trans; _≺_; <⇒≺; _∸_; x∸y≤x)
  field antisym : Antisymmetric _≤_

  tapom : TAPOM _ _
  TAPOM.pom tapom = TMPOM.pom tmpom
  TAPOM._≤|≥_ tapom = _≤|≥_
  TAPOM.antisym tapom = antisym

  open TAPOM tapom public hiding (antisym; _≤|≥_; _≤_; positive)

  zeroSumFree : ∀ x y → x ∙ y ≡ ε → x ≡ ε
  zeroSumFree x y x∙y≡ε = antisym (y , sym x∙y≡ε) (positive x)

  ≤‿∸‿cancel : ∀ x y → x ≤ y → (y ∸ x) ∙ x ≡ y
  ≤‿∸‿cancel x y x≤y with y ≤|≥ x
  ... | inl y≤x = ε∙ x ; antisym x≤y y≤x
  ... | inr (k , y≡x∙k) = comm k x ; sym y≡x∙k

  ∸‿comm : ∀ x y → x ∙ (y ∸ x) ≡ y ∙ (x ∸ y)
  ∸‿comm x y with y ≤|≥ x | x ≤|≥ y
  ... | inl y≤x | inl x≤y = cong (_∙ ε) (antisym x≤y y≤x)
  ... | inr (k , y≡x∙k) | inl x≤y = sym y≡x∙k ; sym (∙ε y)
  ... | inl y≤x | inr (k , x≥y) = ∙ε x ; x≥y
  ... | inr (k₁ , y≡x∙k₁) | inr (k₂ , x≡y∙k₂) =
    x ∙ k₁ ≡˘⟨ y≡x∙k₁ ⟩
    y      ≡⟨ antisym  (k₂ , x≡y∙k₂) (k₁ , y≡x∙k₁) ⟩
    x      ≡⟨ x≡y∙k₂ ⟩
    y ∙ k₂ ∎

  ∸‿≺ : ∀ x y → x ≢ ε → y ≢ ε → x ∸ y ≺ x
  ∸‿≺ x y x≢ε y≢ε with x ≤|≥ y
  ... | inl _ = x , sym (ε∙ x) , x≢ε
  ... | inr (k , x≡y∙k) = y , x≡y∙k ; comm y k , y≢ε

-- Commutative Monoids with Monus
record CMM ℓ : Type (ℓsuc ℓ) where
  field commutativeMonoid : CommutativeMonoid ℓ

  pom : POM _ _
  pom = algebraic-pom commutativeMonoid

  open POM pom public

  field _∸_ : 𝑆 → 𝑆 → 𝑆
  infixl 6 _∸_
  field
    ∸‿comm  : ∀ x y → x ∙ (y ∸ x) ≡ y ∙ (x ∸ y)
    ∸‿assoc : ∀ x y z → (x ∸ y) ∸ z ≡ x ∸ (y ∙ z)
    ∸‿inv   : ∀ x → x ∸ x ≡ ε
    ε∸      : ∀ x → ε ∸ x ≡ ε

  ∸ε : ∀ x → x ∸ ε ≡ x
  ∸ε x =
    x ∸ ε       ≡˘⟨ ε∙ (x ∸ ε) ⟩
    ε ∙ (x ∸ ε) ≡⟨ ∸‿comm ε x ⟩
    x ∙ (ε ∸ x) ≡⟨ cong (x ∙_) (ε∸ x) ⟩
    x ∙ ε       ≡⟨ ∙ε x ⟩
    x ∎

  ∸≤ : ∀ x y → x ≤ y → x ∸ y ≡ ε
  ∸≤ x y (k , y≡x∙k) =
    x ∸ y       ≡⟨ cong (x ∸_) y≡x∙k ⟩
    x ∸ (x ∙ k) ≡˘⟨ ∸‿assoc x x k ⟩
    (x ∸ x) ∸ k ≡⟨ cong (_∸ k) (∸‿inv x) ⟩
    ε ∸ k       ≡⟨ ε∸ k ⟩
    ε ∎

  ∣_-_∣ : 𝑆 → 𝑆 → 𝑆
  ∣ x - y ∣ = (x ∸ y) ∙ (y ∸ x)

  _⊔₂_ : 𝑆 → 𝑆 → 𝑆
  x ⊔₂ y = x ∙ y ∙ ∣ x - y ∣

  _⊓₂_ : 𝑆 → 𝑆 → 𝑆
  x ⊓₂ y = (x ∙ y) ∸ ∣ x - y ∣

-- Cancellative Commutative Monoids with Monus
record CCMM ℓ : Type (ℓsuc ℓ) where
  field cmm : CMM ℓ
  open CMM cmm public

  field ∸‿cancel : ∀ x y → (x ∙ y) ∸ x ≡ y

  cancelˡ : Cancellativeˡ _∙_
  cancelˡ x y z x∙y≡x∙z =
    y           ≡˘⟨ ∸‿cancel x y ⟩
    (x ∙ y) ∸ x ≡⟨ cong (_∸ x) x∙y≡x∙z ⟩
    (x ∙ z) ∸ x ≡⟨ ∸‿cancel x z ⟩
    z ∎

  cancelʳ : Cancellativeʳ _∙_
  cancelʳ x y z y∙x≡z∙x =
    y           ≡˘⟨ ∸‿cancel x y ⟩
    (x ∙ y) ∸ x ≡⟨ cong (_∸ x) (comm x y) ⟩
    (y ∙ x) ∸ x ≡⟨ cong (_∸ x) y∙x≡z∙x ⟩
    (z ∙ x) ∸ x ≡⟨ cong (_∸ x) (comm z x) ⟩
    (x ∙ z) ∸ x ≡⟨ ∸‿cancel x z ⟩
    z ∎

  zeroSumFree : ∀ x y → x ∙ y ≡ ε → x ≡ ε
  zeroSumFree x y x∙y≡ε =
    x           ≡˘⟨ ∸‿cancel y x ⟩
    (y ∙ x) ∸ y ≡⟨ cong (_∸ y) (comm y x) ⟩
    (x ∙ y) ∸ y ≡⟨ cong (_∸ y) x∙y≡ε ⟩
    ε ∸ y       ≡⟨ ε∸ y ⟩
    ε ∎

  antisym : Antisymmetric _≤_
  antisym {x} {y} (k₁ , y≡x∙k₁) (k₂ , x≡y∙k₂) =
      x      ≡⟨ x≡y∙k₂ ⟩
      y ∙ k₂ ≡⟨ [ lemma                 ]⇒ y ∙ ε   ≡ y ∙ (k₂ ∙ k₁)
                ⟨ cancelˡ y ε (k₂ ∙ k₁) ⟩⇒ ε       ≡ k₂ ∙ k₁
                ⟨ sym                   ⟩⇒ k₂ ∙ k₁ ≡ ε
                ⟨ zeroSumFree k₂ k₁     ⟩⇒ k₂      ≡ ε
                ⟨ cong (y ∙_)           ⟩⇒ y ∙ k₂  ≡ y ∙ ε ⇒∎ ⟩
      y ∙ ε  ≡⟨ ∙ε y ⟩
      y ∎
    where
    lemma = ∙ε y ; alg-≤-trans x≡y∙k₂ y≡x∙k₁

  partialOrder : PartialOrder _ _
  PartialOrder.preorder partialOrder = preorder
  PartialOrder.antisym partialOrder = antisym

  ≺⇒< : ∀ x y → x ≺ y → y ≰ x
  ≺⇒< x y (k₁ , y≡x∙k₁ , k₁≢ε) (k₂ , x≡y∙k₂) =
    [ x ∙ ε         ≡⟨ ∙ε x ⟩
      x             ≡⟨ x≡y∙k₂ ⟩
      y ∙ k₂        ≡⟨ cong (_∙ k₂) y≡x∙k₁ ⟩
      (x ∙ k₁) ∙ k₂ ≡⟨ assoc x k₁ k₂ ⟩
      x ∙ (k₁ ∙ k₂) ∎       ]⇒ x ∙ ε ≡ x ∙ (k₁ ∙ k₂)
    ⟨ cancelˡ x ε (k₁ ∙ k₂) ⟩⇒ ε ≡ k₁ ∙ k₂
    ⟨ sym                   ⟩⇒ k₁ ∙ k₂ ≡ ε
    ⟨ zeroSumFree k₁ k₂     ⟩⇒ k₁ ≡ ε
    ⟨ k₁≢ε                  ⟩⇒ ⊥ ⇒∎

  ≤⇒<⇒≢ε : ∀ x y → (x≤y : x ≤ y) → y ≰ x → fst x≤y ≢ ε
  ≤⇒<⇒≢ε x y (k₁ , y≡x∙k₁) y≰x k₁≡ε = y≰x λ
    where
    .fst → ε
    .snd → x      ≡˘⟨ ∙ε x ⟩
           x ∙ ε  ≡˘⟨ cong (x ∙_) k₁≡ε ⟩
           x ∙ k₁ ≡˘⟨ y≡x∙k₁ ⟩
           y      ≡˘⟨ ∙ε y ⟩
           y ∙ ε ∎

  ≤-cancelʳ : ∀ x y z → y ∙ x ≤ z ∙ x → y ≤ z
  ≤-cancelʳ x y z (k , z∙x≡y∙x∙k) .fst = k
  ≤-cancelʳ x y z (k , z∙x≡y∙x∙k) .snd = cancelʳ x z (y ∙ k) $
    z ∙ x ≡⟨ z∙x≡y∙x∙k ⟩
    (y ∙ x) ∙ k ≡⟨ assoc y x k ⟩
    y ∙ (x ∙ k) ≡⟨ cong (y ∙_) (comm x k) ⟩
    y ∙ (k ∙ x) ≡˘⟨ assoc y k x ⟩
    (y ∙ k) ∙ x ∎

  ≤-cancelˡ : ∀ x y z → x ∙ y ≤ x ∙ z → y ≤ z
  ≤-cancelˡ x y z (k , x∙z≡x∙y∙k) .fst = k
  ≤-cancelˡ x y z (k , x∙z≡x∙y∙k) .snd =
    cancelˡ x z (y ∙ k) (x∙z≡x∙y∙k ; assoc x y k)

  ≺-irrefl : Irreflexive _≺_
  ≺-irrefl {x} (k , x≡x∙k , k≢ε) = k≢ε (sym (cancelˡ x ε k (∙ε x ; x≡x∙k)))

  ≤∸ : ∀ x y → (x≤y : x ≤ y) → y ∸ x ≡ fst x≤y
  ≤∸ x y (k , y≡x∙k) =
   y ∸ x       ≡⟨ cong (_∸ x) y≡x∙k ⟩
   (x ∙ k) ∸ x ≡⟨ ∸‿cancel x k ⟩
   k ∎

  ≤‿∸‿cancel : ∀ x y → x ≤ y → (y ∸ x) ∙ x ≡ y
  ≤‿∸‿cancel x y (k , y≡x∙k) =
    (y ∸ x) ∙ x ≡⟨ cong (λ y → (y ∸ x) ∙ x) y≡x∙k ⟩
    ((x ∙ k) ∸ x) ∙ x ≡⟨ cong (_∙ x) (∸‿cancel x k) ⟩
    k ∙ x ≡⟨ comm k x ⟩
    x ∙ k ≡˘⟨ y≡x∙k ⟩
    y ∎

-- Cancellative total minimal antisymmetric pom (has monus)
record CTMAPOM ℓ : Type (ℓsuc ℓ) where
  field tmapom : TMAPOM ℓ
  open TMAPOM tmapom public
  field cancel : Cancellativeˡ _∙_

  module cmm where
    ∸≤ : ∀ x y → x ≤ y → x ∸ y ≡ ε
    ∸≤ x y x≤y with x ≤|≥ y
    ∸≤ x y x≤y | inl _ = refl
    ∸≤ x y (k₁ , y≡x∙k₁) | inr (k₂ , x≡y∙k₂) =
      [ lemma                ]⇒ y ∙ ε   ≡ y ∙ (k₂ ∙ k₁)
      ⟨ cancel y ε (k₂ ∙ k₁) ⟩⇒ ε       ≡ k₂ ∙ k₁
      ⟨ sym                  ⟩⇒ k₂ ∙ k₁ ≡ ε
      ⟨ zeroSumFree k₂ k₁    ⟩⇒ k₂      ≡ ε ⇒∎
      where
      lemma = ∙ε y ; alg-≤-trans x≡y∙k₂ y≡x∙k₁

    ∸‿inv : ∀ x → x ∸ x ≡ ε
    ∸‿inv x = ∸≤ x x ≤-refl

    ε∸ : ∀ x → ε ∸ x ≡ ε
    ε∸ x = ∸≤ ε x (positive x)

    ∸‿assoc : ∀ x y z → (x ∸ y) ∸ z ≡ x ∸ (y ∙ z)
    ∸‿assoc x y z with x ≤|≥ y
    ∸‿assoc x y z | inl x≤y  = ε∸ z ; sym (∸≤ x (y ∙ z) (≤-trans x≤y x≤x∙y))
    ∸‿assoc x y z | inr x≥y with x ≤|≥ y ∙ z
    ∸‿assoc x y z | inr (k₁ , x≡y∙k₁) | inl (k₂ , y∙z≡x∙k₂) = ∸≤ k₁ z (k₂ , lemma)
      where
      lemma : z ≡ k₁ ∙ k₂
      lemma = cancel y z (k₁ ∙ k₂) (alg-≤-trans x≡y∙k₁ y∙z≡x∙k₂)

    ∸‿assoc x y z | inr (k , x≡y∙k) | inr x≥y∙z with k ≤|≥ z
    ∸‿assoc x y z | inr (k₁ , x≡y∙k₁) | inr (k₂ , x≡y∙z∙k₂) | inl (k₃ , z≡k₁∙k₃) =
        [ lemma₁            ]⇒ ε       ≡ k₂ ∙ k₃
        ⟨ sym               ⟩⇒ k₂ ∙ k₃ ≡ ε
        ⟨ zeroSumFree k₂ k₃ ⟩⇒ k₂      ≡ ε
        ⟨ sym               ⟩⇒ ε       ≡ k₂ ⇒∎
      where
      lemma₃ =
        y ∙ k₁       ≡˘⟨ x≡y∙k₁ ⟩
        x            ≡⟨ x≡y∙z∙k₂ ⟩
        (y ∙ z) ∙ k₂ ≡⟨ assoc y z k₂ ⟩
        y ∙ (z ∙ k₂) ∎

      lemma₂ =
        k₁ ∙ ε         ≡⟨ ∙ε k₁ ⟩
        k₁             ≡⟨ alg-≤-trans z≡k₁∙k₃ (cancel y k₁ (z ∙ k₂) lemma₃) ⟩
        k₁ ∙ (k₃ ∙ k₂) ∎

      lemma₁ =
        ε       ≡⟨ cancel k₁ ε (k₃ ∙ k₂) lemma₂ ⟩
        k₃ ∙ k₂ ≡⟨ comm k₃ k₂ ⟩
        k₂ ∙ k₃ ∎

    ∸‿assoc x y z | inr (k₁ , x≡y∙k₁) | inr (k₂ , x≡y∙z∙k₂) | inr (k₃ , k₁≡z∙k₃) =
        cancel z k₃ k₂ lemma₂
      where
      lemma₁ =
        y ∙ k₁       ≡˘⟨ x≡y∙k₁ ⟩
        x            ≡⟨ x≡y∙z∙k₂ ⟩
        (y ∙ z) ∙ k₂ ≡⟨ assoc y z k₂ ⟩
        y ∙ (z ∙ k₂) ∎

      lemma₂ =
        z ∙ k₃ ≡˘⟨ k₁≡z∙k₃ ⟩
        k₁     ≡⟨ cancel y k₁ (z ∙ k₂) lemma₁ ⟩
        z ∙ k₂ ∎

  open cmm public

  ∸‿cancel : ∀ x y → (x ∙ y) ∸ x ≡ y
  ∸‿cancel x y with (x ∙ y) ≤|≥ x
  ... | inl x∙y≤x = sym (cancel x y ε (antisym x∙y≤x x≤x∙y ; sym (∙ε x)))
  ... | inr (k , x∙y≡x∙k) = sym (cancel x y k x∙y≡x∙k)

  ccmm : CCMM _
  ccmm = record { ∸‿cancel = ∸‿cancel
                ; cmm = record { cmm
                               ; ∸‿comm = ∸‿comm
                               ; commutativeMonoid = commutativeMonoid } }

  open CCMM ccmm public
    using (cancelʳ; cancelˡ; ∸ε; ≺⇒<; ≤⇒<⇒≢ε; _⊔₂_; _⊓₂_; ≺-irrefl; ≤∸)

  ∸‿< : ∀ x y → x ≢ ε → y ≢ ε → x ∸ y < x
  ∸‿< x y x≢ε y≢ε = ≺⇒< (x ∸ y) x (∸‿≺ x y x≢ε y≢ε)

  ∸‿<-< : ∀ x y → x < y → x ≢ ε → y ∸ x < y
  ∸‿<-< x y x<y x≢ε = ∸‿< y x (λ y≡ε → x<y (x , sym (cong (_∙ x) y≡ε ; ε∙ x))) x≢ε

  2× : 𝑆 → 𝑆
  2× x = x ∙ x

  open import Relation.Binary.Lattice totalOrder

  double-max : ∀ x y → 2× (x ⊔ y) ≡ x ⊔₂ y
  double-max x y with x ≤|≥ y | y ≤|≥ x
  double-max x y | inl x≤y | inl y≤x =
    x ∙ x ≡⟨ cong (x ∙_) (antisym x≤y y≤x) ⟩
    x ∙ y ≡˘⟨ ∙ε (x ∙ y) ⟩
    (x ∙ y) ∙ ε ≡˘⟨ cong ((x ∙ y) ∙_)  (ε∙ ε) ⟩
    (x ∙ y) ∙ (ε ∙ ε) ∎
  double-max x y | inl x≤y | inr (k , y≡x∙k) =
    y ∙ y ≡⟨ cong (y ∙_) y≡x∙k ⟩
    y ∙ (x ∙ k) ≡˘⟨ assoc y x k ⟩
    (y ∙ x) ∙ k ≡⟨ cong (_∙ k) (comm y x) ⟩
    (x ∙ y) ∙ k ≡˘⟨ cong ((x ∙ y) ∙_) (ε∙ k) ⟩
    (x ∙ y) ∙ (ε ∙ k) ∎
  double-max x y | inr (k , x≡y∙k) | inl y≤x =
    x ∙ x ≡⟨ cong (x ∙_) x≡y∙k ⟩
    x ∙ (y ∙ k) ≡˘⟨ assoc x y k ⟩
    (x ∙ y) ∙ k ≡˘⟨ cong ((x ∙ y) ∙_) (∙ε k) ⟩
    (x ∙ y) ∙ (k ∙ ε) ∎
  double-max x y | inr (k₁ , x≡y∙k₁) | inr (k₂ , y≡x∙k₂) =
    x ∙ x ≡⟨ cong (x ∙_) (antisym (k₂ , y≡x∙k₂) (k₁ , x≡y∙k₁)) ⟩
    x ∙ y ≡⟨ cong₂ _∙_ x≡y∙k₁ y≡x∙k₂ ⟩
    (y ∙ k₁) ∙ (x ∙ k₂) ≡˘⟨ assoc (y ∙ k₁) x k₂ ⟩
    ((y ∙ k₁) ∙ x) ∙ k₂ ≡⟨ cong (_∙ k₂) (comm (y ∙ k₁) x) ⟩
    (x ∙ (y ∙ k₁)) ∙ k₂ ≡˘⟨ cong (_∙ k₂) (assoc x y k₁) ⟩
    ((x ∙ y) ∙ k₁) ∙ k₂ ≡⟨ assoc (x ∙ y) k₁ k₂ ⟩
    (x ∙ y) ∙ (k₁ ∙ k₂) ∎

  open import Data.Sigma.Properties

  ≤-prop : ∀ x y → isProp (x ≤ y)
  ≤-prop x y (k₁ , y≡x∙k₁) (k₂ , y≡x∙k₂) = Σ≡Prop (λ _ → total⇒isSet _ _) (cancelˡ x k₁ k₂ (sym y≡x∙k₁ ; y≡x∙k₂))

  open import Cubical.Foundations.HLevels using (isProp×)
  open import Data.Empty.Properties using (isProp¬)

  ≺-prop : ∀ x y → isProp (x ≺ y)
  ≺-prop x y (k₁ , y≡x∙k₁ , k₁≢ε) (k₂ , y≡x∙k₂ , k₂≢ε) = Σ≡Prop (λ k → isProp× (total⇒isSet _ _) (isProp¬ _)) (cancelˡ x k₁ k₂ (sym y≡x∙k₁ ; y≡x∙k₂))

-- We can construct the viterbi semiring by adjoining a top element to
-- a tapom
module Viterbi {ℓ₁} {ℓ₂} (tapom : TAPOM ℓ₁ ℓ₂) where
  open TAPOM tapom
  open import Relation.Binary.Construct.UpperBound totalOrder
  open import Relation.Binary.Lattice totalOrder

  ⟨⊓⟩∙ : _∙_ Distributesˡ _⊓_
  ⟨⊓⟩∙ x y z with x <? y | (x ∙ z) <? (y ∙ z)
  ... | yes x<y | yes xz<yz = refl
  ... | no  x≮y | no  xz≮yz = refl
  ... | no  x≮y | yes xz<yz = ⊥-elim (<⇒≱ xz<yz (≤-congʳ z (≮⇒≥ x≮y)))
  ... | yes x<y | no  xz≮yz = antisym (≤-congʳ z (<⇒≤ x<y)) (≮⇒≥ xz≮yz)

  ∙⟨⊓⟩ : _∙_ Distributesʳ _⊓_
  ∙⟨⊓⟩ x y z = comm x (y ⊓ z) ; ⟨⊓⟩∙ y z x ; cong₂ _⊓_ (comm y x) (comm z x)

  open UBSugar

  module NS where
    𝑅 = ⌈∙⌉

    0# 1# : 𝑅
    _*_ _+_ : 𝑅 → 𝑅 → 𝑅

    1# = ⌈ ε ⌉

    ⌈⊤⌉   * y     = ⌈⊤⌉
    ⌈ x ⌉ * ⌈⊤⌉   = ⌈⊤⌉
    ⌈ x ⌉ * ⌈ y ⌉ = ⌈ x ∙ y ⌉

    0# = ⌈⊤⌉

    ⌈⊤⌉   + y     = y
    ⌈ x ⌉ + ⌈⊤⌉   = ⌈ x ⌉
    ⌈ x ⌉ + ⌈ y ⌉ = ⌈ x ⊓ y ⌉

    *-assoc : Associative _*_
    *-assoc ⌈⊤⌉   _     _     = refl
    *-assoc ⌈ _ ⌉ ⌈⊤⌉   _     = refl
    *-assoc ⌈ _ ⌉ ⌈ _ ⌉ ⌈⊤⌉   = refl
    *-assoc ⌈ x ⌉ ⌈ y ⌉ ⌈ z ⌉ = cong ⌈_⌉ (assoc x y z)

    *-com : Commutative _*_
    *-com ⌈⊤⌉   ⌈⊤⌉   = refl
    *-com ⌈⊤⌉   ⌈ _ ⌉ = refl
    *-com ⌈ _ ⌉ ⌈⊤⌉   = refl
    *-com ⌈ x ⌉ ⌈ y ⌉ = cong ⌈_⌉ (comm x y)

    ⟨+⟩* : _*_ Distributesˡ _+_
    ⟨+⟩* ⌈⊤⌉   _     _     = refl
    ⟨+⟩* ⌈ _ ⌉ ⌈⊤⌉   ⌈⊤⌉   = refl
    ⟨+⟩* ⌈ _ ⌉ ⌈⊤⌉   ⌈ _ ⌉ = refl
    ⟨+⟩* ⌈ x ⌉ ⌈ y ⌉ ⌈⊤⌉   = refl
    ⟨+⟩* ⌈ x ⌉ ⌈ y ⌉ ⌈ z ⌉ = cong ⌈_⌉ (⟨⊓⟩∙ x y z)

    +-assoc : Associative _+_
    +-assoc ⌈⊤⌉   _     _     = refl
    +-assoc ⌈ x ⌉ ⌈⊤⌉   _     = refl
    +-assoc ⌈ x ⌉ ⌈ _ ⌉ ⌈⊤⌉   = refl
    +-assoc ⌈ x ⌉ ⌈ y ⌉ ⌈ z ⌉ = cong ⌈_⌉ (⊓-assoc x y z)

    0+ : ∀ x → 0# + x ≡ x
    0+ ⌈⊤⌉   = refl
    0+ ⌈ _ ⌉ = refl

    +0 : ∀ x → x + 0# ≡ x
    +0 ⌈ _ ⌉ = refl
    +0 ⌈⊤⌉   = refl

    1* : ∀ x → 1# * x ≡ x
    1* ⌈⊤⌉   = refl
    1* ⌈ x ⌉ = cong ⌈_⌉ (ε∙ x)

    *1 : ∀ x → x * 1# ≡ x
    *1 ⌈⊤⌉   = refl
    *1 ⌈ x ⌉ = cong ⌈_⌉ (∙ε x)

    0* : ∀ x → 0# * x ≡ 0#
    0* _ = refl

  open NS

  nearSemiring : NearSemiring _
  nearSemiring = record { NS }

  +-comm : Commutative _+_
  +-comm ⌈⊤⌉   ⌈⊤⌉   = refl
  +-comm ⌈⊤⌉   ⌈ _ ⌉ = refl
  +-comm ⌈ _ ⌉ ⌈⊤⌉   = refl
  +-comm ⌈ x ⌉ ⌈ y ⌉ = cong ⌈_⌉ (⊓-comm x y)

  *0 : ∀ x → x * ⌈⊤⌉ ≡ ⌈⊤⌉
  *0 ⌈ _ ⌉ = refl
  *0 ⌈⊤⌉   = refl

  *⟨+⟩ : _*_ Distributesʳ _+_
  *⟨+⟩ x y z = *-com x (y + z) ; ⟨+⟩* y z x ; cong₂ _+_ (*-com y x) (*-com z x)

viterbi : ∀ {ℓ₁ ℓ₂} → TAPOM ℓ₁ ℓ₂ → Semiring ℓ₁
viterbi tapom = record { Viterbi tapom }


{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.IDarkwingDuck.Primitive
module Spire.IDarkwingDuck.Derived where

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

ISet : Set → Set
ISet I = I → Set

Enum : Set
Enum = List String

Tag : Enum → Set
Tag xs = PointsTo String xs

proj₁ : ∀{A B} → Σ A B → A
proj₁ = elimPair _ (λ a b → a)

proj₂ : ∀{A B} (ab : Σ A B) → B (proj₁ ab)
proj₂ = elimPair _ (λ a b → b)

Branches : (E : List String) (P : Tag E → Set) → Set
Branches = elimList _
  (λ P → ⊤)
  (λ l E ih P → Σ (P here) (λ _ → ih (λ t → P (there t))))

case' : (E : List String) (t : Tag E) (P : Tag E → Set) (cs : Branches E P) → P t
case' = elimPointsTo _
  (λ l E P c,cs → proj₁ c,cs)
  (λ l E t ih P c,cs → ih (λ t → P (there t)) (proj₂ c,cs))

case : {E : List String} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P cs t = case' _ t P cs

Elᵀ  : Tel → Set
Elᵀ = elimTel _ ⊤ (λ A B ih → Σ A ih) (λ A B ih → Σ A ih)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches = elimList _
  (λ P X → X)
  (λ l E ih P X → P here → ih (λ t → P (there t)) X)

curryBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches = elimList _
  (λ P X f → f tt)
  (λ l E ih P X f c → ih (λ t → P (there t)) X (λ cs → f (c , cs)))

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ = elimTel _
  (λ X → X tt)
  (λ A B ih X → (a : A) → ih a (λ b → X (a , b)))
  (λ A B ih X → {a : A} → ih a (λ b → X (a , b)))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ = elimTel _
  (λ X f → f tt)
  (λ A B ih X f a → ih a (λ b → X (a , b)) (λ b → f (a , b)))
  (λ A B ih X f {a} → ih a (λ b → X (a , b)) (λ b → f (a , b)))

uncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → CurriedElᵀ T X → UncurriedElᵀ T X
uncurryElᵀ = elimTel _
  (λ X x → elimUnit X x)
  (λ A B ih X f → elimPair X (λ a b → ih a (λ b → X (a , b)) (f a) b))
  (λ A B ih X f → elimPair X (λ a b → ih a (λ b → X (a , b)) f b))

ICurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
ICurriedElᵀ = elimTel _
  (λ X → X tt)
  (λ A B ih X → {a : A} → ih a (λ b → X (a , b)))
  (λ A B ih X → {a : A} → ih a (λ b → X (a , b)))

icurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → ICurriedElᵀ T X
icurryElᵀ = elimTel _
  (λ X f → f tt)
  (λ A B ih X f {a} → ih a (λ b → X (a , b)) (λ b → f (a , b)))
  (λ A B ih X f {a} → ih a (λ b → X (a , b)) (λ b → f (a , b)))

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

UncurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedElᴰ D X = ∀{i} → Elᴰ D X i → X i

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ = elimDesc _
  (λ i X → X i)
  (λ i D ih X → (x : X i) → ih X )
  (λ A B ih X → (a : A) → ih a X)
  (λ A B ih X → {a : A} → ih a X)

curryElᴰ : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedElᴰ D X → CurriedElᴰ D X
curryElᴰ = elimDesc _
  (λ i X cn → cn refl)
  (λ i D ih X cn x → ih X (λ xs → cn (x , xs)))
  (λ A B ih X cn a → ih a X (λ xs → cn (a , xs)))
  (λ A B ih X cn {a} → ih a X (λ xs → cn (a , xs)))

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : Elᴰ D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
CurriedHyps = elimDesc _
  (λ i X P cn → P i (cn refl))
  (λ i D ih X P cn → (x : X i) → P i x → ih X P (λ xs → cn (x , xs)))
  (λ A B ih X P cn → (a : A) → ih a X P (λ xs → cn (a , xs)))
  (λ A B ih X P cn → {a : A} → ih a X P (λ xs → cn (a , xs)))

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps = elimDesc _
  (λ j X P cn pf →
    elimEq _ (λ u → pf))
  (λ j D ih X P cn pf i →
    elimPair _ (λ x xs ih,ihs →
      ih X P (λ ys → cn (x , ys)) (pf x (proj₁ ih,ihs)) i xs (proj₂ ih,ihs)))
  (λ A B ih X P cn pf i →
    elimPair _ (λ a xs → ih a X P (λ ys → cn (a , ys)) (pf a) i xs))
  (λ A B ih X P cn pf i →
    elimPair _ (λ a xs → ih a X P (λ ys → cn (a , ys)) pf i xs))

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  C : (A : Elᵀ P) → Tag E → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg (Tag E) (C A)

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

Decl :
  (P : Tel)
  (I : CurriedElᵀ P (λ _ → Tel))
  (E : Enum)
  (B : let I = uncurryElᵀ P (λ _ → Tel) I
      in CurriedElᵀ P λ A → Branches E (λ _ → Desc (Elᵀ (I A))))
  → Data
Decl P I E B = record
  { P = P
  ; I = uncurryElᵀ P _ I
  ; E = E
  ; B = uncurryElᵀ P _ B
  }

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

End[_] : (I : Tel)
  → CurriedElᵀ I (λ _ → Desc (Elᵀ I))
End[_] I = curryElᵀ I _ End

Rec[_] : (I : Tel)
  → CurriedElᵀ I (λ _ → Desc (Elᵀ I) → Desc (Elᵀ I))
Rec[_] I = curryElᵀ I _ Rec

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

FormUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → UncurriedElᵀ (Data.I R p) λ i
  → Set
FormUncurried R p i = μ (Data.D R p) i

Form : (R : Data)
  → CurriedElᵀ (Data.P R) λ p
  → CurriedElᵀ (Data.I R p) λ i
  → Set
Form R =
  curryElᵀ (Data.P R) (λ p → CurriedElᵀ (Data.I R p) λ i → Set) λ p →
  curryElᵀ (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
injUncurried R p t = curryElᴰ (Data.C R p t)
  (μ (Data.D R p))
  (λ xs → init (t , xs))

inj : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
inj R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in CurriedElᴰ D (μ D))
  (injUncurried R)

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

indCurried : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) M init)
  (i : I)
  (x : μ D i)
  → M i x
indCurried D M f i x =
  ind D M (uncurryHyps D (μ D) M init f) i x

SumCurriedHyps : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  let unM = uncurryElᵀ (Data.I R p) (λ i → μ (Data.D R p) i → Set) M in
  CurriedHyps (Data.C R p t) (μ (Data.D R p)) unM (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in UncurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x))
elimUncurried R p M cs =
  let D = Data.D R p
      unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in
  curryElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x) λ i x →
  indCurried (Data.D R p) unM
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x))
elim R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in
    (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
    → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p M)
       (CurriedElᵀ (Data.I R p) (λ i → (x : μ D i) → unM i x)))
  (λ p M → curryBranches (Data.E R) _ _
    (elimUncurried R p M))

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


module _ where

module M where

  data D : Set where
    c : D

  pattern c′ = c

open M hiding (c′)

x : D
x = c′


module Issue4267.A1 where

record RA1 : Set₁ where
  field
    A : Set