------------------------------------------------------------------------
-- Some results related to expansion for the delay monad
------------------------------------------------------------------------

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

open import Prelude

module Expansion.Delay-monad {a} {A : Type a} where

open import Delay-monad
open import Delay-monad.Bisimilarity as D using (force)
import Delay-monad.Bisimilarity.Negative as DN
open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Function-universe equality-with-J hiding (id; _∘_)
open import Function-universe.Size equality-with-J

import Bisimilarity.Delay-monad as SD
open import Equational-reasoning
import Expansion.Equational-reasoning-instances
open import Labelled-transition-system.Delay-monad A

open import Bisimilarity delay-monad using ([_]_∼_)
open import Expansion delay-monad

------------------------------------------------------------------------
-- The direct and the indirect definitions of expansion are pointwise
-- logically equivalent

-- Emulations of the constructors D.later and D.laterˡ.

later-cong : ∀ {i x y} →
             [ i ] force x ≳′ force y → [ i ] later x ≳ later y
later-cong x≳′y =
  ⟨ (λ { later → _ , ⟶→⟶̂   later , x≳′y })
  , (λ { later → _ , ⟶→[]⇒ later , x≳′y })
  ⟩

laterˡ : ∀ {i x y} → [ i ] force x ≳ y → [ i ] later x ≳ y
laterˡ x≳y =
  ⟨ (λ { later → _ , done _ , convert {a = a} x≳y })
  , Σ-map id (Σ-map later[]⇒ id) ∘ right-to-left x≳y
  ⟩

-- The direct definition of expansion is contained in the one
-- obtained from the transition relation.

direct→indirect : ∀ {i x y} →
                  D.[ i ] x ≳ y → [ i ] x ≳ y
direct→indirect D.now        = reflexive
direct→indirect (D.later  p) = later-cong λ { .force →
                                 direct→indirect (force p) }
direct→indirect (D.laterˡ p) = laterˡ (direct→indirect p)

-- If x makes a sequence of zero or more silent transitions to y, then
-- x is an expansion of y.

⇒→≳ : ∀ {i x y} → x ⇒ y → D.[ i ] x ≳ y
⇒→≳ done               = D.reflexive _
⇒→≳ (step _  later tr) = D.laterˡ (⇒→≳ tr)
⇒→≳ (step () now   tr)

-- If x makes a non-silent transition with the label y, then x is an
-- expansion of now y.

[just]⟶→≳now : ∀ {i x x′ y} → x [ just y ]⟶ x′ → D.[ i ] x ≳ now y
[just]⟶→≳now now = D.reflexive _

[just]⇒→≳now : ∀ {i x x′ y} → x [ just y ]⇒ x′ → D.[ i ] x ≳ now y
[just]⇒→≳now (steps tr now _) = ⇒→≳ tr

[just]⇒̂→≳now : ∀ {i x x′ y} → x [ just y ]⇒̂ x′ → D.[ i ] x ≳ now y
[just]⇒̂→≳now (silent () _)
[just]⇒̂→≳now (non-silent _ tr) = [just]⇒→≳now tr

[just]⟶̂→≳now : ∀ {i x x′ y} → x [ just y ]⟶̂ x′ → D.[ i ] x ≳ now y
[just]⟶̂→≳now (done ())
[just]⟶̂→≳now (step tr) = [just]⇒̂→≳now (⟶→⇒̂ tr)

-- The definition of expansion obtained from the transition relation
-- is contained in the direct one.

indirect→direct : ∀ {i} x y → [ i ] x ≳ y → D.[ i ] x ≳ y
indirect→direct {i} (now x) y =
  ([ i ] now x ≳ y)                                ↝⟨ (λ p → left-to-right p now) ⟩
  (∃ λ y′ → y [ just x ]⟶̂ y′ × [ i ] now x ≳′ y′)  ↝⟨ sym ∘ [just]⟶̂→≡now ∘ proj₁ ∘ proj₂ ⟩
  now x ≡ y                                        ↝⟨ (λ { refl → D.reflexive _ }) ⟩□
  D.[ i ] now x ≳ y                                □

indirect→direct {i} x (now y) =
  [ i ] x ≳ now y                                  ↝⟨ (λ p → right-to-left p now) ⟩
  (∃ λ x′ → x [ just y ]⇒ x′ × [ i ] x′ ≳′ now y)  ↝⟨ [just]⇒→≳now ∘ proj₁ ∘ proj₂ ⟩□
  D.[ i ] x ≳ now y                                □

indirect→direct (later x) (later y) lx≳ly =
  case left-to-right lx≳ly later of λ where
    (_ , step later , x≳′y) → D.later λ { .force {j} →
                                indirect→direct _ _
                                  (force x≳′y {j = j}) }
    (_ , done _     , x≳′ly) →
      let x′ , lx⇒x′ , x′≳′y = right-to-left lx≳ly later
      in lemma x≳′ly ([]⇒→⇒ _ lx⇒x′) x′≳′y
  where
  indirect→direct′ : ∀ {i x x′ y} →
                     x ⇒ x′ → [ i ] x′ ≳ y → D.[ i ] x ≳ y
  indirect→direct′ done               p = indirect→direct _ _ p
  indirect→direct′ (step _  later tr) p = D.laterˡ
                                            (indirect→direct′ tr p)
  indirect→direct′ (step () now   _)

  lemma :
    ∀ {i x x′} →
    [ i ] force x ≳′ later y →
    later x ⇒ x′ → [ i ] x′ ≳′ force y →
    D.[ i ] later x ≳ later y
  lemma x≳′ly done lx≳′y =
    D.later λ { .force →
      D.laterˡʳ⁻¹
        (indirect→direct _ _ (force lx≳′y))
        (indirect→direct _ _ (force x≳′ly)) }
  lemma x≳′ly (step _ later x⇒x′) x′≳′y =
    D.later λ { .force →
      indirect→direct′ x⇒x′ (force x′≳′y) }

-- The direct definition of the expansion relation is logically
-- equivalent to the one obtained from the transition relation.
--
-- TODO: Are the two definitions isomorphic?

direct⇔indirect : ∀ {i x y} → D.[ i ] x ≳ y ⇔ [ i ] x ≳ y
direct⇔indirect = record
  { to   = direct→indirect
  ; from = indirect→direct _ _
  }

------------------------------------------------------------------------
-- Some non-existence results

Now≳later-now = ∀ x → now x ≳ later (record { force = now x })

now≳later-now⇔uninhabited : Now≳later-now ⇔ ¬ A
now≳later-now⇔uninhabited =
  Now≳later-now     ↝⟨ inverse $ ∀-cong _ (λ _ → direct⇔indirect) ⟩
  DN.Now≳later-now  ↝⟨ DN.now≳later-now⇔uninhabited ⟩□
  ¬ A               □

Laterˡ⁻¹ = ∀ {x y} → later x ≳ y → force x ≳ y

laterˡ⁻¹⇔uninhabited : Laterˡ⁻¹ ⇔ ¬ A
laterˡ⁻¹⇔uninhabited =
  Laterˡ⁻¹       ↝⟨ inverse $ implicit-∀-cong _ $ implicit-∀-cong _ $ →-cong _ direct⇔indirect direct⇔indirect ⟩
  DN.Laterˡ⁻¹-≳  ↝⟨ DN.laterˡ⁻¹-≳⇔uninhabited ⟩□
  ¬ A            □

Laterʳ⁻¹-∼≳ =
  ∀ {i x} →
  [ i ] never ∼ later (record { force = now x }) →
  [ i ] never ≳ now x

size-preserving-laterʳ⁻¹-∼≳⇔uninhabited : Laterʳ⁻¹-∼≳ ⇔ ¬ A
size-preserving-laterʳ⁻¹-∼≳⇔uninhabited =
  Laterʳ⁻¹-∼≳     ↝⟨ inverse $ implicit-∀-size-cong _ $ implicit-∀-cong _ $ →-cong _ SD.direct⇔indirect direct⇔indirect ⟩
  DN.Laterʳ⁻¹-∼≳  ↝⟨ DN.size-preserving-laterʳ⁻¹-∼≳⇔uninhabited ⟩□
  ¬ A             □

Laterʳ⁻¹ = ∀ {i x y} → [ i ] x ≳ later y → [ i ] x ≳ force y

size-preserving-laterʳ⁻¹⇔uninhabited : Laterʳ⁻¹ ⇔ ¬ A
size-preserving-laterʳ⁻¹⇔uninhabited =
  Laterʳ⁻¹       ↝⟨ inverse $ implicit-∀-size-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $ →-cong _ direct⇔indirect direct⇔indirect ⟩
  DN.Laterʳ⁻¹-≳  ↝⟨ DN.size-preserving-laterʳ⁻¹-≳⇔uninhabited ⟩□
  ¬ A            □

Transitivity-∼≳ˡ =
  ∀ {i} {x y z : Delay A ∞} →
  [ i ] x ∼ y → y ≳ z → [ i ] x ≳ z

size-preserving-transitivity-∼≳ˡ⇔uninhabited : Transitivity-∼≳ˡ ⇔ ¬ A
size-preserving-transitivity-∼≳ˡ⇔uninhabited =
  Transitivity-∼≳ˡ     ↝⟨ inverse $ implicit-∀-size-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $
                          →-cong _ SD.direct⇔indirect (→-cong _ direct⇔indirect direct⇔indirect) ⟩
  DN.Transitivity-∼≳ˡ  ↝⟨ DN.size-preserving-transitivity-∼≳ˡ⇔uninhabited ⟩□
  ¬ A                  □

Transitivityˡ =
  ∀ {i} {x y z : Delay A ∞} →
  [ i ] x ≳ y → y ≳ z → [ i ] x ≳ z

size-preserving-transitivityˡ⇔uninhabited : Transitivityˡ ⇔ ¬ A
size-preserving-transitivityˡ⇔uninhabited =
  Transitivityˡ       ↝⟨ inverse $ implicit-∀-size-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $
                         →-cong _ direct⇔indirect (→-cong _ direct⇔indirect direct⇔indirect) ⟩
  DN.Transitivity-≳ˡ  ↝⟨ DN.size-preserving-transitivity-≳ˡ⇔uninhabited ⟩□
  ¬ A                 □

Transitivity =
  ∀ {i} {x y z : Delay A ∞} →
  [ i ] x ≳ y → [ i ] y ≳ z → [ i ] x ≳ z

size-preserving-transitivity⇔uninhabited : Transitivity ⇔ ¬ A
size-preserving-transitivity⇔uninhabited =
  Transitivity       ↝⟨ inverse $ implicit-∀-size-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $ implicit-∀-cong _ $
                        →-cong _ direct⇔indirect $ →-cong _ direct⇔indirect direct⇔indirect ⟩
  DN.Transitivity-≳  ↝⟨ DN.size-preserving-transitivity-≳⇔uninhabited ⟩□
  ¬ A                □


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Overloading ⟦_⟧ notation
--
-- This module defines a general mechanism for overloading the
-- ⟦_⟧ notation, using Agda’s instance arguments.
------------------------------------------------------------------------

module Base.Denotation.Notation where

open import Level

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

open Meaning public
  using (⟨_⟩⟦_⟧)


{-# OPTIONS --without-K #-}
module overloading.bundle where

open import level

record Bundle {i j} {Base : Set i}
                    (Struct : Base → Set j) : Set (lsuc (i ⊔ j)) where
  constructor bundle
  field
    parent : Base
    struct : Struct parent


{-# OPTIONS --without-K --rewriting --termination-depth=2 #-}

open import HoTT
open import cohomology.ChainComplex
open import cohomology.Theory
open import groups.KernelImage
open import cw.CW

module cw.cohomology.ReconstructedHigherCohomologyGroups {i : ULevel} (OT : OrdinaryTheory i) where

  open OrdinaryTheory OT
  import cw.cohomology.HigherCoboundary OT as HC
  open import cw.cohomology.WedgeOfCells OT
  open import cw.cohomology.Descending OT
  open import cw.cohomology.ReconstructedCochainComplex OT
  import cw.cohomology.HigherCohomologyGroups OT as HCG
  import cw.cohomology.HigherCohomologyGroupsOnDiag OT as HCGD
  import cw.cohomology.CohomologyGroupsTooHigh OT as CGTH

  private
    ≤-dec-has-all-paths : {m n : ℕ} → has-all-paths (Dec (m ≤ n))
    ≤-dec-has-all-paths = prop-has-all-paths (Dec-level ≤-is-prop)

  private
    abstract
      higher-cohomology-group-descend : ∀ {n} (⊙skel : ⊙Skeleton {i} (2 + n)) {m} (Sm<n : S m < n)
        →  cohomology-group (cochain-complex ⊙skel) (ℕ-to-ℤ (2 + m))
        == cohomology-group (cochain-complex (⊙cw-init ⊙skel)) (ℕ-to-ℤ (2 + m))
      higher-cohomology-group-descend ⊙skel {m} ltS -- n = 2 + m
        = ap3
            (λ Sm≤4+m? SSm≤4+m? SSSm≤4+m? → Ker/Im
              (coboundary-template ⊙skel SSm≤4+m? SSSm≤4+m?)
              (coboundary-template ⊙skel Sm≤4+m? SSm≤4+m?)
              (cochain-is-abelian-template ⊙skel SSm≤4+m?))
            (≤-dec-has-all-paths (≤-dec (1 + m) (4 + m)) (inl (lteSR $ lteSR lteS)))
            (≤-dec-has-all-paths (≤-dec (2 + m) (4 + m)) (inl (lteSR lteS)))
            (≤-dec-has-all-paths (≤-dec (3 + m) (4 + m)) (inl lteS))
        ∙ ap2 (λ δ₁ δ₂ → Ker/Im δ₂ δ₁ (CXₙ/Xₙ₋₁-is-abelian (⊙cw-take (lteSR lteS) ⊙skel) (ℕ-to-ℤ (2 + m))))
            (coboundary-higher-template-descend-from-far {n = 3 + m} ⊙skel {m = m} (ltSR ltS) ltS)
            (coboundary-higher-template-descend-from-one-above ⊙skel)
        ∙ ap3
            (λ Sm≤3+m? SSm≤3+m? SSSm≤3+m? → Ker/Im
              (coboundary-template (⊙cw-init ⊙skel) SSm≤3+m? SSSm≤3+m?)
              (coboundary-template (⊙cw-init ⊙skel) Sm≤3+m? SSm≤3+m?)
              (cochain-is-abelian-template (⊙cw-init ⊙skel) SSm≤3+m?))
            (≤-dec-has-all-paths (inl (lteSR lteS)) (≤-dec (1 + m) (3 + m)))
            (≤-dec-has-all-paths (inl lteS)         (≤-dec (2 + m) (3 + m)))
            (≤-dec-has-all-paths (inl lteE)         (≤-dec (3 + m) (3 + m)))
      higher-cohomology-group-descend {n = S n} ⊙skel {m} (ltSR Sm<n) -- n = S n
        = ap3
            (λ Sm≤3+n? SSm≤3+n? SSSm≤3+n? → Ker/Im
              (coboundary-template ⊙skel SSm≤3+n? SSSm≤3+n?)
              (coboundary-template ⊙skel Sm≤3+n? SSm≤3+n?)
              (cochain-is-abelian-template ⊙skel SSm≤3+n?))
            (≤-dec-has-all-paths (≤-dec (1 + m) (3 + n)) (inl (lteSR $ lteSR $ lteSR (inr Sm<n))))
            (≤-dec-has-all-paths (≤-dec (2 + m) (3 + n)) (inl (≤-+-l 1 (lteSR $ lteSR $ inr Sm<n))))
            (≤-dec-has-all-paths (≤-dec (3 + m) (3 + n)) (inl (≤-+-l 2 (lteSR (inr Sm<n)))))
        ∙ ap2
            (λ δ₁ δ₂ → Ker/Im δ₂ δ₁
              (CXₙ/Xₙ₋₁-is-abelian (⊙cw-take (≤-+-l 1 (lteSR $ lteSR $ inr Sm<n)) ⊙skel) (ℕ-to-ℤ (2 + m))))
            (coboundary-higher-template-descend-from-far {n = 2 + n} ⊙skel {m = m}   (ltSR (ltSR Sm<n))    (<-+-l 1 (ltSR Sm<n)))
            (coboundary-higher-template-descend-from-far {n = 2 + n} ⊙skel {m = S m} (<-+-l 1 (ltSR Sm<n)) (<-+-l 2 Sm<n))
        ∙ ap3
            (λ Sm≤2+n? SSm≤2+n? SSSm≤2+n? → Ker/Im
              (coboundary-template (⊙cw-init ⊙skel) SSm≤2+n? SSSm≤2+n?)
              (coboundary-template (⊙cw-init ⊙skel) Sm≤2+n? SSm≤2+n?)
              (cochain-is-abelian-template (⊙cw-init ⊙skel) SSm≤2+n?))
            (≤-dec-has-all-paths (inl (lteSR $ lteSR $ inr Sm<n))   (≤-dec (1 + m) (2 + n)))
            (≤-dec-has-all-paths (inl (≤-+-l 1 (lteSR $ inr Sm<n))) (≤-dec (2 + m) (2 + n)))
            (≤-dec-has-all-paths (inl (≤-+-l 2 (inr Sm<n)))         (≤-dec (3 + m) (2 + n)))

      higher-cohomology-group-β : ∀ {n} (⊙skel : ⊙Skeleton {i} (3 + n))
        →  cohomology-group (cochain-complex ⊙skel) (ℕ-to-ℤ (2 + n))
        == Ker/Im
            (HC.cw-co∂-last ⊙skel)
            (HC.cw-co∂-last (⊙cw-init ⊙skel))
            (CXₙ/Xₙ₋₁-is-abelian (⊙cw-init ⊙skel) (ℕ-to-ℤ (2 + n)))
      higher-cohomology-group-β {n} ⊙skel
        = ap3
            (λ 1+n≤3+n? 2+n≤3+n? 3+n≤3+n? → Ker/Im
              (coboundary-template ⊙skel 2+n≤3+n? 3+n≤3+n?)
              (coboundary-template ⊙skel 1+n≤3+n? 2+n≤3+n?)
              (cochain-is-abelian-template ⊙skel 2+n≤3+n?))
            (≤-dec-has-all-paths (≤-dec (1 + n) (3 + n)) (inl (lteSR lteS)))
            (≤-dec-has-all-paths (≤-dec (2 + n) (3 + n)) (inl lteS))
            (≤-dec-has-all-paths (≤-dec (3 + n) (3 + n)) (inl lteE))
        ∙ ap2 (λ δ₁ δ₂ → Ker/Im δ₂ δ₁ (CXₙ/Xₙ₋₁-is-abelian (⊙cw-init ⊙skel) (ℕ-to-ℤ (2 + n))))
            ( coboundary-higher-template-descend-from-one-above ⊙skel
            ∙ coboundary-higher-template-β (⊙cw-init ⊙skel))
            (coboundary-higher-template-β ⊙skel)

      higher-cohomology-group-β-one-below : ∀ {n} (⊙skel : ⊙Skeleton {i} (2 + n))
        →  cohomology-group (cochain-complex ⊙skel) (ℕ-to-ℤ (2 + n))
        == Ker/Im
            (cst-hom {H = Lift-group {j = i} Unit-group})
            (HC.cw-co∂-last ⊙skel)
            (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (2 + n)))
      higher-cohomology-group-β-one-below {n} ⊙skel
        = ap3
            (λ 1+n≤2+n? 2+n≤2+n? 3+n≤2+n? → Ker/Im
              (coboundary-template ⊙skel 2+n≤2+n? 3+n≤2+n?)
              (coboundary-template ⊙skel 1+n≤2+n? 2+n≤2+n?)
              (cochain-is-abelian-template ⊙skel 2+n≤2+n?))
            (≤-dec-has-all-paths (≤-dec (1 + n) (2 + n)) (inl lteS))
            (≤-dec-has-all-paths (≤-dec (2 + n) (2 + n)) (inl lteE))
            (≤-dec-has-all-paths (≤-dec (3 + n) (2 + n)) (inr (<-to-≱ ltS)))
        ∙ ap
            (λ δ₁ → Ker/Im
              (cst-hom {H = Lift-group {j = i} Unit-group})
              δ₁ (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (2 + n))))
            (coboundary-higher-template-β ⊙skel)

      higher-cohomology-group-β-far-below : ∀ {n} (⊙skel : ⊙Skeleton {i} n) {m} (SSm≰n : ¬ (2 + m ≤ n))
        →  cohomology-group (cochain-complex ⊙skel) (ℕ-to-ℤ (2 + m))
        == Ker/Im
            (cst-hom {H = Lift-group {j = i} Unit-group})
            (cst-hom
              {G = AbGroup.grp (cochain-template ⊙skel (≤-dec (1 + m) n))}
              {H = Lift-group {j = i} Unit-group})
            (snd (Lift-abgroup {j = i} Unit-abgroup))
      higher-cohomology-group-β-far-below {n} ⊙skel {m} SSm≰n
        = ap2
            (λ 2+m≤n? 3+m≤n? → Ker/Im
              (coboundary-template ⊙skel 2+m≤n? 3+m≤n?)
              (coboundary-template ⊙skel (≤-dec (1 + m) n) 2+m≤n?)
              (cochain-is-abelian-template ⊙skel 2+m≤n?))
            (≤-dec-has-all-paths (≤-dec (2 + m) n) (inr SSm≰n))
            (≤-dec-has-all-paths (≤-dec (3 + m) n) (inr (λ SSSm≤n → SSm≰n (≤-trans lteS SSSm≤n))))

  abstract
    higher-cohomology-group : ∀ m {n} (⊙skel : ⊙Skeleton {i} n)
      → ⊙has-cells-with-choice 0 ⊙skel i
      → C (ℕ-to-ℤ (2 + m)) ⊙⟦ ⊙skel ⟧ ≃ᴳ cohomology-group (cochain-complex ⊙skel) (ℕ-to-ℤ (2 + m))
    higher-cohomology-group m {n = 0} ⊙skel ac =
      CGTH.C-cw-iso-ker/im (2 + m) (O<S (S m)) (Lift-group {j = i} Unit-group) ⊙skel ac
    higher-cohomology-group m {n = 1} ⊙skel ac =
      CGTH.C-cw-iso-ker/im (2 + m) (<-+-l 1 (O<S m))
        (AbGroup.grp (cochain-template ⊙skel (≤-dec (1 + m) 1)))
        ⊙skel ac
    higher-cohomology-group m {n = S (S n)} ⊙skel ac with ℕ-trichotomy (S m) (S n)
    ... | inl idp = coe!ᴳ-iso (higher-cohomology-group-β-one-below ⊙skel)
                ∘eᴳ HCGD.C-cw-iso-ker/im ⊙skel ac
    ... | inr (inl ltS) = coe!ᴳ-iso (higher-cohomology-group-β ⊙skel)
                      ∘eᴳ HCG.C-cw-iso-ker/im ⊙skel ac
    ... | inr (inl (ltSR Sm<n)) =
                coe!ᴳ-iso (higher-cohomology-group-descend ⊙skel Sm<n)
            ∘eᴳ higher-cohomology-group m {n = S n} (⊙cw-init ⊙skel) (⊙init-has-cells-with-choice ⊙skel ac)
            ∘eᴳ C-cw-descend-at-lower ⊙skel (<-+-l 1 Sm<n) ac
    ... | inr (inr Sn<Sm) =
                coe!ᴳ-iso (higher-cohomology-group-β-far-below ⊙skel (<-to-≱ (<-+-l 1 Sn<Sm)))
            ∘eᴳ CGTH.C-cw-iso-ker/im (2 + m) (<-+-l 1 Sn<Sm)
                  (AbGroup.grp (cochain-template ⊙skel (≤-dec (1 + m) (2 + n))))
                  ⊙skel ac


{-# OPTIONS --without-K --safe --erased-cubical --no-import-sorts #-}

module Prelude where

open import Agda.Primitive renaming (Set to Type) public
open import Agda.Builtin.Reflection hiding (Type) renaming (primQNameEquality to _==_) public
open import Reflection using (_>>=_) public

open import Agda.Builtin.String public
open import Agda.Builtin.Sigma public

open import Data.Bool using (Bool; not; true; false; if_then_else_) public
open import Data.List using (List; []; _∷_; map; concat; concatMap; _++_; foldr; zip; length; take) public
open import Data.Maybe using (Maybe; just; nothing) public
open import Data.Fin.Base using (Fin; toℕ) renaming (zero to fz) public
open import Data.Integer.Base using (ℤ; +_; -[1+_]) public
open import Data.Nat.Base using (ℕ; zero; suc; _^_) public
open import Data.Nat.DivMod using (_%_; _mod_) public
open import Data.Product using (_×_; _,_) public
open import Data.Unit using (⊤) public
open import Data.Vec using (Vec; []; _∷_; updateAt) public

open import Function using (id; _∘_; flip) public

open import Definition.Conversion.Soundness public

open import Interval public
open import Note public
open import Pitch using (Pitch; a; b; b♭; c; c♯; d; d♯; e; f; f♯; g; g♯) public
open import Transformation public

open import MidiEvent using (InstrumentNumber-1; maxChannels; MidiTrack) public

open import FarmCanon using () renaming (subject to canonsubject) public
open import FarmFugue using (b1; b2; b3; b4; b5; b6; b7; b8; b9; b10; b11; b12; b13; subject; countersubject; extra) public


{-

  Reflection-based tools for converting between iterated record types, particularly between
  record types and iterated Σ-types.

  See end of file for examples.

-}
{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Reflection.RecordEquiv where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Data.List as List
open import Cubical.Data.Nat
open import Cubical.Data.Maybe as Maybe
open import Cubical.Data.Sigma

open import Agda.Builtin.String
import Agda.Builtin.Reflection as R
open import Cubical.Reflection.Base

Projections = Maybe (List R.Name)

-- Describes a correspondence between two iterated record types
RecordAssoc = List (Projections × Projections)

-- Describes a correspondence between a record type and an iterated Σ-types;
-- more convenient than RecordAssoc for this special case
data ΣFormat : Type where
  leaf : R.Name → ΣFormat
  _,_ : ΣFormat → ΣFormat → ΣFormat
  unit : ΣFormat

infixr 4 _,_

flipRecordAssoc : RecordAssoc → RecordAssoc
flipRecordAssoc = List.map λ {p .fst → p .snd; p .snd → p .fst}

fstIdRecordAssoc : RecordAssoc → RecordAssoc
fstIdRecordAssoc = List.map λ {p .fst → p .fst; p .snd → p .fst}

List→ΣFormat : List R.Name → ΣFormat
List→ΣFormat [] = unit
List→ΣFormat (x ∷ []) = leaf x
List→ΣFormat (x ∷ y ∷ xs) = leaf x , List→ΣFormat (y ∷ xs)

ΣFormat→RecordAssoc : ΣFormat → RecordAssoc
ΣFormat→RecordAssoc = go []
  where
  go : List R.Name → ΣFormat → RecordAssoc
  go prefix unit = [ just prefix , nothing ]
  go prefix (leaf fieldName) = [ just prefix , just [ fieldName ] ]
  go prefix (sig₁ , sig₂) =
    go (quote fst ∷ prefix) sig₁ ++ go (quote snd ∷ prefix) sig₂

-- Derive the shape of the compound Σ-type
ΣFormat→Ty : ΣFormat → R.Type
ΣFormat→Ty unit = R.def (quote Unit) []
ΣFormat→Ty (leaf _) = R.unknown
ΣFormat→Ty (sig₁ , sig₂) =
  R.def (quote Σ) (ΣFormat→Ty sig₁ v∷ R.lam R.visible (R.abs "_" (ΣFormat→Ty sig₂)) v∷ [])

recordName→isoTy : R.Name → R.Term → R.TC R.Term
recordName→isoTy name σShape =
  R.inferType (R.def name []) >>= R.normalise >>= go []
  where
  go : List R.ArgInfo → R.Type → R.TC R.Term
  go acc (R.pi (R.arg i argTy) (R.abs s ty)) =
    liftTC (λ t → R.pi (R.arg i' argTy) (R.abs s t)) (go (i ∷ acc) ty)
    where
    i' = R.arg-info R.hidden (R.modality R.relevant R.quantity-ω)
  go acc (R.agda-sort _) =
    R.returnTC (R.def (quote Iso) (R.def name (makeArgs 0 [] acc) v∷ σShape v∷ []))
    where
    makeArgs : ℕ → List (R.Arg R.Term) → List R.ArgInfo → List (R.Arg R.Term)
    makeArgs n acc [] = acc
    makeArgs n acc (i ∷ infos) = makeArgs (suc n) (R.arg i (v n) ∷ acc) infos
  go _ _ = R.typeError (R.strErr "Not a record type name: " ∷ R.nameErr name ∷ [])

projNames→Patterns : List R.Name → List (R.Arg R.Pattern)
projNames→Patterns = go []
  where
  go : List (R.Arg R.Pattern) → List R.Name → List (R.Arg R.Pattern)
  go acc [] = acc
  go acc (π ∷ projs) = go (varg (R.proj π) ∷ acc) projs

projNames→Term : R.Term → List R.Name → R.Term
projNames→Term term [] = term
projNames→Term term (π ∷ projs) = R.def π [ varg (projNames→Term term projs) ]

convertClauses : RecordAssoc → R.Term → List R.Clause
convertClauses al term = fixIfEmpty (List.filterMap makeClause al)
  where
  makeClause : Projections × Projections → Maybe R.Clause
  makeClause (projl , just projr) =
    just (R.clause [] (goPat [] projr) (Maybe.rec R.unknown goTm projl))
    where
    goPat : List (R.Arg R.Pattern) → List R.Name → List (R.Arg R.Pattern)
    goPat acc [] = acc
    goPat acc (π ∷ projs) = goPat (varg (R.proj π) ∷ acc) projs

    goTm : List R.Name → R.Term
    goTm [] = term
    goTm (π ∷ projs) = R.def π [ varg (goTm projs) ]
  makeClause (_ , nothing) = nothing

  fixIfEmpty : List R.Clause → List R.Clause
  fixIfEmpty [] = [ R.clause [] [] R.unknown ]
  fixIfEmpty (c ∷ cs) = c ∷ cs

mapClause :
  (List (String × R.Arg R.Type) → List (String × R.Arg R.Type))
  → (List (R.Arg R.Pattern) → List (R.Arg R.Pattern))
  → (R.Clause → R.Clause)
mapClause f g (R.clause tel ps t) = R.clause (f tel) (g ps) t
mapClause f g (R.absurd-clause tel ps) = R.absurd-clause (f tel) (g ps)

recordIsoΣClauses : ΣFormat → List R.Clause
recordIsoΣClauses σ =
  funClauses (quote Iso.fun) Σ↔R ++
  funClauses (quote Iso.inv) R↔Σ ++
  pathClauses (quote Iso.rightInv) R↔Σ ++
  pathClauses (quote Iso.leftInv) Σ↔R
  where
  R↔Σ = ΣFormat→RecordAssoc σ
  Σ↔R = flipRecordAssoc R↔Σ

  funClauses : R.Name → RecordAssoc → List R.Clause
  funClauses name al =
    List.map
      (mapClause
        (("_" , varg R.unknown) ∷_)
        (λ ps → R.proj name v∷ R.var 0 v∷ ps))
      (convertClauses al (v 0))

  pathClauses : R.Name → RecordAssoc → List R.Clause
  pathClauses name al =
    List.map
      (mapClause
        (λ vs → ("_" , varg R.unknown) ∷ ("_" , varg R.unknown) ∷ vs)
        (λ ps → R.proj name v∷ R.var 1 v∷ R.var 0 v∷ ps))
      (convertClauses (fstIdRecordAssoc al) (v 1))

recordIsoΣTerm : ΣFormat → R.Term
recordIsoΣTerm σ = R.pat-lam (recordIsoΣClauses σ) []

-- with a provided ΣFormat for the record
declareRecordIsoΣ' : R.Name → ΣFormat → R.Name → R.TC Unit
declareRecordIsoΣ' idName σ recordName =
  let σTy = ΣFormat→Ty σ in
  recordName→isoTy recordName σTy >>= λ isoTy →
  R.declareDef (varg idName) isoTy >>
  R.defineFun idName (recordIsoΣClauses σ)

-- using the right-associated Σ given by the record fields
declareRecordIsoΣ : R.Name → R.Name → R.TC Unit
declareRecordIsoΣ idName recordName =
  R.getDefinition recordName >>= λ where
  (R.record-type _ fs) →
    let σ = List→ΣFormat (List.map (λ {(R.arg _ n) → n}) fs) in
    declareRecordIsoΣ' idName σ recordName
  _ →
    R.typeError (R.strErr "Not a record type name:" ∷ R.nameErr recordName ∷ [])

private
  module Example where
    variable
      ℓ ℓ' : Level
      A : Type ℓ
      B : A → Type ℓ'

    record Example0 {A : Type ℓ} (B : A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
      no-eta-equality -- works with or without eta equality
      field
        cool : A
        fun : A
        wow : B cool

    -- Declares a function `Example0IsoΣ` that gives an isomorphism between the record type and a
    -- right-associated nested Σ-type (with the parameters to Example0 as implict arguments).
    unquoteDecl Example0IsoΣ = declareRecordIsoΣ Example0IsoΣ (quote Example0)

    -- `Example0IsoΣ` has the type we expect
    test0 : Iso (Example0 B) (Σ[ a ∈ A ] (Σ[ _ ∈ A ] B a))
    test0 = Example0IsoΣ

    -- A record with no fields is isomorphic to Unit

    record Example1 : Type where

    unquoteDecl Example1IsoΣ = declareRecordIsoΣ Example1IsoΣ (quote Example1)

    test1 : Iso Example1 Unit
    test1 = Example1IsoΣ


module NativePolyIO where

open import Data.String.Base using (String) public
open import Level

record Unit {α} : Set α where
  constructor unit

{-# HASKELL type AgdaUnit a = () #-}

{-# COMPILED_DATA Unit AgdaUnit () #-}

postulate
  NativeIO : ∀ {ℓ} → Set ℓ → Set ℓ
  nativeReturn : ∀ {a} {A : Set a} → A → NativeIO A
  _native>>=_  : ∀ {a b} {A : Set a} {B : Set b} → NativeIO A → (A → NativeIO B) → NativeIO B

{-# COMPILED_TYPE NativeIO MAlonzo.Code.NativePolyIO.AgdaIO #-}
{-# BUILTIN IO NativeIO #-}

{-# HASKELL type AgdaIO a b = IO b #-}

{-# COMPILED nativeReturn (\_ _ -> return :: a -> IO a) #-}
{-# COMPILED _native>>=_  (\_ _ _ _ ->
                        (>>=) :: IO a -> (a -> IO b) -> IO b) #-}

{-# IMPORT Data.Text.IO #-}

postulate
  nativePutStrLn : ∀ {ℓ} → String → NativeIO (Unit{ℓ})
  nativeGetLine  : NativeIO String

{-# COMPILED nativePutStrLn (\ _ s -> Data.Text.IO.putStrLn s) #-}
{-# COMPILED nativeGetLine  Data.Text.IO.getLine #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Binary.Lex.NonStrict directly.
------------------------------------------------------------------------

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

module Data.List.Relation.Lex.NonStrict where

open import Data.List.Relation.Binary.Lex.NonStrict public


------------------------------------------------------------------------
-- Decoding types and subtypes into SK terms and equality
------------------------------------------------------------------------

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

module FOmegaInt.Undecidable.Decoding where

open import Data.List using ([]; _∷_)
open import Data.Product using (_,_; proj₁; proj₂; _×_)
open import Data.Fin using (zero; suc)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Kinding.Canonical as Canonical
open import FOmegaInt.Kinding.Canonical.Reduced as Reduced
open import FOmegaInt.Undecidable.SK
open import FOmegaInt.Undecidable.Encoding

open Syntax
open ElimCtx
open Substitution hiding (subst)
open Canonical.Kinding using (_⊢_<:_; _⊢_<:_⇇_; <:-⇇)
open Reduced.Kinding
open Encoding
open ≡-Reasoning
module V   = VarSubst
module EL  = TermLikeLemmas Substitution.termLikeLemmasElim
module ELV = LiftAppLemmas EL.varLiftAppLemmas

------------------------------------------------------------------------
-- Decoding of types into SK? terms

decode : Elim |Γ| → SK?Term
decode (var x₀ ∙ (a ∷ b ∷ _))     = K · (decode a) · (decode b)
decode (var x₁ ∙ (a ∷ b ∷ c ∷ _)) = S · (decode a) · (decode b) · (decode c)
decode (var x₂ ∙ (a ∷ b ∷ _))     = K · (decode a) · (decode b)
decode (var x₃ ∙ (a ∷ b ∷ c ∷ _)) = S · (decode a) · (decode b) · (decode c)
decode (var x₄ ∙ (a ∷ b ∷ _))     = decode a · decode b
decode (var x₅ ∙ _)               = K
decode (var x₆ ∙ _)               = S
decode (⊥ ∙ _)                    = ⊥
decode (⊤ ∙ _)                    = ⊤
{-# CATCHALL #-}
decode _ = ⊤

-- Decoding is the left-inverse of encoding.
--
-- NOTE. We encode SK terms but decode to SK? terms, so decoding is
-- strictly speaking only left-inverse when restricted to (pure) SK
-- terms.  Hence the use of `inject' here.

decode-encode : ∀ t → decode (encode t) ≡ inject t
decode-encode S       = refl
decode-encode K       = refl
decode-encode (s · t) = cong₂ _·_ (decode-encode s) (decode-encode t)

-- Decoding subsumes squashing

decode-squash : ∀ (a : Elim |Γ|) → decode (squashElim a) ≡ decode a
decode-squash (var x₀ ∙ [])              = refl   -- degenerate case
decode-squash (var x₀ ∙ (_ ∷ []))        = refl   -- degenerate case
decode-squash (var x₀ ∙ (a ∷ b ∷ _))     =
  cong₂ (λ a b → K · a · b) (decode-squash a) (decode-squash b)
decode-squash (var x₁ ∙ [])              = refl   -- degenerate case
decode-squash (var x₁ ∙ (_ ∷ []))        = refl   -- degenerate case
decode-squash (var x₁ ∙ (_ ∷ _ ∷ []))    = refl   -- degenerate case
decode-squash (var x₁ ∙ (a ∷ b ∷ c ∷ _)) =
  trans (cong (S · _ · _ ·_) (decode-squash c))
        (cong₂ (λ a b → S · a · b · _) (decode-squash a) (decode-squash b))
decode-squash (var x₂ ∙ [])              = refl   -- degenerate case
decode-squash (var x₂ ∙ (_ ∷ []))        = refl   -- degenerate case
decode-squash (var x₂ ∙ (a ∷ b ∷ _))     =
  cong₂ (λ a b → K · a · b) (decode-squash a) (decode-squash b)
decode-squash (var x₃ ∙ [])              = refl   -- degenerate case
decode-squash (var x₃ ∙ (_ ∷ []))        = refl   -- degenerate case
decode-squash (var x₃ ∙ (_ ∷ _ ∷ []))    = refl   -- degenerate case
decode-squash (var x₃ ∙ (a ∷ b ∷ c ∷ _)) =
  trans (cong (S · _ · _ ·_) (decode-squash c))
        (cong₂ (λ a b → S · a · b · _) (decode-squash a) (decode-squash b))
decode-squash (var x₄ ∙ [])              = refl   -- degenerate case
decode-squash (var x₄ ∙ (_ ∷ []))        = refl   -- degenerate case
decode-squash (var x₄ ∙ (a ∷ b ∷ _))     =
  cong₂ _·_ (decode-squash a) (decode-squash b)
decode-squash (var x₅ ∙ as) = refl
decode-squash (var x₆ ∙ as) = refl
decode-squash (⊥ ∙ as)      = refl
decode-squash (⊤ ∙ as)      = refl
-- squashed cases
decode-squash (Π k a   ∙ as) = refl
decode-squash ((a ⇒ b) ∙ as) = refl
decode-squash (Λ k a   ∙ as) = refl
decode-squash (ƛ a b   ∙ as) = refl
decode-squash (a ⊡ b   ∙ as) = refl

-- Helper lemmas to be used when decoding kinding derivations.

⌜⌝-⌞⌟-∙∙ : ∀ {n} (a : Elim n) → ⌜ ⌞ a ⌟ ⌝ ∙∙ [] ≡ a
⌜⌝-⌞⌟-∙∙ a = begin
  ⌜ ⌞ a ⌟ ⌝ ∙∙ []  ≡⟨ ∙∙-[] ⌜ ⌞ a ⌟ ⌝ ⟩
  ⌜ ⌞ a ⌟ ⌝        ≡⟨ ⌜⌝∘⌞⌟-id a ⟩
  a                ∎

⌜⌝-⌞⌟-weaken-sub₁ : ∀ {n} (a b : Elim n) →
                    (⌜ weaken ⌞ a ⌟ ⌝ ∙∙ []) Elim[ ⌞ b ⌟ ] ≡ a
⌜⌝-⌞⌟-weaken-sub₁ a b = begin
    (⌜ weaken ⌞ a ⌟ ⌝ ∙∙ []) Elim[ ⌞ b ⌟ ]
  ≡˘⟨ cong (λ a → (⌜ a ⌝ ∙∙ []) Elim[ ⌞ b ⌟ ]) (⌞⌟-/Var a) ⟩
    (⌜ ⌞ weakenElim a ⌟ ⌝ ∙∙ []) Elim[ ⌞ b ⌟ ]
  ≡⟨ cong (_Elim[ ⌞ b ⌟ ]) (⌜⌝-⌞⌟-∙∙ (weakenElim a)) ⟩
    weakenElim a Elim[ ⌞ b ⌟ ]
  ≡⟨ EL.weaken-sub a ⟩
    a
  ∎

⌜⌝-⌞⌟-weaken-sub₂ : ∀ {n} (a b c : Elim n) →
  ((⌜ weaken (weaken ⌞ a ⌟) ⌝ ∙∙ []) Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ] ≡ a
⌜⌝-⌞⌟-weaken-sub₂ a b c = begin
    ((⌜ weaken (weaken ⌞ a ⌟) ⌝ ∙∙ []) Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ]
  ≡˘⟨ cong (λ a → ((⌜ a ⌝ ∙∙ []) Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ])
           (trans (⌞⌟-/Var (weakenElim a)) (cong weaken (⌞⌟-/Var a))) ⟩
    ((⌜ ⌞ weakenElim (weakenElim a) ⌟ ⌝ ∙∙ []) Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ]
  ≡⟨ cong (λ a → (a Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ])
          (⌜⌝-⌞⌟-∙∙ (weakenElim (weakenElim a))) ⟩
    (weakenElim (weakenElim a) Elim/ sub ⌞ b ⌟ ↑) Elim[ ⌞ c ⌟ ]
  ≡⟨ cong (_Elim[ ⌞ c ⌟ ]) (sym (EL.weaken-/ (weakenElim a))) ⟩
    weakenElim (weakenElim a Elim/ sub ⌞ b ⌟) Elim[ ⌞ c ⌟ ]
  ≡⟨ cong ((_Elim[ ⌞ c ⌟ ]) ∘ weakenElim) (EL.weaken-sub a) ⟩
    weakenElim a Elim[ ⌞ c ⌟ ]
  ≡⟨ EL.weaken-sub a ⟩
    a
  ∎

-- Decoding of (reduced) canonical type order into the SK? term order.

mutual

  decode-∼ : ∀ {a b} → Γ-SK? ⊢ a ∼ b → decode a ≤SK? decode b
  decode-∼ (∼-trans a∼b b∼c) = ≤?-trans (decode-∼ a∼b) (decode-∼ b∼c)
  decode-∼ (∼-⊥ b⇉b⋯b)       = ≤?-⊥
  decode-∼ (∼-⊤ a⇉a⋯a)       = ≤?-⊤
  decode-∼ (∼-∙ (⇉-var x₀ _ refl) (∼-∷ _ _ a₁∼b₁ (∼-∷ _ _ a₂∼b₂ ∼-[]))) =
    ≤?-· (≤?-· ≤?-refl (decode-∼ a₁∼b₁)) (decode-∼ a₂∼b₂)
  decode-∼ (∼-∙ (⇉-var x₁ _ refl)
           (∼-∷ _ _ a₁∼b₁ (∼-∷ _ _ a₂∼b₂ (∼-∷ _ _ a₃∼b₃ ∼-[])))) =
    ≤?-· (≤?-· (≤?-· ≤?-refl (decode-∼ a₁∼b₁)) (decode-∼ a₂∼b₂))
         (decode-∼ a₃∼b₃)
  decode-∼ (∼-∙ (⇉-var x₂ _ refl) (∼-∷ _ _ a₁∼b₁ (∼-∷ _ _ a₂∼b₂ ∼-[]))) =
    ≤?-· (≤?-· ≤?-refl (decode-∼ a₁∼b₁)) (decode-∼ a₂∼b₂)
  decode-∼ (∼-∙ (⇉-var x₃ _ refl)
           (∼-∷ _ _ a₁∼b₁ (∼-∷ _ _ a₂∼b₂ (∼-∷ _ _ a₃∼b₃ ∼-[])))) =
    ≤?-· (≤?-· (≤?-· ≤?-refl (decode-∼ a₁∼b₁)) (decode-∼ a₂∼b₂))
         (decode-∼ a₃∼b₃)
  decode-∼ (∼-∙ (⇉-var x₄ _ refl) (∼-∷ _ _ a₁∼b₁ (∼-∷ _ _ a₂∼b₂ ∼-[]))) =
    ≤?-· (decode-∼ a₁∼b₁) (decode-∼ a₂∼b₂)
  decode-∼ (∼-∙ (⇉-var x₅ _ refl) ∼-[]) = ≤?-refl
  decode-∼ (∼-∙ (⇉-var x₆ _ refl) ∼-[]) = ≤?-refl
  decode-∼ (∼-⟨| a⇉b⋯c) = proj₁ (decode-Ne⇉ a⇉b⋯c)
  decode-∼ (∼-|⟩ a⇉b⋯c) = proj₂ (decode-Ne⇉ a⇉b⋯c)

  decode-Ne⇉ : ∀ {a b c} → Γ-SK? ⊢Ne a ⇉ b ⋯ c →
               decode b ≤SK? decode a × decode a ≤SK? decode c
  decode-Ne⇉ (⇉-∙ (⇉-var x₀ _ refl) (⇉-∷ {a} a∈* (⇉-∷ {b} b∈* ⇉-[]))) =
    subst (λ a′ → decode a′ ≤SK? K · (decode a) · (decode b))
          (sym (⌜⌝-⌞⌟-weaken-sub₁ a b)) ≤?-Kexp ,
    subst₂ (λ a′ b′ → K · decode a  · decode b ≤SK?
                      K · decode a′ · decode b′)
           (sym (⌜⌝-⌞⌟-weaken-sub₁ a b)) (sym (⌜⌝-⌞⌟-∙∙ b)) ≤?-refl
  decode-Ne⇉ (⇉-∙ (⇉-var x₁ _ refl)
                  (⇉-∷ {a} a∈* (⇉-∷ {b} b∈* (⇉-∷ {c} c∈* ⇉-[])))) =
    subst₂ (λ a′ b′ → decode a′ · decode c′ · (decode b′ · decode c′) ≤SK?
                      S · decode a · decode b · decode c)
      (sym (⌜⌝-⌞⌟-weaken-sub₂ a b c)) (sym (⌜⌝-⌞⌟-weaken-sub₁ b c))
      (subst (λ c′ → decode a · decode c′ · (decode b · decode c′) ≤SK?
                     S · decode a · decode b · decode c)
        (sym (⌜⌝-⌞⌟-∙∙ c)) ≤?-Sexp) ,
    subst₂ (λ a′ b′ → S · decode a  · decode b  · decode c ≤SK?
                      S · decode a′ · decode b′ · decode c′)
      (sym (⌜⌝-⌞⌟-weaken-sub₂ a b c)) (sym (⌜⌝-⌞⌟-weaken-sub₁ b c))
      (subst (λ c′ → S · decode a · decode b · decode c ≤SK?
                     S · decode a · decode b · decode c′)
        (sym (⌜⌝-⌞⌟-∙∙ c)) ≤?-refl)
    where c′ = ⌜ ⌞ c ⌟ ⌝ ∙∙ []
  decode-Ne⇉ (⇉-∙ (⇉-var x₂ _ refl) (⇉-∷ {a} a∈* (⇉-∷ {b} b∈* ⇉-[]))) =
    subst₂ (λ a′ b′ → K · decode a′ · decode b′ ≤SK?
                      K · decode a  · decode b)
           (sym (⌜⌝-⌞⌟-weaken-sub₁ a b)) (sym (⌜⌝-⌞⌟-∙∙ b)) ≤?-refl ,
    subst (λ a′ → K · decode a · decode b ≤SK? decode a′)
          (sym (⌜⌝-⌞⌟-weaken-sub₁ a b)) ≤?-Kred
  decode-Ne⇉ (⇉-∙ (⇉-var x₃ _ refl)
             (⇉-∷ {a} a∈* (⇉-∷ {b} b∈* (⇉-∷ {c} c∈* ⇉-[])))) =
    subst₂ (λ a′ b′ → S · decode a′ · decode b′ · decode c′ ≤SK?
                      S · decode a  · decode b  · decode c)
      (sym (⌜⌝-⌞⌟-weaken-sub₂ a b c)) (sym (⌜⌝-⌞⌟-weaken-sub₁ b c))
      (subst (λ c′ → S · decode a · decode b · decode c′ ≤SK?
                     S · decode a · decode b · decode c)
        (sym (⌜⌝-⌞⌟-∙∙ c)) ≤?-refl) ,
    subst₂ (λ a′ b′ → S · decode a · decode b · decode c ≤SK?
                      decode a′ · decode c′ · (decode b′ · decode c′))
      (sym (⌜⌝-⌞⌟-weaken-sub₂ a b c)) (sym (⌜⌝-⌞⌟-weaken-sub₁ b c))
      (subst (λ c′ → S · decode a · decode b · decode c ≤SK?
                     decode a · decode c′ · (decode b · decode c′))
        (sym (⌜⌝-⌞⌟-∙∙ c)) ≤?-Sred)
    where c′ = ⌜ ⌞ c ⌟ ⌝ ∙∙ []
  decode-Ne⇉ (⇉-∙ (⇉-var x₄ _ refl) (⇉-∷ a∈* (⇉-∷ b∈* ⇉-[]))) = ≤?-⊥ , ≤?-⊤
  decode-Ne⇉ (⇉-∙ (⇉-var x₅ _ refl) ⇉-[]) = ≤?-⊥ , ≤?-⊤
  decode-Ne⇉ (⇉-∙ (⇉-var x₆ _ refl) ⇉-[]) = ≤?-⊥ , ≤?-⊤

-- The SK? signature is a first-order context.

kdS-fo : FOKind (kdS {0})
kdS-fo = fo-⋯

kdK-fo : FOKind (kdK {0})
kdK-fo = fo-⋯

kdApp-fo : FOKind (kdApp {0})
kdApp-fo = fo-Π (fo-Π fo-⋯)

kdSRed-fo : FOKind (kdSRed {0})
kdSRed-fo = fo-Π (fo-Π (fo-Π fo-⋯))

kdKRed-fo : FOKind (kdKRed {0})
kdKRed-fo = fo-Π (fo-Π fo-⋯)

kdSExp-fo : FOKind (kdSExp {0})
kdSExp-fo = fo-Π (fo-Π (fo-Π fo-⋯))

kdKExp-fo : FOKind (kdKExp {0})
kdKExp-fo = fo-Π (fo-Π fo-⋯)

Γ-SK?-fo : FOCtx Γ-SK?
Γ-SK?-fo =
  fo-∷ (fo-kd kdKExp-fo)
       (fo-∷ (fo-kd kdSExp-fo)
             (fo-∷ (fo-kd kdKRed-fo)
                   (fo-∷ (fo-kd kdSRed-fo)
                         (fo-∷ (fo-kd kdApp-fo)
                               (fo-∷ (fo-kd kdK-fo)
                                     (fo-∷ (fo-kd kdS-fo) fo-[]))))))

-- Decoding of canonical subtyping into the SK? term order.

decode-<: : ∀ {a b} → Γ-SK? ⊢ a <: b → decode a ≤SK? decode b
decode-<: {a} {b} a<:b =
  subst₂ (_≤SK?_) (decode-squash a) (decode-squash b)
         (decode-∼ (reduce-<: Γ-SK?-fo a<:b))

decode-<:⇇ : ∀ {a b} → Γ-SK? ⊢ a <: b ⇇ ⌜*⌝ → decode a ≤SK? decode b
decode-<:⇇ {a} {b} (<:-⇇ _ _ a<:b) = decode-<: a<:b

-- Full decoding to SK term equality.

decode-<:⇇-encode : ∀ {s t} → Γ-SK? ⊢ encode s <: encode t ⇇ ⌜*⌝ → s ≡SK t
decode-<:⇇-encode {s} {t} es<:et⇇* =
  inject-≤SK?-≡SK (subst₂ (_≤SK?_) (decode-encode s) (decode-encode t)
                          (decode-<:⇇ es<:et⇇*))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Examples of format strings and printf
------------------------------------------------------------------------

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

module README.Text.Printf where

open import Data.Nat.Base
open import Data.Char.Base
open import Data.List.Base
open import Data.String.Base
open import Data.Sum.Base

open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Format strings

open import Text.Format

-- We can specify a format by writing a string which will get interpreted
-- by a lexer into a list of formatting directives.

-- The specification types are always started with a '%' character:

-- Integers (%d or %i)
-- Naturals (%u)
-- Floats   (%f)
-- Chars    (%c)
-- Strings  (%s)

-- Anything which is not a type specification is a raw string to be spliced
-- in the output of printf.

-- For instance the following format alternates types and raw strings

_ : lexer "%s: %u + %u ≡ %u"
  ≡ inj₂ (`String ∷ Raw ": " ∷ `ℕ ∷ Raw " + " ∷ `ℕ ∷ Raw " ≡ " ∷ `ℕ ∷ [])
_ = refl

-- Lexing can fail. There are two possible errors:

-- If we start a specification type with a '%' but the string ends then
-- we get an UnexpectedEndOfString error

_ : lexer "%s: %u + %u ≡ %"
  ≡ inj₁ (UnexpectedEndOfString "%s: %u + %u ≡ %")
_ = refl

-- If we start a specification type with a '%' and the following character
-- does not correspond to an existing type, we get an InvalidType error
-- together with a focus highlighting the position of the problematic type.

_ : lexer "%s: %u + %a ≡ %u"
  ≡ inj₁ (InvalidType "%s: %u + %" 'a' " ≡ %u")
_ = refl

------------------------------------------------------------------------
-- Printf

open import Text.Printf

-- printf is a function which takes a format string as an argument and
-- returns a function expecting a value for each type specification present
-- in the format and returns a string splicing in these values into the
-- format string.

-- For instance `printf "%s: %u + %u ≡ %u"` is a
-- `String → ℕ → ℕ → ℕ → String` function.

_ : String → ℕ → ℕ → ℕ → String
_ = printf "%s: %u + %u ≡ %u"

_ : printf "%s: %u + %u ≡ %u" "example" 3 2 5
  ≡ "example: 3 + 2 ≡ 5"
_ = refl

-- If the format string str is invalid then `printf str` will have type
-- `Error e` where `e` is the lexing error.

_ : Text.Printf.Error (UnexpectedEndOfString "%s: %u + %u ≡ %")
_ = printf "%s: %u + %u ≡ %"

_ : Text.Printf.Error (InvalidType "%s: %u + %" 'a' " ≡ %u")
_ = printf "%s: %u + %a ≡ %u"

-- Trying to pass arguments to such an ̀Error` type will lead to a
-- unification error which hopefully makes the problem clear e.g.
-- `printf "%s: %u + %a ≡ %u" "example" 3 2 5` fails with the error:

-- Text.Printf.Error (InvalidType "%s: %u + %" 'a' " ≡ %u") should be
-- a function type, but it isn't
-- when checking that "example" 3 2 5 are valid arguments to a
-- function of type Text.Printf.Printf (lexer "%s: %u + %a ≡ %u")


-- Actually, we're cheating (for expediency); this is
-- Symmetric Rig, not just Rig.
module Categories.RigCategory where

open import Level
open import Data.Fin renaming (zero to 0F; suc to sucF)
open import Data.Product using (_,_)

open import Categories.Category
open import Categories.Functor
open import Categories.Monoidal
open import Categories.Monoidal.Braided
open import Categories.Monoidal.Braided.Helpers
open import Categories.Monoidal.Symmetric
open import Categories.Monoidal.Helpers
open import Categories.NaturalIsomorphism
open import Categories.NaturalTransformation using (_∘₀_; _∘₁_; _∘ˡ_; _∘ʳ_; NaturalTransformation) renaming (_≡_ to _≡ⁿ_; id to idⁿ)

-- first round of setting up, just for defining the NaturalIsomorphisms
-- of Rig.  Next one will be for the equalities.
module BimonoidalHelperFunctors {o ℓ e} {C : Category o ℓ e}
  {M⊎ M× : Monoidal C} (B⊎ : Braided M⊎) (B× : Braided M×) where

  private
    module C = Category C
    module M⊎ = Monoidal M⊎
    module M× = Monoidal M×
    module B⊎ = Braided B⊎
    module B× = Braided B×

  module h⊎ = MonoidalHelperFunctors C M⊎.⊗ M⊎.id
  module h× = MonoidalHelperFunctors C M×.⊗ M×.id
  module b⊎ = BraidedHelperFunctors C M⊎.⊗ M⊎.id
  module b× = BraidedHelperFunctors C M×.⊗ M×.id

  module br⊎ = b⊎.Braiding M⊎.identityˡ M⊎.identityʳ M⊎.assoc B⊎.braid
  module br× = b×.Braiding M×.identityˡ M×.identityʳ M×.assoc B×.braid

  import Categories.Power.NaturalTransformation
  private module PowNat = Categories.Power.NaturalTransformation C
  open PowNat hiding (module C)

  -- for convenience of multiple of the larger equations, define
  -- shorthands for 3 and 4 variables
  x⊗z : Powerendo 3
  x⊗z = select 0 h×.⊗₂ select 2

  z⊗x : Powerendo 3
  z⊗x = (select 2) h×.⊗₂ (select 0)

  z⊗y : Powerendo 3
  z⊗y = select 2 h×.⊗₂ select 1

  y⊗z : Powerendo 3
  y⊗z = select 1 h×.⊗₂ select 2

  x : Powerendo 4
  x = select 0

  y : Powerendo 4
  y = select 1

  z : Powerendo 4
  z = select 2

  w : Powerendo 4
  w = select 3

  -- combinations of 3 variables
  x⊗[y⊕z] : Powerendo 3
  x⊗[y⊕z] = h×.x h×.⊗ (h⊎.x⊗y)

  x⊗[z⊕y] : Powerendo 3
  x⊗[z⊕y] = h×.x h×.⊗ h⊎.y⊗x

  [x⊕y]⊗z : Powerendo 3
  [x⊕y]⊗z = (h⊎.x⊗y) h×.⊗ h×.x

  z⊗[x⊕y] : Powerendo 3
  z⊗[x⊕y] = (select 2) h×.⊗₂ ((select 0) h⊎.⊗₂ (select 1))

  [x⊗y]⊕[x⊗z] : Powerendo 3
  [x⊗y]⊕[x⊗z] = (select 0 h×.⊗₂ select 1) h⊎.⊗₂ (select 0 h×.⊗₂ select 2)

  [x⊗z]⊕[y⊗z] : Powerendo 3
  [x⊗z]⊕[y⊗z] = (select 0 h×.⊗₂ select 2) h⊎.⊗₂ (select 1 h×.⊗₂ select 2)

  [z⊗x]⊕[z⊗y] : Powerendo 3
  [z⊗x]⊕[z⊗y] = z⊗x h⊎.⊗₂ z⊗y

  [x⊗z]⊕[x⊗y] : Powerendo 3
  [x⊗z]⊕[x⊗y] = x⊗z h⊎.⊗₂ (select 0 h×.⊗₂ select 1)

  x⊗0 : Powerendo 1
  x⊗0 = h⊎.x h×.⊗ h⊎.id↑

  0⊗x : Powerendo 1
  0⊗x = h⊎.id↑ h×.⊗ h⊎.x

  0↑ : Powerendo 1
  0↑ = widenˡ 1 h⊎.id↑

  xy : Powerendo 4
  xy = widenʳ 2 h×.x⊗y

  yz : Powerendo 4
  yz = select 1 h×.⊗₂ select 2

  xw : Powerendo 4
  xw = select 0 h×.⊗₂ select 3

  yw : Powerendo 4
  yw = select 1 h×.⊗₂ select 3

  zw : Powerendo 4
  zw = select 2 h×.⊗₂ select 3

  xz : Powerendo 4
  xz = select 0 h×.⊗₂ select 2

  z⊕w : Powerendo 4
  z⊕w = widenˡ 2 h⊎.x⊗y

  -- for 2 variables
  x₂ : Powerendo 2
  x₂ = widenʳ 1 h×.x

  y₂ : Powerendo 2
  y₂ = widenˡ 1 h×.x

  -- 0 variables!
  0₀ : Powerendo 0
  0₀ = h⊎.id↑

  0⊗0 : Powerendo 0
  0⊗0 = 0₀ h×.⊗ 0₀

  0⊕0 : Powerendo 0
  0⊕0 = 0₀ h⊎.⊗ 0₀

  1₀ : Powerendo 0
  1₀ = h×.id↑

  -- 1 variable + 0
  A0 : Powerendo 1
  A0 = h×.x h×.⊗ 0₀

  0A : Powerendo 1
  0A = 0₀ h×.⊗ h×.x

  -- 2 variables + 0
  0₂ : Powerendo 2
  0₂ = widenʳ 2 0₀

  0[A⊕B] : Powerendo 2
  0[A⊕B] = 0₂ h×.⊗₂ h⊎.x⊗y

  0[AB] : Powerendo 2
  0[AB] = 0₀ h×.⊗ (h×.x⊗y)

  [0A]B : Powerendo 2
  [0A]B = 0A h×.⊗ h×.x

  0A₂ : Powerendo 2
  0A₂ = 0₂ h×.⊗₂ select 0

  0B : Powerendo 2
  0B = 0₂ h×.⊗₂ (select 1)

  A0₂ : Powerendo 2
  A0₂ = select 0 h×.⊗₂ 0₂

  AB : Powerendo 2
  AB = h×.x⊗y

  0A⊕0B : Powerendo 2
  0A⊕0B = 0A₂ h⊎.⊗₂ 0B

  A[0B] : Powerendo 2
  A[0B] = (widenʳ 1 h×.x) h×.⊗₂ 0B

  [A0]B : Powerendo 2
  [A0]B = A0 h×.⊗ h×.x

  A[0⊕B] : Powerendo 2
  A[0⊕B] = h×.x h×.⊗ h⊎.id⊗x

  A0⊕AB : Powerendo 2
  A0⊕AB = A0₂ h⊎.⊗₂ AB

  0⊕AB : Powerendo 2
  0⊕AB = 0₂ h⊎.⊗₂ AB

  -- 2 variables + 1
  1₂ : Powerendo 2
  1₂ = widenʳ 2 1₀

  A⊕B : Powerendo 2
  A⊕B = h⊎.x⊗y

  1[A⊕B] : Powerendo 2
  1[A⊕B] = 1₀ h×.⊗ A⊕B

  1A⊕1B : Powerendo 2
  1A⊕1B = h×.id⊗x h⊎.⊗ h×.id⊗x

  -- like Laplaza, use concatenation for ⊗ to make things easier to read
  -- also ⊗ binds more tightly, so skip those parens

  -- combinations of 4 variables
  [x⊕[y⊕z]]w : Powerendo 4
  [x⊕[y⊕z]]w = h⊎.x⊗[y⊗z] h×.⊗ h⊎.x

  xw⊕[y⊕z]w : Powerendo 4
  xw⊕[y⊕z]w = (x h×.⊗₂ w) h⊎.⊗₂ ((y h⊎.⊗₂ z) h×.⊗₂ w)

  xw⊕[yw⊕zw] : Powerendo 4
  xw⊕[yw⊕zw] = (x h×.⊗₂ w) h⊎.⊗₂ ((y h×.⊗₂ w) h⊎.⊗₂ (z h×.⊗₂ w))

  [xw⊕yw]⊕zw : Powerendo 4
  [xw⊕yw]⊕zw = ((x h×.⊗₂ w) h⊎.⊗₂ (y h×.⊗₂ w)) h⊎.⊗₂ (z h×.⊗₂ w)

  [[x⊕y]⊕z]w : Powerendo 4
  [[x⊕y]⊕z]w = h⊎.[x⊗y]⊗z h×.⊗ h⊎.x

  [x⊕y]w⊕zw : Powerendo 4
  [x⊕y]w⊕zw = ((x h⊎.⊗₂ y) h×.⊗₂ w) h⊎.⊗₂ (z h×.⊗₂ w)

  x[y[z⊕w]] : Powerendo 4
  x[y[z⊕w]] = x h×.⊗₂ (y h×.⊗₂ (z h⊎.⊗₂ w))

  x[yz⊕yw] : Powerendo 4
  x[yz⊕yw] = x h×.⊗₂ ((y h×.⊗₂ z) h⊎.⊗₂ (y h×.⊗₂ w))

  x[yz]⊕x[yw] : Powerendo 4
  x[yz]⊕x[yw] = (x h×.⊗₂ (y h×.⊗₂ z)) h⊎.⊗₂ (x h×.⊗₂ (y h×.⊗₂ w))

  [xy][z⊕w] : Powerendo 4
  [xy][z⊕w] = (x h×.⊗₂ y) h×.⊗₂ (z h⊎.⊗₂ w)

  [xy]z⊕[xy]w : Powerendo 4
  [xy]z⊕[xy]w = let xy = (x h×.⊗₂ y) in (xy h×.⊗₂ z) h⊎.⊗₂ (xy h×.⊗₂ w)

  x⊕y : Powerendo 4
  x⊕y = widenʳ 2 h⊎.x⊗y

  x[z⊕w] : Powerendo 4
  x[z⊕w] = x h×.⊗₂ z⊕w

  y[z⊕w] : Powerendo 4
  y[z⊕w] = y h×.⊗₂ z⊕w

  xz⊕xw : Powerendo 4
  xz⊕xw = xz h⊎.⊗₂ xw

  yz⊕yw : Powerendo 4
  yz⊕yw = yz h⊎.⊗₂ yw

  xz⊕yz : Powerendo 4
  xz⊕yz = xz h⊎.⊗₂ yz

  xw⊕yw : Powerendo 4
  xw⊕yw = xw h⊎.⊗₂ yw

  [x⊕y]z : Powerendo 4
  [x⊕y]z = x⊕y h×.⊗₂ z

  [x⊕y]w : Powerendo 4
  [x⊕y]w = x⊕y h×.⊗₂ w

  [x⊕y][z⊕w] : Powerendo 4
  [x⊕y][z⊕w] = x⊕y h×.⊗₂ z⊕w

  [x⊕y]z⊕[x⊕y]w : Powerendo 4
  [x⊕y]z⊕[x⊕y]w = [x⊕y]z h⊎.⊗₂ [x⊕y]w

  [xz⊕yz]⊕[xw⊕yw] : Powerendo 4
  [xz⊕yz]⊕[xw⊕yw] = xz⊕yz h⊎.⊗₂ xw⊕yw

  [[xz⊕yz]⊕xw]⊕yw : Powerendo 4
  [[xz⊕yz]⊕xw]⊕yw = (xz⊕yz h⊎.⊗₂ xw) h⊎.⊗₂ yw

  x[z⊕w]⊕y[z⊕w] : Powerendo 4
  x[z⊕w]⊕y[z⊕w] = x[z⊕w] h⊎.⊗₂ y[z⊕w]

  [xz⊕xw]⊕[yz⊕yw] : Powerendo 4
  [xz⊕xw]⊕[yz⊕yw] = xz⊕xw h⊎.⊗₂ yz⊕yw

  [[xz⊕xw]⊕yz]⊕yw : Powerendo 4
  [[xz⊕xw]⊕yz]⊕yw = (xz⊕xw h⊎.⊗₂ yz) h⊎.⊗₂ yw

  [xz⊕[xw⊕yz]]⊕yw : Powerendo 4
  [xz⊕[xw⊕yz]]⊕yw = (xz h⊎.⊗₂ (xw h⊎.⊗₂ yz)) h⊎.⊗₂ yw

  [xz⊕[yz⊕xw]]⊕yw : Powerendo 4
  [xz⊕[yz⊕xw]]⊕yw = (xz h⊎.⊗₂ (yz h⊎.⊗₂ xw)) h⊎.⊗₂ yw

  module SRig (S⊎ : Symmetric B⊎) (S× : Symmetric B×)
    (distribₗ : NaturalIsomorphism x⊗[y⊕z] [x⊗y]⊕[x⊗z])
    (distribᵣ : NaturalIsomorphism [x⊕y]⊗z [x⊗z]⊕[y⊗z])
    (annₗ : NaturalIsomorphism 0⊗x 0↑)
    (annᵣ : NaturalIsomorphism x⊗0 0↑) where

    open NaturalIsomorphism distribₗ using () renaming (F⇒G to dₗ)
    open NaturalIsomorphism distribᵣ using () renaming (F⇒G to dᵣ)
    open NaturalIsomorphism annₗ using () renaming (F⇒G to aₗ)
    open NaturalIsomorphism annᵣ using () renaming (F⇒G to aᵣ)

    dₗ-over : ∀ {n} (F₁ F₂ F₃ : Powerendo n) → NaturalTransformation (F₁ h×.⊗₂ (F₂ h⊎.⊗₂ F₃)) ((F₁ h×.⊗₂ F₂) h⊎.⊗₂ (F₁ h×.⊗₂ F₃))
    dₗ-over F₁ F₂ F₃ = dₗ ∘ʳ plex {3} F₁ F₂ F₃

    dᵣ-over : ∀ {n} (F₁ F₂ F₃ : Powerendo n) → NaturalTransformation ((F₁ h⊎.⊗₂ F₂) h×.⊗₂ F₃) ((F₁ h×.⊗₂ F₃) h⊎.⊗₂ (F₂ h×.⊗₂ F₃))
    dᵣ-over F₁ F₂ F₃ = dᵣ ∘ʳ plex {3} F₁ F₂ F₃

    aₗ-over : ∀ {n} (F₁ : Powerendo n) → NaturalTransformation ((widenʳ n 0₀) h×.⊗₂ F₁) (widenʳ n 0₀)
    aₗ-over F₁ = aₗ ∘ʳ plex {1} F₁

    aᵣ-over : ∀ {n} (F₁ : Powerendo n) → NaturalTransformation (F₁ h×.⊗₂ (widenʳ n 0₀)) (widenʳ n 0₀)
    aᵣ-over F₁ = aᵣ ∘ʳ plex {1} F₁

    uₗ⊕-over : ∀ {n} (F₁ : Powerendo n) → NaturalTransformation ((widenʳ n 0₀) h⊎.⊗₂ F₁) F₁
    uₗ⊕-over F₁ = (NaturalIsomorphism.F⇒G M⊎.identityˡ) ∘ʳ plex {1} F₁

    uₗ⊗-over : ∀ {n} (F₁ : Powerendo n) → NaturalTransformation ((widenʳ n 1₀) h×.⊗₂ F₁) F₁
    uₗ⊗-over F₁ = (NaturalIsomorphism.F⇒G M×.identityˡ) ∘ʳ plex {1} F₁

    uᵣ⊗-over : ∀ {n} (F₁ : Powerendo n) → NaturalTransformation (F₁ h×.⊗₂ (widenʳ n 1₀)) F₁
    uᵣ⊗-over F₁ = (NaturalIsomorphism.F⇒G M×.identityʳ) ∘ʳ plex {1} F₁

    s⊕-over : ∀ {n} (F₁ F₂ : Powerendo n) → NaturalTransformation (F₁ h⊎.⊗₂ F₂) (F₂ h⊎.⊗₂ F₁)
    s⊕-over F₁ F₂ = (NaturalIsomorphism.F⇒G B⊎.braid) ∘ʳ plex {2} F₁ F₂

    s⊗-over : ∀ {n} (F₁ F₂ : Powerendo n) → NaturalTransformation (F₁ h×.⊗₂ F₂) (F₂ h×.⊗₂ F₁)
    s⊗-over F₁ F₂ = (NaturalIsomorphism.F⇒G B×.braid) ∘ʳ plex {2} F₁ F₂

    -- for 2 variables
    idx₂ : NaturalTransformation x₂ x₂
    idx₂ = idⁿ

    idy₂ : NaturalTransformation y₂ y₂
    idy₂ = idⁿ

    idxy : NaturalTransformation AB AB
    idxy = idⁿ

    -- these are all for 3 variables
    Bxz : NaturalTransformation x⊗z z⊗x
    Bxz = br×.B-over (select 0) (select 2)

    Byz : NaturalTransformation y⊗z z⊗y
    Byz = br×.B-over (select 1) (select 2)

    Bxz⊕Byz : NaturalTransformation [x⊗z]⊕[y⊗z] [z⊗x]⊕[z⊗y]
    Bxz⊕Byz = Bxz h⊎.⊗ⁿ′ Byz

    B[x⊕y]z : NaturalTransformation [x⊕y]⊗z z⊗[x⊕y]
    B[x⊕y]z = br×.B-over (widenʳ 1 h⊎.x⊗y) (select 2)

    dᵣABC : NaturalTransformation [x⊕y]⊗z [x⊗z]⊕[y⊗z]
    dᵣABC = dᵣ-over (select 0) (select 1) (select 2)

    dₗABC : NaturalTransformation x⊗[y⊕z] [x⊗y]⊕[x⊗z]
    dₗABC = dₗ-over (select 0) (select 1) (select 2)

    dₗACB : NaturalTransformation x⊗[z⊕y] [x⊗z]⊕[x⊗y]
    dₗACB = dₗ-over (select 0) (select 2) (select 1)

    dₗCAB : NaturalTransformation z⊗[x⊕y] [z⊗x]⊕[z⊗y]
    dₗCAB = dₗ-over (select 2) (select 0) (select 1)

    1⊗Byz : NaturalTransformation x⊗[y⊕z] x⊗[z⊕y]
    1⊗Byz = reduceN M×.⊗ h×.id₂ (br⊎.B-over (select 0) (select 1))

    B[x⊗y][x⊗z] : NaturalTransformation [x⊗y]⊕[x⊗z] [x⊗z]⊕[x⊗y]
    B[x⊗y][x⊗z] = br⊎.B-over (widenʳ 1 h×.x⊗y) x⊗z

    -- these are all for 4 variables
    dᵣA[B⊕C]D : NaturalTransformation [x⊕[y⊕z]]w xw⊕[y⊕z]w
    dᵣA[B⊕C]D = dᵣ-over (select 0) (widenʳ 1 (widenˡ 1 h⊎.x⊗y)) (select 3)

    dᵣBCD : NaturalTransformation (widenˡ 1 [x⊕y]⊗z) (widenˡ 1 [x⊗z]⊕[y⊗z])
    dᵣBCD = dᵣ-over (select 1) (select 2) (select 3)

    id03 : NaturalTransformation xw xw
    id03 = idⁿ

    id23 : NaturalTransformation zw zw
    id23 = idⁿ

    idx : NaturalTransformation x x
    idx = idⁿ

    idw : NaturalTransformation w w
    idw = idⁿ

    idyw : NaturalTransformation yw yw
    idyw = idⁿ

    idxz : NaturalTransformation xz xz
    idxz = idⁿ

    1⊗dᵣBCD : NaturalTransformation xw⊕[y⊕z]w xw⊕[yw⊕zw]
    1⊗dᵣBCD = overlapN M⊎.⊗ id03 dᵣBCD

    assocˡAD-BD-CD : NaturalTransformation xw⊕[yw⊕zw] [xw⊕yw]⊕zw
    assocˡAD-BD-CD = br⊎.α₂-over xw yw zw

    αˡABC⊗1 : NaturalTransformation [x⊕[y⊕z]]w [[x⊕y]⊕z]w
    αˡABC⊗1 = overlapN M×.⊗ (br⊎.α₂-over (select 0) (select 1) (select 2)) idw

    dᵣ[A⊕B]CD : NaturalTransformation [[x⊕y]⊕z]w [x⊕y]w⊕zw
    dᵣ[A⊕B]CD = dᵣ-over (widenʳ 2 h⊎.x⊗y) (select 2) (select 3)

    dᵣABD⊗1 : NaturalTransformation [x⊕y]w⊕zw [xw⊕yw]⊕zw
    dᵣABD⊗1 = overlapN M⊎.⊗ (dᵣ-over (select 0) (select 1) (select 3)) id23

    1A⊗dₗBCD : NaturalTransformation x[y[z⊕w]] x[yz⊕yw]
    1A⊗dₗBCD = overlapN M×.⊗ idx (dₗ-over y z w)

    dₗA[BC][BD] : NaturalTransformation x[yz⊕yw] x[yz]⊕x[yw]
    dₗA[BC][BD] = dₗ-over x yz yw

    αABC⊕αABD : NaturalTransformation x[yz]⊕x[yw] [xy]z⊕[xy]w
    αABC⊕αABD = overlapN M⊎.⊗ (br×.α₂-over x y z) (br×.α₂-over x y w)

    αAB[C⊕D] : NaturalTransformation x[y[z⊕w]] [xy][z⊕w]
    αAB[C⊕D] = br×.α₂-over x y z⊕w

    dₗ[AB]CD : NaturalTransformation [xy][z⊕w] [xy]z⊕[xy]w
    dₗ[AB]CD = dₗ-over xy z w

    dₗ0AB : NaturalTransformation 0[A⊕B] 0A⊕0B
    dₗ0AB = dₗ-over (widenʳ 2 0₀) (select 0) (select 1)

    aₗA⊕aₗB : NaturalTransformation 0A⊕0B (widenʳ 2 0⊕0)
    aₗA⊕aₗB = overlapN M⊎.⊗ (aₗ-over (select 0)) (aₗ-over (select 1))

    -- a bit weird, but the widening is needed
    uˡ0 : NaturalTransformation (widenʳ 2 0⊕0) (widenʳ 2 0₀)
    uˡ0 = uₗ⊕-over (widenʳ 2 0₀)

    aᵣA : NaturalTransformation A0 0↑
    aᵣA = aᵣ-over (select 0)

    aₗA : NaturalTransformation 0A (widenʳ 1 0₀)
    aₗA = aₗ-over (select 0)

    s⊗A0 : NaturalTransformation A0 0A
    s⊗A0 = s⊗-over (select 0) 0↑

    α0AB : NaturalTransformation 0[AB] [0A]B
    α0AB = br×.α₂-over 0₂ (select 0) (select 1)

    aₗA⊗1B : NaturalTransformation [0A]B 0B
    aₗA⊗1B = overlapN M×.⊗ (aₗ-over (select 0)) idy₂

    aₗAB : NaturalTransformation 0[AB] 0₂
    aₗAB = aₗ-over h×.x⊗y

    aₗB : NaturalTransformation 0B 0₂
    aₗB = aₗ-over y₂

    αA0B : NaturalTransformation A[0B] [A0]B
    αA0B = br×.α₂-over (select 0) 0₂ (select 1)

    aᵣA⊗1B : NaturalTransformation [A0]B 0B
    aᵣA⊗1B = overlapN M×.⊗ (aᵣ-over (select 0)) idy₂

    1A⊗aₗB : NaturalTransformation A[0B] (widenʳ 1 A0)
    1A⊗aₗB = overlapN M×.⊗ idx₂ aₗB

    aᵣA₂ : NaturalTransformation (widenʳ 1 A0) 0₂
    aᵣA₂ = aᵣ-over (select 0)

    1A⊗uₗB : NaturalTransformation A[0⊕B] AB
    1A⊗uₗB = overlapN M×.⊗ idx₂ (uₗ⊕-over y₂)

    dₗA0B : NaturalTransformation A[0⊕B] A0⊕AB
    dₗA0B = dₗ-over x₂ 0₂ y₂

    aᵣA⊕1AB : NaturalTransformation A0⊕AB 0⊕AB
    aᵣA⊕1AB = overlapN M⊎.⊗ (aᵣ-over x₂) idxy

    uₗAB : NaturalTransformation 0⊕AB AB
    uₗAB = uₗ⊕-over AB

    dₗ1AB : NaturalTransformation 1[A⊕B] 1A⊕1B
    dₗ1AB = dₗ-over 1₂ x₂ y₂

    uₗA⊕B : NaturalTransformation 1[A⊕B] A⊕B
    uₗA⊕B = uₗ⊗-over h⊎.x⊗y

    uₗA⊕uₗB : NaturalTransformation 1A⊕1B A⊕B
    uₗA⊕uₗB = overlapN M⊎.⊗ (uₗ⊗-over x₂) (uₗ⊗-over y₂)

    -- the monster, aka diagram IX
    dₗ[A⊕B]CD : NaturalTransformation [x⊕y][z⊕w] [x⊕y]z⊕[x⊕y]w
    dₗ[A⊕B]CD = dₗ-over x⊕y z w

    dᵣABC⊕dᵣABD : NaturalTransformation [x⊕y]z⊕[x⊕y]w [xz⊕yz]⊕[xw⊕yw]
    dᵣABC⊕dᵣABD = overlapN M⊎.⊗ ( dᵣ-over x y z ) (dᵣ-over x y w)

    α[AC⊕BC][AD][BD] : NaturalTransformation [xz⊕yz]⊕[xw⊕yw] [[xz⊕yz]⊕xw]⊕yw
    α[AC⊕BC][AD][BD] = br⊎.α₂-over xz⊕yz xw yw

    dᵣAB[C⊕D] : NaturalTransformation [x⊕y][z⊕w] x[z⊕w]⊕y[z⊕w]
    dᵣAB[C⊕D] = dᵣ-over x y z⊕w

    dₗACD⊕dₗBCD : NaturalTransformation x[z⊕w]⊕y[z⊕w] [xz⊕xw]⊕[yz⊕yw]
    dₗACD⊕dₗBCD = overlapN M⊎.⊗ (dₗ-over x z w) (dₗ-over y z w)

    α[AC⊕AD][BC][BD] : NaturalTransformation [xz⊕xw]⊕[yz⊕yw] [[xz⊕xw]⊕yz]⊕yw
    α[AC⊕AD][BC][BD] = br⊎.α₂-over xz⊕xw yz yw

    α′[AC][AD][BC]⊕1BD : NaturalTransformation [[xz⊕xw]⊕yz]⊕yw [xz⊕[xw⊕yz]]⊕yw
    α′[AC][AD][BC]⊕1BD = overlapN M⊎.⊗ (br⊎.α-over xz xw yz) idyw

    [1AC⊕s[AD][BC]]⊕1BD : NaturalTransformation [xz⊕[xw⊕yz]]⊕yw [xz⊕[yz⊕xw]]⊕yw
    [1AC⊕s[AD][BC]]⊕1BD = overlapN M⊎.⊗ (overlapN M⊎.⊗ idxz (s⊕-over xw yz)) idyw

    α[AC][BC][AD]⊕1BD : NaturalTransformation [xz⊕[yz⊕xw]]⊕yw [[xz⊕yz]⊕xw]⊕yw
    α[AC][BC][AD]⊕1BD = overlapN M⊎.⊗ (br⊎.α₂-over xz yz xw) idyw

record RigCategory {o ℓ e} {C : Category o ℓ e}
  {M⊎ M× : Monoidal C} {B⊎ : Braided M⊎} (S⊎ : Symmetric B⊎)
   {B× : Braided M×} (S× : Symmetric B×) : Set (o ⊔ ℓ ⊔ e) where

  open BimonoidalHelperFunctors B⊎ B×

  field
    distribₗ : NaturalIsomorphism x⊗[y⊕z] [x⊗y]⊕[x⊗z]
    distribᵣ : NaturalIsomorphism [x⊕y]⊗z [x⊗z]⊕[y⊗z]
    annₗ : NaturalIsomorphism 0⊗x 0↑
    annᵣ : NaturalIsomorphism x⊗0 0↑

  open SRig S⊎ S× distribₗ distribᵣ annₗ annᵣ

  -- need II, IX, X, XV
  -- choose I, IV, VI, XI, XIII, XIX, XXIII and (XVI, XVII)
  field
    .laplazaI : dₗACB ∘₁ 1⊗Byz ≡ⁿ B[x⊗y][x⊗z] ∘₁ dₗABC
    .laplazaII : Bxz⊕Byz ∘₁ dᵣABC ≡ⁿ dₗCAB ∘₁ B[x⊕y]z
    .laplazaIV : dᵣABD⊗1 ∘₁ (dᵣ[A⊕B]CD ∘₁ αˡABC⊗1) ≡ⁿ assocˡAD-BD-CD ∘₁ (1⊗dᵣBCD ∘₁ dᵣA[B⊕C]D)
    .laplazaVI : dₗ[AB]CD ∘₁ αAB[C⊕D] ≡ⁿ αABC⊕αABD ∘₁ (dₗA[BC][BD] ∘₁ 1A⊗dₗBCD)
    .laplazaIX : α[AC⊕BC][AD][BD] ∘₁ (dᵣABC⊕dᵣABD ∘₁ dₗ[A⊕B]CD) ≡ⁿ
        α[AC][BC][AD]⊕1BD ∘₁ ([1AC⊕s[AD][BC]]⊕1BD ∘₁ (α′[AC][AD][BC]⊕1BD ∘₁
           (α[AC⊕AD][BC][BD] ∘₁ (dₗACD⊕dₗBCD ∘₁ dᵣAB[C⊕D]))))
    .laplazaX : aₗ-over 0₀ ≡ⁿ aᵣ-over 0₀
    .laplazaXI : aₗ-over (h⊎.x⊗y) ≡ⁿ uˡ0 ∘₁ (aₗA⊕aₗB ∘₁ dₗ0AB)
    .laplazaXIII : uᵣ⊗-over 0₀ ≡ⁿ aₗ-over 1₀
    .laplazaXV : aᵣA ≡ⁿ aₗA ∘₁ s⊗A0
    .laplazaXVI : aₗAB ≡ⁿ aₗB ∘₁ (aₗA⊗1B ∘₁ α0AB)
    .laplazaXVII : aᵣA₂ ∘₁ 1A⊗aₗB ≡ⁿ aₗB ∘₁ (aᵣA⊗1B ∘₁ αA0B)
    .laplazaXIX : 1A⊗uₗB ≡ⁿ uₗAB ∘₁ (aᵣA⊕1AB ∘₁ dₗA0B)
    .laplazaXXIII : uₗA⊕B ≡ⁿ uₗA⊕uₗB ∘₁ dₗ1AB


------------------------------------------------------------------------
-- An alternative characterisation of the information ordering, along
-- with related results
------------------------------------------------------------------------

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

open import Prelude hiding (⊥)

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

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

open import Bijection equality-with-J using (_↔_)
open import Double-negation equality-with-J as DN
open import Equality.Path.Isomorphisms.Univalence equality-with-paths
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F 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
  as Trunc
open import Monad equality-with-J
open import Nat equality-with-J
open import Univalence-axiom equality-with-J

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

------------------------------------------------------------------------
-- An alternative characterisation of λ x y → now x ⊑ y

-- This characterisation uses a technique from the first edition of
-- the HoTT book (Theorems 11.3.16 and 11.3.32).
--
-- The characterisation was developed together with Paolo Capriotti.

-- A binary relation, defined using structural recursion.

private

  now[_]≲-args : A → Arguments-nd (lsuc a) a A
  now[ x ]≲-args = record
    { P  = Proposition a
    ; Q  = λ P Q → proj₁ P → proj₁ Q
    ; pe = Prelude.⊥ , ⊥-propositional
    ; po = λ y → ∥ x ≡ y ∥ , truncation-is-proposition
    ; pl = λ { s (now-x≲s[_] , _) → ∥ ∃ (λ n → proj₁ (now-x≲s[ n ])) ∥
                                  , truncation-is-proposition
             }
    ; pa = λ now-x≲y now-x≲z now-x≲y→now-x≲z now-x≲z→now-x≲y →
                                            $⟨ record { to = now-x≲y→now-x≲z; from = now-x≲z→now-x≲y } ⟩
             proj₁ now-x≲y ⇔ proj₁ now-x≲z  ↝⟨ _↔_.to (⇔↔≡″ ext prop-ext) ⟩□
             now-x≲y ≡ now-x≲z              □
    ; ps = ps
    ; qr = λ { _ (now-x≲y , _) →
               now-x≲y  ↝⟨ id ⟩□
               now-x≲y  □
             }
    ; qt = λ { _ _ (P , _) (Q , _) (R , _) P→Q Q→R →
               P  ↝⟨ P→Q ⟩
               Q  ↝⟨ Q→R ⟩□
               R  □
             }
    ; qe = λ { _ (now-x≲⊥ , _) →
               Prelude.⊥  ↝⟨ ⊥-elim ⟩□
               now-x≲⊥    □
             }
    ; qu = λ { s (now-x≲s[_] , _) n →
               proj₁ now-x≲s[ n ]                ↝⟨ ∣_∣ ∘ (n ,_) ⟩□
               ∥ ∃ (λ n → proj₁ now-x≲s[ n ]) ∥  □
             }
    ; ql = λ { s ub is-ub (now-x≲s[_] , _) now-x≲ub now-x≲s[]→now-x≲ub →
               ∥ ∃ (λ n → proj₁ now-x≲s[ n ]) ∥  ↝⟨ Trunc.rec (proj₂ now-x≲ub) (uncurry now-x≲s[]→now-x≲ub) ⟩□
               proj₁ now-x≲ub                    □
             }
    ; qp = λ _ now-x≲z → Π-closure ext 1 λ _ →
                         proj₂ now-x≲z
    }
    where
    abstract
      ps : Is-set (Proposition a)
      ps = Is-set-∃-Is-proposition ext prop-ext

infix 4 now[_]≲_

now[_]≲_ : A → A ⊥ → Type a
now[ x ]≲ y = proj₁ (⊥-rec-nd now[ x ]≲-args y)

-- The relation is propositional.

now[]≲-propositional : ∀ {x y} → Is-proposition (now[ x ]≲ y)
now[]≲-propositional = proj₂ (⊥-rec-nd now[ _ ]≲-args _)

-- If a computation terminates with a certain value, then all larger
-- computations terminate with the same value (according to now[_]≲_).

larger-terminate-with-same-value≲ :
  ∀ {x y} → x ⊑ y → ∀ {z} → now[ z ]≲ x → now[ z ]≲ y
larger-terminate-with-same-value≲ x⊑y =
  ⊑-rec-nd now[ _ ]≲-args x⊑y

-- "Evaluation" lemmas for now[_]≲_.

now[]≲never : ∀ {x} → (now[ x ]≲ never) ≡ Prelude.⊥
now[]≲never {x} =
  now[ x ]≲ never  ≡⟨ cong proj₁ (⊥-rec-nd-never now[ x ]≲-args) ⟩∎
  Prelude.⊥        ∎

now[]≲now : ∀ {x y} → (now[ x ]≲ now y) ≡ ∥ x ≡ y ∥
now[]≲now {x} {y} =
  now[ x ]≲ now y  ≡⟨ cong proj₁ (⊥-rec-nd-now now[ x ]≲-args y) ⟩∎
  ∥ x ≡ y ∥        ∎

now[]≲⨆ : ∀ {x s} → (now[ x ]≲ ⨆ s) ≡ ∥ (∃ λ n → now[ x ]≲ s [ n ]) ∥
now[]≲⨆ {x} {s} =
  now[ x ]≲ ⨆ s                    ≡⟨ cong proj₁ (⊥-rec-nd-⨆ now[ x ]≲-args s) ⟩∎
  ∥ (∃ λ n → now[ x ]≲ s [ n ]) ∥  ∎

-- now[_]≲_ is pointwise equivalent to λ x y → now x ⊑ y.

now⊑≃now[]≲ : ∀ {x y} → (now x ⊑ y) ≃ (now[ x ]≲ y)
now⊑≃now[]≲ {x} {y} =
  _↔_.to (Eq.⇔↔≃ ext ⊑-propositional now[]≲-propositional)
    (record { to   = now x ⊑ y                                ↝⟨ larger-terminate-with-same-value≲ ⟩
                     (∀ {z} → now[ z ]≲ now x → now[ z ]≲ y)  ↝⟨ (λ hyp {_} eq → hyp (≡⇒→ (sym now[]≲now) eq)) ⟩
                     (∀ {z} → ∥ z ≡ x ∥ → now[ z ]≲ y)        ↝⟨ (λ hyp → hyp ∣ refl ∣) ⟩□
                     now[ x ]≲ y                              □
            ; from = ⊥-rec-⊥ from-args _
            })
  where
  from-args : Arguments-⊥ a A
  from-args = record
    { P  = λ y → now[ x ]≲ y → now x ⊑ y
    ; pe = now[ x ]≲ never  ↝⟨ ≡⇒↝ _ now[]≲never ⟩
           Prelude.⊥        ↝⟨ ⊥-elim ⟩□
           now x ⊑ never    □
    ; po = λ y →
             now[ x ]≲ now y  ↝⟨ ≡⇒↝ _ now[]≲now ⟩

             ∥ x ≡ y ∥        ↝⟨ Trunc.rec ⊑-propositional (

               x ≡ y               ↝⟨ cong now ⟩
               now x ≡ now y       ↝⟨ flip (subst (now x ⊑_)) (⊑-refl _) ⟩□
               now x ⊑ now y       □) ⟩□

             now x ⊑ now y    □
    ; pl = λ s now-x≲s→now-x⊑s →
             now[ x ]≲ ⨆ s                    ↝⟨ ≡⇒↝ _ now[]≲⨆ ⟩

             ∥ ∃ (λ n → now[ x ]≲ s [ n ]) ∥  ↝⟨ Trunc.rec ⊑-propositional (uncurry λ n now-x≲s[n] →

               now x                               ⊑⟨ now-x≲s→now-x⊑s n now-x≲s[n] ⟩
               s [ n ]                             ⊑⟨ upper-bound s n ⟩■
               ⨆ s                                 ■) ⟩□

             now x ⊑ ⨆ s                      □
    ; pp = λ _ → Π-closure ext 1 λ _ →
                 ⊑-propositional
    }

------------------------------------------------------------------------
-- Some properties that follow from the equivalence between now[_]≲_
-- and λ x y → now x ⊑ y

-- An equivalence between "now x ⊑ never" and an empty type.
--
-- This lemma was proved together with Paolo Capriotti.

now⊑never≃⊥ : {x : A} → (now x ⊑ never) ≃ Prelude.⊥ {ℓ = a}
now⊑never≃⊥ {x} =
  now x ⊑ never    ↝⟨ now⊑≃now[]≲ ⟩
  now[ x ]≲ never  ↝⟨ ≡⇒↝ _ now[]≲never ⟩□
  Prelude.⊥        □

-- Defined values of the form now x are never smaller than or equal to
-- never.
--
-- This lemma was proved together with Paolo Capriotti.

now⋢never : (x : A) → ¬ now x ⊑ never
now⋢never x =
  now x ⊑ never  ↔⟨ now⊑never≃⊥ ⟩
  Prelude.⊥      ↝⟨ ⊥-elim ⟩□
  ⊥₀             □

-- Defined values of the form now x are never equal to never.

now≢never : (x : A) → now x ≢ never
now≢never x =
  now x ≡ never                  ↝⟨ _≃_.from equality-characterisation-⊥ ⟩
  now x ⊑ never × now x ⊒ never  ↝⟨ proj₁ ⟩
  now x ⊑ never                  ↝⟨ now⋢never x ⟩□
  ⊥₀                             □

-- There is an equivalence between "now x is smaller than or equal
-- to now y" and "x is merely equal to y".

now⊑now≃∥≡∥ : {x y : A} → (now x ⊑ now y) ≃ ∥ x ≡ y ∥
now⊑now≃∥≡∥ {x} {y} =
  now x ⊑ now y    ↝⟨ now⊑≃now[]≲ ⟩
  now[ x ]≲ now y  ↝⟨ ≡⇒↝ _ now[]≲now ⟩□
  ∥ x ≡ y ∥        □

-- There is an equivalence between "now x is equal to now y" and "x
-- is merely equal to y".

now≡now≃∥≡∥ : {x y : A} → (now x ≡ now y) ≃ ∥ x ≡ y ∥
now≡now≃∥≡∥ {x} {y} =
  now x ≡ now y                  ↝⟨ inverse equality-characterisation-⊥ ⟩
  now x ⊑ now y × now x ⊒ now y  ↝⟨ now⊑now≃∥≡∥ ×-cong now⊑now≃∥≡∥ ⟩
  ∥ x ≡ y ∥ × ∥ y ≡ x ∥          ↝⟨ _↔_.to (Eq.⇔↔≃ ext (×-closure 1 truncation-is-proposition
                                                                    truncation-is-proposition)
                                                       truncation-is-proposition)
                                           (record { to = proj₁
                                                   ; from = λ ∥x≡y∥ → ∥x≡y∥ , ∥∥-map sym ∥x≡y∥
                                                   }) ⟩□
  ∥ x ≡ y ∥                      □

-- There is an equivalence between "now x is smaller than or equal to
-- now y" and "now x is equal to now y".

now⊑now≃now≡now : {x y : A} → (now x ⊑ now y) ≃ (now x ≡ now y)
now⊑now≃now≡now {x} {y} =
  now x ⊑ now y  ↝⟨ now⊑now≃∥≡∥ ⟩
  ∥ x ≡ y ∥      ↝⟨ inverse now≡now≃∥≡∥ ⟩□
  now x ≡ now y  □

-- A computation can terminate with at most one value.

termination-value-merely-unique :
  ∀ {x y z} → x ⇓ y → x ⇓ z → ∥ y ≡ z ∥
termination-value-merely-unique {x} {y} {z} x⇓y x⇓z =
  _≃_.to now≡now≃∥≡∥ (
    now y  ≡⟨ sym x⇓y ⟩
    x      ≡⟨ x⇓z ⟩∎
    now z  ∎)

-- There is an equivalence between now x ⊑ ⨆ s and
-- ∥ ∃ (λ n → now x ⊑ s [ n ]) ∥.

now⊑⨆≃∥∃now⊑∥ :
  ∀ {s : Increasing-sequence A} {x} →
  (now x ⊑ ⨆ s) ≃ ∥ ∃ (λ n → now x ⊑ s [ n ]) ∥
now⊑⨆≃∥∃now⊑∥ {s} {x} =
  now x ⊑ ⨆ s                      ↝⟨ now⊑≃now[]≲ ⟩
  now[ x ]≲ ⨆ s                    ↝⟨ ≡⇒↝ _ now[]≲⨆ ⟩
  ∥ (∃ λ n → now[ x ]≲ s [ n ]) ∥  ↝⟨ ∥∥-cong (∃-cong λ _ → inverse now⊑≃now[]≲) ⟩□
  ∥ (∃ λ n → now x ⊑ s [ n ]) ∥    □

-- If x is larger than or equal to now y, then x is equal to now y.

now⊑→⇓ : ∀ {x} {y : A} → now y ⊑ x → x ⇓ y
now⊑→⇓ {x} {y} = ⊥-rec-⊥ (record
  { P  = λ x → now y ⊑ x → x ⇓ y
  ; pe = now y ⊑ never  ↝⟨ now⋢never y ⟩
         Prelude.⊥      ↝⟨ ⊥-elim ⟩□
         never ≡ now y  □
  ; po = λ x →
           now y ⊑ now x  ↔⟨ now⊑now≃∥≡∥ ⟩
           ∥ y ≡ x ∥      ↝⟨ ∥∥-map sym ⟩
           ∥ x ≡ y ∥      ↝⟨ Trunc.rec ⊥-is-set (cong now) ⟩□
           now x ≡ now y  □
  ; pl = λ s hyp →
           now y ⊑ ⨆ s                                  ↝⟨ (λ p → p , _≃_.to now⊑⨆≃∥∃now⊑∥ p) ⟩
           now y ⊑ ⨆ s × ∥ (∃ λ n → now y ⊑ s [ n ]) ∥  ↝⟨ uncurry (λ p → Trunc.rec ⊥-is-set (uncurry λ n →

               now y ⊑ s [ n ]                               ↝⟨ (λ now⊑ _ n≤m → ⊑-trans now⊑ (later-larger s n≤m)) ⟩
               (∀ m → n ≤ m → now y ⊑ s [ m ])               ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → hyp _) ⟩
               (∀ m → n ≤ m → s [ m ] ≡ now y)               ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → flip (subst (_ ⊑_)) (⊑-refl _)) ⟩
               (∀ m → n ≤ m → s [ m ] ⊑ now y)               ↝⟨ upper-bound-≤→upper-bound s ⟩
               (∀ n → s [ n ] ⊑ now y)                       ↝⟨ least-upper-bound _ _ ⟩
               ⨆ s ⊑ now y                                   ↝⟨ flip antisymmetry p ⟩□
               ⨆ s ≡ now y                                   □)) ⟩□

           ⨆ s ≡ now y                                  □
  ; pp = λ _ → Π-closure ext 1 λ _ →
               ⊥-is-set
  })
  x

-- If a computation terminates with a certain value, then all larger
-- computations terminate with the same value.
--
-- Capretta proved a similar result in "General Recursion via
-- Coinductive Types".

larger-terminate-with-same-value : {x y : A ⊥} → x ⊑ y → x ≼ y
larger-terminate-with-same-value now-x⊑y _ refl = now⊑→⇓ now-x⊑y

-- If one element in an increasing sequence terminates with a given
-- value, then this value is the sequence's least upper bound.

terminating-element-is-⨆ :
  ∀ (s : Increasing-sequence A) {n x} →
  s [ n ] ⇓ x → ⨆ s ⇓ x
terminating-element-is-⨆ s {n} {x} =
  larger-terminate-with-same-value (upper-bound s n) x

-- The relation _≼_ is contained in _⊑_.
--
-- Capretta proved a similar result in "General Recursion via
-- Coinductive Types".

≼→⊑ : {x y : A ⊥} → x ≼ y → x ⊑ y
≼→⊑ {x} {y} = ⊥-rec-⊥
  (record
     { P  = λ x → x ≼ y → x ⊑ y
     ; pe = never ≼ y  ↝⟨ (λ _ → never⊑ y) ⟩□
            never ⊑ y   □
     ; po = λ x →
              now x ≼ y              ↝⟨ (λ hyp → hyp x refl) ⟩
              y ⇓ x                  ↔⟨ inverse equality-characterisation-⊥ ⟩
              y ⊑ now x × y ⊒ now x  ↝⟨ proj₂ ⟩□
              now x ⊑ y              □
     ; pl = λ s s≼y→s⊑y →
              ⨆ s ≼ y                        ↝⟨ id ⟩
              (∀ z → ⨆ s ⇓ z → y ⇓ z)        ↝⟨ (λ hyp n z →

                s [ n ] ⇓ z                       ↝⟨ larger-terminate-with-same-value (upper-bound s n) z ⟩
                ⨆ s ⇓ z                           ↝⟨ hyp z ⟩□
                y ⇓ z                             □) ⟩

              (∀ n z → s [ n ] ⇓ z → y ⇓ z)  ↝⟨ id ⟩
              (∀ n → s [ n ] ≼ y)            ↝⟨ (λ hyp n → s≼y→s⊑y n (hyp n)) ⟩
              (∀ n → s [ n ] ⊑ y)            ↝⟨ least-upper-bound s y ⟩□
              ⨆ s ⊑ y                        □
     ; pp = λ _ →
              Π-closure ext 1 λ _ →
              ⊑-propositional
     })
  x

-- The two relations _≼_ and _⊑_ are pointwise equivalent.
--
-- Capretta proved a similar result in "General Recursion via
-- Coinductive Types".

≼≃⊑ : {x y : A ⊥} → (x ≼ y) ≃ (x ⊑ y)
≼≃⊑ = _↔_.to (Eq.⇔↔≃ ext ≼-propositional ⊑-propositional)
             (record { to   = ≼→⊑
                     ; from = larger-terminate-with-same-value
                     })

-- An alternative characterisation of _⇓_.

⇓≃now⊑ : ∀ {x} {y : A} → (x ⇓ y) ≃ (now y ⊑ x)
⇓≃now⊑ {x} {y} =
  _↔_.to (Eq.⇔↔≃ ext ⊥-is-set ⊑-propositional) (record
    { to   = x ≡ now y              ↔⟨ inverse equality-characterisation-⊥ ⟩
             x ⊑ now y × x ⊒ now y  ↝⟨ proj₂ ⟩□
             now y ⊑ x              □
    ; from = now y ⊑ x                  ↝⟨ larger-terminate-with-same-value ⟩
             (∀ z → now y ⇓ z → x ⇓ z)  ↝⟨ (λ hyp → hyp y refl) ⟩□
             x ⇓ y                      □
    })

-- Another alternative characterisation of _⇓_.

⇓≃now[]≲ : ∀ {x y} → (x ⇓ y) ≃ (now[ y ]≲ x)
⇓≃now[]≲ {x} {y} =
  x ⇓ y        ↝⟨ ⇓≃now⊑ ⟩
  now y ⊑ x    ↝⟨ now⊑≃now[]≲ ⟩□
  now[ y ]≲ x  □

-- Two corollaries of ⇓≃now[]≲.

never⇓≃⊥ : {x : A} → (never ⇓ x) ≃ Prelude.⊥ {ℓ = a}
never⇓≃⊥ {x = x} =
  never ≡ now x    ↝⟨ ⇓≃now[]≲ ⟩
  now[ x ]≲ never  ↝⟨ ≡⇒↝ _ now[]≲never ⟩□
  Prelude.⊥        □

⨆⇓≃∥∃⇓∥ :
  ∀ {s : Increasing-sequence A} {x} →
  (⨆ s ⇓ x) ≃ ∥ ∃ (λ n → s [ n ] ⇓ x) ∥
⨆⇓≃∥∃⇓∥ {s} {x} =
  ⨆ s ⇓ x                          ↝⟨ ⇓≃now[]≲ ⟩
  now[ x ]≲ ⨆ s                    ↝⟨ ≡⇒↝ _ now[]≲⨆ ⟩
  ∥ ∃ (λ n → now[ x ]≲ s [ n ]) ∥  ↝⟨ ∥∥-cong (∃-cong λ _ → inverse ⇓≃now[]≲) ⟩□
  ∥ ∃ (λ n → s [ n ] ⇓ x) ∥        □

-- If x does not terminate, then x is equal to never.

¬⇓→⇑ : {x : A ⊥} → ¬ (∃ λ y → x ⇓ y) → x ⇑
¬⇓→⇑ {x} = ⊥-rec-⊥
  (record
     { P  = λ x → ¬ (∃ λ y → x ⇓ y) → x ⇑
     ; pe = ¬ ∃ (never ⇓_)  ↝⟨ const refl ⟩□
            never ⇑         □
     ; po = λ x →
              ¬ ∃ (now x ⇓_) ↝⟨ _$ (x , refl) ⟩
              ⊥₀             ↝⟨ ⊥-elim ⟩□
              now x ⇑        □
     ; pl = λ s ih →
              ¬ ∃ (⨆ s ⇓_)                           ↔⟨ →-cong ext (∃-cong (λ _ → ⨆⇓≃∥∃⇓∥)) F.id ⟩
              ¬ ∃ (λ x → ∥ ∃ (λ n → s [ n ] ⇓ x) ∥)  ↝⟨ (λ { hyp (n , x , s[n]⇓x) → hyp (x , ∣ n , s[n]⇓x ∣) }) ⟩
              ¬ ∃ (λ n → ∃ λ x → s [ n ] ⇓ x)        ↝⟨ (λ hyp n → ih n (hyp ∘ (n ,_))) ⟩
              (∀ n → s [ n ] ⇑)                      ↝⟨ sym ∘ _↔_.to equality-characterisation-increasing ⟩
              constˢ never ≡ s                       ↝⟨ flip (subst (λ s → ⨆ s ⇑)) ⨆-const ⟩□
              ⨆ s ⇑                                  □
     ; pp = λ _ → Π-closure ext 1 λ _ →
                  ⊥-is-set
     })
  x

-- In the double-negation monad a computation is either terminating or
-- non-terminating.

now-or-never : (x : A ⊥) → ¬ ¬ ((∃ λ y → x ⇓ y) ⊎ x ⇑)
now-or-never x = run (map (⊎-map id ¬⇓→⇑) excluded-middle)

-- _⊑_ is a flat order, in the sense that distinct elements that are
-- distinct from never are unrelated.

flat-order : {x y : A ⊥} → x ≢ y → ¬ x ⇑ → ¬ y ⇑ → ¬ (x ⊑ y)
flat-order {x} {y} x≢y never≢x never≢y x⊑y = ¬¬¬⊥ $
  ¬⇑→¬¬⇓ never≢x >>= λ x⇓ →
  ¬⇑→¬¬⇓ never≢y >>= λ y⇓ →
  return (⊥-elim $ ¬x⇓×y⇓ (x⇓ , y⇓))
  where
  -- The computations x and y cannot both terminate.

  ¬x⇓×y⇓ : ¬ ((∃ λ z → x ⇓ z) × (∃ λ z → y ⇓ z))
  ¬x⇓×y⇓ ((xz , refl) , (yz , refl)) = x≢y (
    now xz      ≡⟨ _≃_.to now⊑now≃now≡now (

        now xz       ⊑⟨ x⊑y ⟩■
        now yz       ■) ⟩∎

    now yz      ∎)

  -- Computations that fail to be equal to never do not fail to
  -- terminate.

  ¬⇑→¬¬⇓ : {x : A ⊥} → ¬ x ⇑ → ¬¬ (∃ λ y → x ⇓ y)
  run (¬⇑→¬¬⇓ ¬x⇑) = ¬x⇑ ∘ ¬⇓→⇑

-- Some "constructors" for □.

□-never :
  ∀ {ℓ} {P : A → Type ℓ} →
  □ P never
□-never {P = P} y =
  never ⇓ y        ↔⟨ ⇓≃now[]≲ ⟩
  now[ y ]≲ never  ↔⟨ ≡⇒↝ bijection now[]≲never ⟩
  Prelude.⊥        ↝⟨ ⊥-elim ⟩□
  P y              □

□-now :
  ∀ {ℓ} {P : A → Type ℓ} {x} →
  Is-proposition (P x) →
  P x → □ P (now x)
□-now {P = P} {x} P-prop p y =
  now x ⇓ y  ↔⟨ now≡now≃∥≡∥ ⟩
  ∥ x ≡ y ∥  ↝⟨ (λ ∥x≡y∥ →
                   Trunc.rec (Trunc.rec (H-level-propositional ext 1)
                                        (λ x≡y → subst (Is-proposition ∘ P) x≡y P-prop)
                                        ∥x≡y∥)
                             (λ x≡y → subst P x≡y p)
                             ∥x≡y∥) ⟩□
  P y        □

□-⨆ :
  ∀ {ℓ} {P : A → Type ℓ} →
  (∀ x → Is-proposition (P x)) →
  ∀ {s} → (∀ n → □ P (s [ n ])) → □ P (⨆ s)
□-⨆ {P = P} P-prop {s} p y =
  ⨆ s ⇓ y                    ↔⟨ ⨆⇓≃∥∃⇓∥ ⟩
  ∥ ∃ (λ n → s [ n ] ⇓ y) ∥  ↝⟨ Trunc.rec (P-prop y) (uncurry λ n s[n]⇓y → p n y s[n]⇓y) ⟩□
  P y                        □

-- One "non-constructor" and one "constructor" for ◇.

◇-never :
  ∀ {ℓ} {P : A → Type ℓ} →
  ¬ ◇ P never
◇-never {P = P} =
  ◇ P never                      ↝⟨ id ⟩
  ∥ (∃ λ y → never ⇓ y × P y) ∥  ↝⟨ Trunc.rec ⊥-propositional (now≢never _ ∘ sym ∘ proj₁ ∘ proj₂) ⟩□
  ⊥₀                             □

◇-⨆ :
  ∀ {ℓ} {P : A → Type ℓ} →
  ∀ {s n} → ◇ P (s [ n ]) → ◇ P (⨆ s)
◇-⨆ {P = P} =
  ∥∥-map (Σ-map id (λ {x} → Σ-map {Q = λ _ → P x}
                                  (terminating-element-is-⨆ _) id))

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

-- This characterisation uses a technique from the first edition of
-- the HoTT book (Theorems 11.3.16 and 11.3.32).
--
-- The characterisation was developed together with Paolo Capriotti.

-- A binary relation, defined using structural recursion.

private

  ≲-args : Arguments-nd (lsuc a) a A
  ≲-args = record
    { P  = A ⊥ → Proposition a
    ; Q  = λ P Q → ∀ z → proj₁ (Q z) → proj₁ (P z)
    ; pe = λ _ → ↑ _ ⊤ , ↑-closure 1 (mono₁ 0 ⊤-contractible)
    ; po = λ x y → ⊥-rec-nd now[ x ]≲-args y
    ; pl = λ { _ (s[_]≲ , _) y → (∀ n → proj₁ (s[ n ]≲ y))
                               , Π-closure ext 1 λ n →
                                 proj₂ (s[ n ]≲ y)
             }
    ; pa = λ x≲ y≲ y≲→x≲ x≲→y≲ → ⟨ext⟩ λ z →
                                          $⟨ record { to = x≲→y≲ z; from = y≲→x≲ z } ⟩
             proj₁ (x≲ z) ⇔ proj₁ (y≲ z)  ↝⟨ _↔_.to (⇔↔≡″ ext prop-ext) ⟩□
             x≲ z ≡ y≲ z                  □
    ; ps = ps
    ; qr = λ _ x≲ z →
             proj₁ (x≲ z)  ↝⟨ id ⟩□
             proj₁ (x≲ z)  □
    ; qt = λ _ _ P Q R Q→P R→Q z →
             proj₁ (R z)  ↝⟨ R→Q z ⟩
             proj₁ (Q z)  ↝⟨ Q→P z ⟩□
             proj₁ (P z)  □
    ; qe = λ _ ⊥≲ z →
             proj₁ (⊥≲ z)  ↝⟨ _ ⟩□
             ↑ _ ⊤         □
    ; qu = λ { s (s[_]≲ , _) n z →
               (∀ m → proj₁ (s[ m ]≲ z))  ↝⟨ (_$ n) ⟩□
               proj₁ (s[ n ]≲ z)          □
             }
    ; ql = λ { _ _ _ (s[_]≲ , _) ub≲ ub≲→s[]≲ z →
               proj₁ (ub≲ z)              ↝⟨ flip (flip ub≲→s[]≲ z) ⟩□
               (∀ n → proj₁ (s[ n ]≲ z))  □
             }
    ; qp = λ x≲ y≲ → Π-closure ext 1 λ z →
                     Π-closure ext 1 λ _ →
                     proj₂ (x≲ z)
    }
    where
    abstract
      ps : Is-set (A ⊥ → Proposition a)
      ps =
        Π-closure ext 2 λ _ →
        Is-set-∃-Is-proposition ext prop-ext

infix 4 _≲_

_≲_ : A ⊥ → A ⊥ → Type a
x ≲ y = proj₁ (⊥-rec-nd ≲-args x y)

-- The relation is propositional.

≲-propositional : ∀ x y → Is-proposition (x ≲ y)
≲-propositional x y = proj₂ (⊥-rec-nd ≲-args x y)

-- A form of transitivity involving _⊑_ and _≲_.

⊑≲-trans : ∀ {x y} (z : A ⊥) → x ⊑ y → y ≲ z → x ≲ z
⊑≲-trans z x⊑y = ⊑-rec-nd ≲-args x⊑y z

-- "Evaluation" lemmas for _≲_.

never≲ : ∀ {y} → (never ≲ y) ≡ ↑ _ ⊤
never≲ {y} = cong (proj₁ ∘ (_$ _)) (
  ⊥-rec-nd ≲-args never  ≡⟨ ⊥-rec-nd-never ≲-args ⟩∎
  (λ _ → ↑ _ ⊤ , _)      ∎)

⨆≲ : ∀ {s y} → (⨆ s ≲ y) ≡ ∀ n → s [ n ] ≲ y
⨆≲ {s} {y} = cong (proj₁ ∘ (_$ _)) (
  ⊥-rec-nd ≲-args (⨆ s)            ≡⟨ ⊥-rec-nd-⨆ ≲-args s ⟩∎
  (λ y → (∀ n → s [ n ] ≲ y) , _)  ∎)

now≲ : ∀ {x y} → (now x ≲ y) ≡ (now[ x ]≲ y)
now≲ {x} {y} =
  now x ≲ y    ≡⟨ cong (proj₁ ∘ (_$ _)) (⊥-rec-nd-now ≲-args x) ⟩∎
  now[ x ]≲ y  ∎

now≲never : ∀ {x} → (now x ≲ never) ≡ Prelude.⊥
now≲never {x} =
  now x ≲ never    ≡⟨ now≲ ⟩
  now[ x ]≲ never  ≡⟨ now[]≲never ⟩∎
  Prelude.⊥        ∎

now≲now : ∀ {x y} → (now x ≲ now y) ≡ ∥ x ≡ y ∥
now≲now {x} {y} =
  now x ≲ now y    ≡⟨ now≲ ⟩
  now[ x ]≲ now y  ≡⟨ now[]≲now ⟩∎
  ∥ x ≡ y ∥        ∎

now≲⨆ : ∀ {x s} → (now x ≲ ⨆ s) ≡ ∥ (∃ λ n → now x ≲ s [ n ]) ∥
now≲⨆ {x} {s} =
  now x ≲ ⨆ s                      ≡⟨ now≲ ⟩
  now[ x ]≲ ⨆ s                    ≡⟨ now[]≲⨆ ⟩
  ∥ (∃ λ n → now[ x ]≲ s [ n ]) ∥  ≡⟨ cong (λ P → ∥ ∃ P ∥) (⟨ext⟩ λ _ → sym now≲) ⟩∎
  ∥ (∃ λ n → now x ≲ s [ n ]) ∥    ∎

-- _≲_ is reflexive.

≲-refl : ∀ x → x ≲ x
≲-refl = ⊥-rec-⊥ (record
  { pe =                $⟨ _ ⟩
         ↑ _ ⊤          ↝⟨ ≡⇒↝ bijection $ sym never≲ ⟩□
         never ≲ never  □
  ; po = λ x →            $⟨ ∣ refl ∣ ⟩
           ∥ x ≡ x ∥      ↝⟨ ≡⇒↝ bijection $ sym now≲now ⟩□
           now x ≲ now x  □
  ; pl = λ s →
           (∀ n → s [ n ] ≲ s [ n ])  ↝⟨ (λ s≲s n → ⨆-lemma s (s [ n ]) n (s≲s n)) ⟩
           (∀ n → s [ n ] ≲ ⨆ s)      ↔⟨ ≡⇒↝ bijection $ sym ⨆≲ ⟩□
           ⨆ s ≲ ⨆ s                  □
  ; pp = λ x → ≲-propositional x x
  })
  where
  ⨆-lemma : ∀ s x n → x ≲ s [ n ] → x ≲ ⨆ s
  ⨆-lemma s = ⊥-rec-⊥
    (record
       { P  = λ x → ∀ n → x ≲ s [ n ] → x ≲ ⨆ s
       ; pe = λ n →
                never ≲ s [ n ]  ↔⟨ ≡⇒↝ bijection $ never≲ ⟩
                ↑ _ ⊤            ↔⟨ ≡⇒↝ bijection $ sym never≲ ⟩□
                never ≲ ⨆ s      □
       ; po = λ x n →
                now x ≲ s [ n ]                ↝⟨ ∣_∣ ∘ (n ,_) ⟩
                ∥ (∃ λ n → now x ≲ s [ n ]) ∥  ↔⟨ ≡⇒↝ bijection $ sym now≲⨆ ⟩□
                now x ≲ ⨆ s                    □
       ; pl = λ s′ →
                (∀ m n → s′ [ m ] ≲ s [ n ] → s′ [ m ] ≲ ⨆ s)  ↝⟨ (λ hyp n s′≲s m → hyp m n (s′≲s m)) ⟩

                (∀ n → (∀ m → s′ [ m ] ≲ s [ n ]) →
                       (∀ m → s′ [ m ] ≲ ⨆ s))                 ↝⟨ ∀-cong _ (λ _ →
                                                                    ≡⇒↝ _ $ sym $ cong₂ (λ x y → x → y) ⨆≲ ⨆≲) ⟩□
                (∀ n → ⨆ s′ ≲ s [ n ] → ⨆ s′ ≲ ⨆ s)            □
       ; pp = λ x → Π-closure ext 1 λ _ →
                    Π-closure ext 1 λ _ →
                    ≲-propositional x (⨆ s)
       })

-- _⊑_ and _≲_ are pointwise equivalent.

⊑≃≲ : ∀ {x y} → (x ⊑ y) ≃ (x ≲ y)
⊑≃≲ {x} {y} =
  _↔_.to (Eq.⇔↔≃ ext ⊑-propositional (≲-propositional x y))
    (record { to   = λ x⊑y → ⊑≲-trans _ x⊑y (≲-refl y)
            ; from = ⊥-rec-⊥ from-args _ _
            })
  where
  from-args : Arguments-⊥ a A
  from-args = record
    { P  = λ x → ∀ y → x ≲ y → x ⊑ y
    ; pe = λ y _ → never⊑ y
    ; po = λ x y →
             now x ≲ y    ↝⟨ ≡⇒↝ _ now≲ ⟩
             now[ x ]≲ y  ↔⟨ inverse now⊑≃now[]≲ ⟩□
             now x ⊑ y    □
    ; pl = λ s s≲→s⊑ y →
             ⨆ s ≲ y              ↝⟨ ≡⇒↝ _ ⨆≲ ⟩
             (∀ n → s [ n ] ≲ y)  ↝⟨ (λ s[_]≲y n → s≲→s⊑ n y s[ n ]≲y) ⟩
             (∀ n → s [ n ] ⊑ y)  ↝⟨ least-upper-bound s y ⟩□
             ⨆ s ⊑ y              □
    ; pp = λ _ → Π-closure ext 1 λ _ →
                 Π-closure ext 1 λ _ →
                 ⊑-propositional
    }


module Data.Tree where

open import Data.Tree.Base public


-- Mapping of Haskell types to Agda Types
module Foreign.Haskell.Types where

open import Prelude
open import Builtin.Float

{-# FOREIGN GHC import qualified GHC.Float #-}
{-# FOREIGN GHC import qualified Data.Text #-}

HSUnit = ⊤
HSBool = Bool
HSInteger = Int

HSList = List

HSChar = Char
HSString = HSList HSChar
HSText = String

postulate
  HSFloat : Set
  HSFloat=>Float : HSFloat → Float
  lossyFloat=>HSFloat : Float → HSFloat

  HSInt : Set
  HSInt=>Int : HSInt → Int
  lossyInt=>HSInt : Int → HSInt

{-# COMPILE GHC HSFloat = type Float #-}
{-# COMPILE GHC HSFloat=>Float = GHC.Float.float2Double #-}
{-# COMPILE GHC lossyFloat=>HSFloat = GHC.Float.double2Float #-}
{-# COMPILE GHC HSInt = type Int #-}
{-# COMPILE GHC HSInt=>Int = toInteger #-}
{-# COMPILE GHC lossyInt=>HSInt = fromInteger #-}

{-# FOREIGN GHC type AgdaTuple a b c d = (c, d) #-}

data HSTuple {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  _,_ : A → B → HSTuple A B
{-# COMPILE GHC HSTuple = data MAlonzo.Code.Foreign.Haskell.Types.AgdaTuple ((,)) #-}


-- Andreas, 2010-09-24

module ParseForallAbsurd where

parseFails : forall () -> Set1
parseFails x = Set
-- this does no longer give the error message
-- "absurd lambda cannot have a body"


module Issue217 where

record A : Set where
  ⊥ : Set
  ⊥ = ⊥


open import Nat
open import Prelude
open import List

open import contexts
open import core

module completeness where
  -- any hole is new to a complete expression
  e-complete-hnn : ∀{e u} → e ecomplete → hole-name-new e u
  e-complete-hnn (ECFix cmp) = HNNFix (e-complete-hnn cmp)
  e-complete-hnn ECVar = HNNVar
  e-complete-hnn (ECAp cmp1 cmp2) = HNNAp (e-complete-hnn cmp1) (e-complete-hnn cmp2)
  e-complete-hnn ECUnit = HNNUnit
  e-complete-hnn (ECPair cmp cmp₁) = HNNPair (e-complete-hnn cmp) (e-complete-hnn cmp₁)
  e-complete-hnn (ECFst cmp) = HNNFst (e-complete-hnn cmp)
  e-complete-hnn (ECSnd cmp) = HNNSnd (e-complete-hnn cmp)
  e-complete-hnn (ECCtor cmp) = HNNCtor (e-complete-hnn cmp)
  e-complete-hnn (ECCase cmp h) = HNNCase (e-complete-hnn cmp) λ i<∥rules∥ → e-complete-hnn (h i<∥rules∥)
  e-complete-hnn (ECAsrt cmp1 cmp2) = HNNAsrt (e-complete-hnn cmp1) (e-complete-hnn cmp2)

  {- TODO : probably delete
  e-hnn-complete : ∀{e} → (∀{u} → hole-name-new e u) → e ecomplete
  e-hnn-complete hnn∀ = {!!}
  -}

  -- a complete expression is holes-disjoint to all expressions
  e-complete-disjoint : ∀{e1 e2} → e1 ecomplete → holes-disjoint e1 e2
  e-complete-disjoint (ECFix cmp) = HDFix (e-complete-disjoint cmp)
  e-complete-disjoint ECVar = HDVar
  e-complete-disjoint (ECAp cmp1 cmp2) = HDAp (e-complete-disjoint cmp1) (e-complete-disjoint cmp2)
  e-complete-disjoint ECUnit = HDUnit
  e-complete-disjoint (ECPair cmp cmp₁) = HDPair (e-complete-disjoint cmp) (e-complete-disjoint cmp₁)
  e-complete-disjoint (ECFst cmp) = HDFst (e-complete-disjoint cmp)
  e-complete-disjoint (ECSnd cmp) = HDSnd (e-complete-disjoint cmp)
  e-complete-disjoint (ECCtor cmp) = HDCtor (e-complete-disjoint cmp)
  e-complete-disjoint (ECCase cmp h) = HDCase (e-complete-disjoint cmp) λ i<∥rules∥ → e-complete-disjoint (h i<∥rules∥)
  e-complete-disjoint (ECAsrt cmp1 cmp2) = HDAsrt (e-complete-disjoint cmp1) (e-complete-disjoint cmp2)

  -- TODO a holes-disjoint-sym check - very involved but arguably pretty important

  -- TODO we should generalize this, to a theorem that says that if a hole name is new in
  -- e, then it is new in r and k
  {- TODO}
  -- if e evals to r, and e is complete, then r is complete
  eval-completeness : ∀{Δ Σ' Γ E e r τ k} →
                        E env-complete →
                        Δ , Σ' , Γ ⊢ E →
                        Δ , Σ' , Γ ⊢ e :: τ →
                        E ⊢ e ⇒ r ⊣ k →
                        e ecomplete →
                        r rcomplete
  eval-completeness Ecmp Γ⊢E (TALam _ _) EFun (ECLam ecmp) = RCLam Ecmp ecmp
  eval-completeness Ecmp Γ⊢E (TAFix _ _ _) EFix (ECFix ecmp) = RCFix Ecmp ecmp
  eval-completeness (ENVC Ecmp) Γ⊢E (TAVar _) (EVar h) ECVar = Ecmp h
  eval-completeness Ecmp Γ⊢E (TAApp _ ta-f ta-arg) (EApp {Ef = Ef} {x} {r2 = r2} CF∞ eval-f eval-arg eval-ef) (ECAp cmp-f cmp-arg)
    with eval-completeness Ecmp Γ⊢E ta-f eval-f cmp-f | preservation Γ⊢E ta-f eval-f
  ... | RCLam (ENVC Efcmp) efcmp | TALam Γ'⊢Ef (TALam _ ta-ef)
    = eval-completeness (ENVC env-cmp) (EnvInd Γ'⊢Ef (preservation Γ⊢E ta-arg eval-arg)) ta-ef eval-ef efcmp
      where
        env-cmp : ∀{x' rx'} → (x' , rx') ∈ (Ef ,, (x , r2)) → rx' rcomplete
        env-cmp {x'} {rx'} h with ctx-split {Γ = Ef} h
        env-cmp {x'} {rx'} h | Inl (_ , x'∈Ef) = Efcmp x'∈Ef
        env-cmp {x'} {rx'} h | Inr (_ , rx'==r2) rewrite rx'==r2 =
          eval-completeness Ecmp Γ⊢E ta-arg eval-arg cmp-arg
  eval-completeness Ecmp Γ⊢E (TAApp _ ta-f ta-arg) (EAppFix {Ef = Ef} {f} {x} {ef} {r2 = r2} CF∞ h eval-f eval-arg eval-ef) (ECAp cmp-f cmp-arg)
    rewrite h with eval-completeness Ecmp Γ⊢E ta-f eval-f cmp-f | preservation Γ⊢E ta-f eval-f
  ... | RCFix (ENVC Efcmp) efcmp | TAFix Γ'⊢Ef (TAFix _ _ ta-ef) =
    eval-completeness (ENVC new-Ef+-cmp) new-ctxcons ta-ef eval-ef efcmp
    where
      new-ctxcons =
        EnvInd (EnvInd Γ'⊢Ef (preservation Γ⊢E ta-f eval-f)) (preservation Γ⊢E ta-arg eval-arg)
      new-Ef-cmp  : ∀{x' rx'} → (x' , rx') ∈ (Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈)) → rx' rcomplete
      new-Ef-cmp  {x'} {rx'} h with ctx-split {Γ = Ef} h
      new-Ef-cmp  {x'} {rx'} h | Inl (_ , x'∈Ef) = Efcmp x'∈Ef
      new-Ef-cmp  {x'} {rx'} h | Inr (_ , rx'==r2) rewrite rx'==r2 = RCFix (ENVC Efcmp) efcmp
      new-Ef+-cmp : ∀{x' rx'} → (x' , rx') ∈ (Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈) ,, (x , r2)) → rx' rcomplete
      new-Ef+-cmp {x'} {rx'} h with ctx-split {Γ = Ef ,, (f , [ Ef ]fix f ⦇·λ x => ef ·⦈)} h
      new-Ef+-cmp {x'} {rx'} h | Inl (_ , x'∈Ef+) = new-Ef-cmp x'∈Ef+
      new-Ef+-cmp {x'} {rx'} h | Inr (_ , rx'==r2) rewrite rx'==r2 =
        eval-completeness Ecmp Γ⊢E ta-arg eval-arg cmp-arg
  eval-completeness Ecmp Γ⊢E (TAApp _ ta1 ta2) (EAppUnfinished eval1 _ _ eval2) (ECAp ecmp1 ecmp2) =
    RCAp (eval-completeness Ecmp Γ⊢E ta1 eval1 ecmp1) (eval-completeness Ecmp Γ⊢E ta2 eval2 ecmp2)
  eval-completeness Ecmp Γ⊢E (TATpl ∥es∥==∥τs∥ _ tas) (ETuple ∥es∥==∥rs∥ ∥es∥==∥ks∥ evals) (ECTpl cmps) =
    RCTpl λ {i} rs[i] →
      let
        _ , es[i] = ∥l1∥==∥l2∥→l1[i]→l2[i] (! ∥es∥==∥rs∥) rs[i]
        _ , ks[i] = ∥l1∥==∥l2∥→l1[i]→l2[i] ∥es∥==∥ks∥ es[i]
        _ , τs[i] = ∥l1∥==∥l2∥→l1[i]→l2[i] ∥es∥==∥τs∥ es[i]
      in
      eval-completeness Ecmp Γ⊢E (tas es[i] τs[i]) (evals es[i] rs[i] ks[i]) (cmps es[i])
  eval-completeness Ecmp Γ⊢E (TAGet ∥rs⊫=∥τs∥ i<∥τs∥ ta) (EGet _ i<∥rs∥ eval) (ECGet ecmp)
    with eval-completeness Ecmp Γ⊢E ta eval ecmp
  ... | RCTpl h = h i<∥rs∥
  eval-completeness Ecmp Γ⊢E (TAGet _ i<∥τs∥ ta) (EGetUnfinished eval _) (ECGet ecmp) =
    RCGet (eval-completeness Ecmp Γ⊢E ta eval ecmp)
  eval-completeness Ecmp Γ⊢E (TACtor _ _ ta) (ECtor eval) (ECCtor ecmp) =
    RCCtor (eval-completeness Ecmp Γ⊢E ta eval ecmp)
  eval-completeness {Σ' = Σ'} (ENVC Ecmp) Γ⊢E (TACase d∈Σ'1 ta h1 h2) (EMatch {E = E} {xc = xc} {r' = r'} CF∞ form eval eval-ec) (ECCase ecmp rules-cmp)
    with h2 form
  ... | _ , _ , _ , _ , c∈cctx1 , ta-ec
    with preservation Γ⊢E ta eval
  ... | TACtor {cctx = cctx} d∈Σ' c∈cctx ta-r'
    rewrite ctxunicity {Γ = π1 Σ'} d∈Σ'1 d∈Σ' | ctxunicity {Γ = cctx} c∈cctx1 c∈cctx =
    eval-completeness (ENVC new-E-cmp) (EnvInd Γ⊢E ta-r') ta-ec eval-ec (rules-cmp form)
    where
      new-E-cmp : ∀{x' rx'} → (x' , rx') ∈ (E ,, (xc , r')) → rx' rcomplete
      new-E-cmp {x'} {rx'} x'∈E+ with ctx-split {Γ = E} x'∈E+
      ... | Inl (_ , x'∈E) = Ecmp x'∈E
      ... | Inr (_ , rx'==r') rewrite rx'==r'
        with eval-completeness (ENVC Ecmp) Γ⊢E ta eval ecmp
      ... | RCCtor r'cmp = r'cmp
  eval-completeness Ecmp Γ⊢E (TACase _ ta _ _) (EMatchUnfinished eval _) (ECCase ecmp rulescmp) =
    RCCase Ecmp (eval-completeness Ecmp Γ⊢E ta eval ecmp) rulescmp
  eval-completeness Ecmp Γ⊢E (TAHole _) EHole ()
  eval-completeness Ecmp Γ⊢E (TAPF _) EPF (ECPF pf-cmp) = RCPF pf-cmp
  eval-completeness Ecmp Γ⊢E (TAAsrt _ _ _) (EAsrt _ _ _) (ECAsrt _ _) = RCTpl (λ ())
  -}


------------------------------------------------------------------------
-- A terminating parser data type and the accompanying interpreter
------------------------------------------------------------------------

module RecursiveDescent.InductiveWithFix.Internal where

open import Data.Bool
open import Data.Product.Record
open import Data.Maybe
open import Data.BoundedVec.Inefficient
import Data.List as L
open import Data.Nat
open import Category.Applicative.Indexed
open import Category.Monad.Indexed
open import Category.Monad.State

open import RecursiveDescent.Index
open import Utilities

------------------------------------------------------------------------
-- Lifting non-terminals

-- Extends a non-terminal type with a fresh non-terminal.

data Lift (i : Index) (r : Set) (nt : ParserType₁) : ParserType₁ where
  fresh : Lift i r nt i r
  ↟     : forall {i' r'} -> nt i' r' -> Lift i r nt i' r'

------------------------------------------------------------------------
-- Parser data type

-- A type for parsers which can be implemented using recursive
-- descent. The types used ensure that the implementation below is
-- structurally recursive.

-- The parsers are indexed on a type of nonterminals.

data Parser (tok : Set) (nt : ParserType₁) : ParserType₁ where
  !_     :  forall {e c r}
         -> nt (e , c) r -> Parser tok nt (e , step c) r
  fix    :  forall {e c r}
         -> Parser tok (Lift (e , step c) r nt) (e , c) r
         -> Parser tok nt (e , step c) r
  symbol :  Parser tok nt (false , leaf) tok
  ret    :  forall {r} -> r -> Parser tok nt (true , leaf) r
  fail   :  forall {r} -> Parser tok nt (false , leaf) r
  bind₀  :  forall {c₁ e₂ c₂ r₁ r₂}
         -> Parser tok nt (true , c₁) r₁
         -> (r₁ -> Parser tok nt (e₂ , c₂) r₂)
         -> Parser tok nt (e₂ , node c₁ c₂) r₂
  bind₁  :  forall {c₁ r₁ r₂} {i₂ : r₁ -> Index}
         -> Parser tok nt (false , c₁) r₁
         -> ((x : r₁) -> Parser tok nt (i₂ x) r₂)
         -> Parser tok nt (false , step c₁) r₂
  alt₀   :  forall {c₁ e₂ c₂ r}
         -> Parser tok nt (true , c₁)         r
         -> Parser tok nt (e₂   , c₂)         r
         -> Parser tok nt (true , node c₁ c₂) r
  alt₁   :  forall {c₁} e₂ {c₂ r}
         -> Parser tok nt (false , c₁)         r
         -> Parser tok nt (e₂    , c₂)         r
         -> Parser tok nt (e₂    , node c₁ c₂) r

------------------------------------------------------------------------
-- Lifting parsers

Map : (ParserType₁ -> ParserType₁) -> Set2
Map F = forall {nt nt' i r} ->
        (nt i r -> nt' i r) -> (F nt i r -> F nt' i r)

liftMap : forall (F : ParserType₁ -> ParserType₁) {i' r'} ->
          Map F -> Map (Lift i' r' ∘₂ F)
liftMap F map g fresh = fresh
liftMap F map g (↟ x) = ↟ (map g x)

lift' : forall {tok nt i r i' r'}
        (F : ParserType₁ -> ParserType₁) -> Map F ->
        Parser tok (F nt) i r -> Parser tok (F (Lift i' r' nt)) i r
lift' F map (! x)               ~ ! (map ↟ x)
lift' F map (fix {e} {c} {r} p) ~ fix (lift' (Lift (e , step c) r ∘₂ F)
                                             (liftMap F map) p)
lift' F map symbol              ~ symbol
lift' F map (ret x)             ~ ret x
lift' F map fail                ~ fail
lift' F map (bind₀  p₁ p₂)      ~ bind₀  (lift' F map p₁) (\x -> lift' F map (p₂ x))
lift' F map (bind₁  p₁ p₂)      ~ bind₁  (lift' F map p₁) (\x -> lift' F map (p₂ x))
lift' F map (alt₀   p₁ p₂)      ~ alt₀   (lift' F map p₁) (lift' F map p₂)
lift' F map (alt₁ e p₁ p₂)      ~ alt₁ e (lift' F map p₁) (lift' F map p₂)

-- Note that lift p is linear in the size of p (in a sense; note that
-- p can contain higher-order components), assuming that p contains at
-- most <some constant> occurrences of fix.

lift : forall {tok nt i r i' r'} ->
       Parser tok nt i r -> Parser tok (Lift i' r' nt) i r
lift p = lift' (\nt -> nt) (\f -> f) p

------------------------------------------------------------------------
-- Run function for the parsers

-- Grammars.

Grammar : Set -> ParserType₁ -> Set1
Grammar tok nt = forall {i r} -> nt i r -> Parser tok nt i r

-- Extends a grammar with a case for a fresh non-terminal.

_▷_ : forall {tok nt i r} ->
      Grammar tok nt -> Parser tok nt i r ->
      Grammar tok (Lift i r nt)
(g ▷ p) fresh = lift p
(g ▷ p) (↟ x) = lift (g x)

-- Parser monad.

P : Set -> IFun ℕ
P tok = IStateT (BoundedVec tok) L.List

PIMonadPlus : (tok : Set) -> RawIMonadPlus (P tok)
PIMonadPlus tok = StateTIMonadPlus (BoundedVec tok) L.monadPlus

PIMonadState : (tok : Set) -> RawIMonadState (BoundedVec tok) (P tok)
PIMonadState tok = StateTIMonadState (BoundedVec tok) L.monad

private
  open module LM {tok} = RawIMonadPlus  (PIMonadPlus  tok)
  open module SM {tok} = RawIMonadState (PIMonadState tok)
                           using (get; put; modify)

-- For every successful parse the run function returns the remaining
-- string. (Since there can be several successful parses a list of
-- strings is returned.)

-- This function is structurally recursive with respect to the
-- following lexicographic measure:
--
-- 1) The upper bound of the length of the input string.
-- 2) The parser's proper left corner tree.

mutual
  parse : forall {tok nt} -> Grammar tok nt ->
          forall n {e c r} ->
          Parser tok nt (e , c) r ->
          P tok n (if e then n else pred n) r
  parse g n       (! x)              = parse g n (g x)
  parse g n       (fix p)            = parse (g ▷ fix p) n p
  parse g zero    symbol             = ∅
  parse g (suc n) symbol             = eat =<< get
  parse g n       (ret x)            = return x
  parse g n       fail               = ∅
  parse g n       (bind₀      p₁ p₂) = parse  g  n      p₁ >>= parse  g n ∘′ p₂
  parse g zero    (bind₁      p₁ p₂) = ∅
  parse g (suc n) (bind₁      p₁ p₂) = parse  g (suc n) p₁ >>= parse↑ g n ∘′ p₂
  parse g n       (alt₀       p₁ p₂) = parse  g  n      p₁ ∣   parse↑ g n    p₂
  parse g n       (alt₁ true  p₁ p₂) = parse↑ g  n      p₁ ∣   parse  g n    p₂
  parse g n       (alt₁ false p₁ p₂) = parse  g  n      p₁ ∣   parse  g n    p₂

  parse↑ : forall {tok nt} -> Grammar tok nt ->
           forall n {e c r} -> Parser tok nt (e , c) r -> P tok n n r
  parse↑ g n       {true}  p = parse g n p
  parse↑ g zero    {false} p = ∅
  parse↑ g (suc n) {false} p = parse g (suc n) p >>= \r ->
                               modify ↑ >>
                               return r

  eat : forall {tok n} -> BoundedVec tok (suc n) -> P tok (suc n) n tok
  eat []      = ∅
  eat (c ∷ s) = put s >> return c