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

open import library.Basics hiding (Type ; Σ)
open import library.types.Sigma
open import library.NType2

open import Sec2preliminaries
open import Sec3hedberg
open import Sec4hasConstToSplit

module Sec5factorConst where

-- Definition 5.1
factors-through : {X Y : Type} → Type → (X → Y) → Type
factors-through {X} {Y} Z f = Σ (X → Z) λ f₁ → Σ (Z → Y) λ f₂ → (x : X) → f₂ (f₁ x) == f x

-- Definition 5.1 addendum: "factors through the truncation"
factors : {X Y : Type} → (X → Y) → Type
factors {X} = factors-through (Trunc X)

-- Principle 5.2
factor-helper : {X Y : Type} → (f : X → Y) → (P : Type) → (X → is-prop P) → (factors-through P f) → factors f
factor-helper {X} {Y} f P xpp (f₁ , f₂ , q) = f₁' , f₂' , q' where
  f₁' : X → Trunc X
  f₁' = ∣_∣

  f₂' : Trunc X → Y
  f₂' z = f₂ (rec {X} (rec is-prop-is-prop xpp z) f₁ z)

  q' : (x : X) → f₂' (f₁' x) == f x
  q' x =
    f₂' (f₁' x)         =⟨ idp ⟩
    f₂' ∣ x ∣            =⟨ idp ⟩
    f₂ (rec _ f₁ ∣ x ∣ ) =⟨ ap f₂ (trunc-β _ f₁ x) ⟩
    f₂ (f₁ x)           =⟨ q x ⟩
    f x                 ∎

-- Theorem 5.3
module thm53 {X Y : Type} (f : X → Y) (c : const f) where
  One = ¬ X
  Two = X
  Three = Trunc X → X
  Four = hasConst X
  Five = Y → X

  One→Three : One → Three
  One→Three nx z = Empty-elim {A = λ _ → X} (rec Empty-elim nx z)

  Two→Three : Two → Three
  Two→Three x = λ _ → x

  Five→Four : Five → Four
  Five→Four g = g ∘ f , (λ x₁ x₂ → ap g (c x₁ x₂))

  Three↔Four : Three ↔ Four
  Three↔Four = snd hasConst↔splitSup , fst hasConst↔splitSup

  Three→factors : Three → factors f
  Three→factors s = ∣_∣ , f ∘ s , (λ x → c _ _)

-- Theorem 5.4
-- as a small preparation, let us define a function that applies the truncation recursor twice:
double-rec : {X₁ X₂ P : Type} → (is-prop P) → (X₁ → X₂ → P) → Trunc X₁ → Trunc X₂ → P
double-rec {X₁} {X₂} {P} pp f z₁ z₂ = next-step z₂ z₁ where
  step : X₁ → Trunc X₂ → P
  step x₁ = rec {X = X₂} {P = P} pp (f x₁)
  step-switch : Trunc X₂ → X₁ → P
  step-switch z₂ x₁ = step x₁ z₂
  next-step : Trunc X₂ → Trunc X₁ → P
  next-step z₂ = rec pp (step-switch z₂)

-- now, the actual Theorem 5.4
factor-codomain-set : {X Y : Type} → (f : X → Y) → const f → is-set Y → factors f
factor-codomain-set {X} {Y} f c h = factor-helper f P (λ _ → pp) fact-through-p where
  P : Type
  P = Σ Y λ y → Trunc(Σ X λ x → f x == y)

  pp : is-prop P
  pp = all-paths-is-prop all-paths where
    all-paths : has-all-paths P
    all-paths (y₁ , t₁) (y₂ , t₂) = pair= ys ts where
      ys = double-rec {P = y₁ == y₂} (h _ _) (λ {(x₁ , p₁) (x₂ , p₂) → ! p₁ ∙ c _ _ ∙ p₂}) t₁ t₂
      ts = from-transp _ ys (prop-has-all-paths (h-tr _) _ _)

  fact-through-p : factors-through P f
  fact-through-p = f₁ , f₂ , q where
    f₁ : X → P
    f₁ x = f x , ∣ x , idp ∣
    f₂ : P → Y
    f₂ = fst
    q : (x : X) → f₂ (f₁ x) == f x
    q x = idp

-- Theorem 5.5
-- Note that this lemma requires function extensionality (hidden in the use of the library.types.Pi library:
-- at one point, we use that Π X Y is propositional as soon as Y x is (for all x)).

open import library.types.Pi

-- a general auxiliary function which switches the second and third component of a Σ-type with four components
-- (provided that it is possible)
-- we formulate this explicitly as we will need it several times
switch23 : {X : Type} → {Y Z : X → Type} → {W : (x : X) → (Y x) → (Z x) → Type} →
  (Σ X λ x → Σ (Y x) λ y → Σ (Z x) λ z → (W x y z)) ≃
  (Σ X λ x → Σ (Z x) λ z → Σ (Y x) λ y → (W x y z))
switch23 = equiv (λ {(y , s , t , coh) → (y , t , s , coh)}) (λ {(y , t , s , coh) → (y , s , t , coh)}) (λ _ → idp) (λ _ → idp)

module thm55aux {P : Type} {Y : P → Type} (pp : is-prop P) (x₀ : P) where
  neutral-contr-base-space : Σ P Y ≃ Y x₀
  neutral-contr-base-space =
    Σ P Y               ≃⟨ (equiv-Σ-fst {A = Unit} {B = P} Y
                             {λ _ → x₀}
                             (is-eq _ (λ _ → unit) (λ _ → prop-has-all-paths pp _ _) (λ _ → idp))) ⁻¹  ⟩
    Σ Unit (λ _ → Y x₀) ≃⟨ Σ₁-Unit ⟩
    Y x₀                ≃∎

  neutral-contr-exp : Π P Y ≃ Y x₀
  neutral-contr-exp =
    Π P Y               ≃⟨ (equiv-Π-l {A = Unit} {B = P} Y
                             {λ _ → x₀}
                             (is-eq _ (λ _ → unit) (λ _ → prop-has-all-paths pp _ _) (λ _ → idp))) ⁻¹ ⟩
    Π Unit (λ _ → Y x₀) ≃⟨ Π₁-Unit ⟩
    Y x₀                ≃∎

module thm55 {Q R Y : Type} (qq : is-prop Q) (rr : is-prop R) (f : Q + R → Y) (c : const f) where

  P : Type
  P = Σ Y λ y →
        Σ ((q : Q) → y == f(inl q)) λ s →
        Σ ((r : R) → y == f(inr r)) λ t →
          (q : Q) → (r : R) → ! (s q) ∙ (t r) == c (inl q) (inr r)

  -- This is going to be tedious: if q₀ : Q is given, we can show that P is equivalent to the Unit type.
  given-q-reduce-P : Q → P ≃ Unit
  given-q-reduce-P q₀ =

    P

                         ≃⟨ switch23 ⟩

    (Σ Y λ y →
        Σ ((r : R) → y == f(inr r)) λ t →
        Σ ((q : Q) → y == f(inl q)) λ s →
          (q : Q) → (r : R) → ! (s q) ∙ (t r) == c (inl q) (inr r))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ t → choice ⁻¹)) ⟩

    (Σ Y λ y →
        Σ ((r : R) → y == f(inr r)) λ t →
          (q : Q) → Σ (y == f(inl q)) λ s-reduced →
                      (r : R) → ! s-reduced ∙ (t r) == c (inl q) (inr r))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ t → thm55aux.neutral-contr-exp qq q₀)) ⟩

    (Σ Y λ y →
        Σ ((r : R) → y == f(inr r)) λ t →
          Σ (y == f(inl q₀)) λ s-reduced →
            (r : R) → ! s-reduced ∙ (t r) == c (inl q₀) (inr r))

                         ≃⟨ switch23 ⟩

    (Σ Y λ y →
        Σ (y == f(inl q₀)) λ s-reduced →
          Σ ((r : R) → y == f(inr r)) λ t →
            (r : R) → ! s-reduced ∙ (t r) == c (inl q₀) (inr r))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ t → choice ⁻¹)) ⟩

    (Σ Y λ y →
        Σ (y == f(inl q₀)) λ s-reduced →
          (r : R) → Σ (y == f(inr r)) λ t-reduced →
                       ! s-reduced ∙ t-reduced == c (inl q₀) (inr r))

                         ≃⟨ Σ-assoc ⁻¹ ⟩

    (Σ (Σ Y λ y → (y == f(inl q₀))) λ {(y , s-reduced) →
       (r : R) → Σ (y == f(inr r)) λ t-reduced →
                   ! s-reduced ∙ t-reduced == c (inl q₀) (inr r)})

                         ≃⟨ thm55aux.neutral-contr-base-space (contr-is-prop (pathto-is-contr _)) (f(inl q₀) , idp) ⟩

    ((r : R) → Σ (f(inl q₀) == f(inr r)) λ t-reduced →
                 idp ∙ t-reduced == c (inl q₀) (inr r))

                         ≃⟨ neutral-codomain (λ r → pathto-is-contr _) ⟩

    Unit                 ≃∎

  given-r-reduce-P : R → P ≃ Unit
  given-r-reduce-P r₀ =

    P

                         ≃⟨ equiv-Σ-snd (λ _ → equiv-Σ-snd (λ _ → equiv-Σ-snd (λ _ → switch-args))) ⟩

    (Σ Y λ y →
        Σ ((q : Q) → y == f(inl q)) λ s →
        Σ ((r : R) → y == f(inr r)) λ t →
          (r : R) → (q : Q) → ! (s q) ∙ (t r) == c (inl q) (inr r))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ s → choice ⁻¹)) ⟩

    (Σ Y λ y →
        Σ ((q : Q) → y == f(inl q)) λ s →
          (r : R) → Σ (y == f(inr r)) λ t-reduced →
                      (q : Q) → ! (s q) ∙ t-reduced == c (inl q) (inr r))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ t → thm55aux.neutral-contr-exp rr r₀)) ⟩

    (Σ Y λ y →
        Σ ((q : Q) → y == f(inl q)) λ s →
          Σ (y == f(inr r₀)) λ t-reduced →
            (q : Q) → ! (s q) ∙ t-reduced == c (inl q) (inr r₀))

                         ≃⟨ switch23 ⟩

    (Σ Y λ y →
        Σ (y == f(inr r₀)) λ t-reduced →
          Σ ((q : Q) → y == f(inl q)) λ s →
            (q : Q) → ! (s q) ∙ t-reduced == c (inl q) (inr r₀))

                         ≃⟨ equiv-Σ-snd (λ y → equiv-Σ-snd (λ s → choice ⁻¹)) ⟩

    (Σ Y λ y →
        Σ (y == f(inr r₀)) λ t-reduced →
          (q : Q) → Σ (y == f(inl q)) λ s-reduced →
                       ! s-reduced ∙ t-reduced == c (inl q) (inr r₀))

                         ≃⟨ Σ-assoc ⁻¹ ⟩

    (Σ (Σ Y λ y → (y == f(inr r₀))) λ {(y , t-reduced) →
       (q : Q) → Σ (y == f(inl q)) λ s-reduced →
                   ! s-reduced ∙ t-reduced == c (inl q) (inr r₀)})

                         ≃⟨ thm55aux.neutral-contr-base-space (contr-is-prop (pathto-is-contr _)) (f(inr r₀) , idp) ⟩

    ((q : Q) → Σ (f(inr r₀) == f(inl q)) λ s-reduced →
                  ! s-reduced ∙ idp == c (inl q) (inr r₀))

                         ≃⟨ equiv-Π-r (λ q → equiv-Σ-snd (λ proof →
                              ! proof ∙ idp == c (inl q) (inr r₀) ≃⟨ delete-idp _ _ ⟩
                              ! proof == c (inl q) (inr r₀) ≃⟨ reverse-paths _ _ ⟩
                              proof == ! (c (inl q) (inr r₀))   ≃∎
                         )) ⟩

    ((q : Q) → Σ (f(inr r₀) == f(inl q)) λ s-reduced →
                  s-reduced == ! (c (inl q) (inr r₀)))

                         ≃⟨  neutral-codomain (λ q → pathto-is-contr _) ⟩

    Unit                 ≃∎

  given-q+r-reduce-P : Q + R → P ≃ Unit
  given-q+r-reduce-P (inl q) = given-q-reduce-P q
  given-q+r-reduce-P (inr r) = given-r-reduce-P r

  Q+R→P : Q + R → P
  Q+R→P x = <– (given-q+r-reduce-P x) _

  P→Y : P → Y
  P→Y = fst

  open import library.types.Unit

  -- Finally : the statement of Theorem 5.5
  factor-f : factors f
  factor-f = factor-helper f P (λ x → equiv-preserves-level ((given-q+r-reduce-P x) ⁻¹) Unit-is-prop) (Q+R→P , P→Y , proof) where
    proof : (x : Q + R) → P→Y (Q+R→P x) == f x
    proof (inl q) = idp
    proof (inr r) = idp

-- and Theorem 5.5 again (outside of a specialized module)
Theorem55 : {Q R Y : Type} → (is-prop Q) → (is-prop R) → (f : Q + R → Y) → (const f) → factors f
Theorem55 = thm55.factor-f


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.S1 where

open import Cubical.HITs.S1.Base public
open import Cubical.HITs.S1.Properties public


module L.Base where

-- Reexport definitions
open import L.Base.Sigma public
open import L.Base.Coproduct public renaming (_+_ to _⊎_)
open import L.Base.Empty public
open import L.Base.Unit public
open import L.Base.Nat public
open import L.Base.Id public


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

open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
import homotopy.3x3.To as To
import homotopy.3x3.From as From
open import homotopy.3x3.Common

module homotopy.3x3.Commutes {i} (d : Span^2 {i}) where

open Span^2 d
open M using (Pushout^2)

open To d
open From d

open import homotopy.3x3.FromTo
open import homotopy.3x3.ToFrom

abstract
  theorem : Pushout^2 d ≃ Pushout^2 (transpose d)
  theorem = equiv to from (to-from d) (from-to d)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Notation for freely adding an infimum to any set
------------------------------------------------------------------------

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

module Relation.Nullary.Construct.Add.Infimum where

open import Relation.Nullary.Construct.Add.Point
  renaming (Pointed to _₋; ∙ to ⊥₋)
  public


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

open import lib.Basics
open import lib.PathGroupoid
open import lib.types.Bool
open import lib.types.Sigma
open import lib.types.Pi
open import lib.types.Coproduct
open import lib.types.Unit
open import lib.types.Empty
open import lib.NConnected
open import lib.NType
open import lib.NType2
open import lib.Equivalence
open import lib.types.Truncation

open import Util.Misc

open import Graphs.Definition
open import Graphs.Properties

open import Coequalizers.Definition
open import Coequalizers.EdgeCoproduct
open import Coequalizers.PreserveEquivalence
open import Coequalizers.TrivialExtension

{- Contains a useful lemma about extending subtrees used in the construction of spanning trees. -}
module Graphs.SubTrees where

{- We fix a graph E ⇉ V together with a family of types P over the vertex set. -}
module _ {i j k : ULevel} (E : Type i) (V : Type j) ⦃ gph : Graph E V ⦄
  (P : V → Type k) where
  private
    ijk' = lmax i (lmax j k)

  {- A crossing edge is an edge that has one end in P and one end outside P. -}
  record Crossingedge : Type ijk' where
    constructor
      crossingedge
    field
      edge : E
      dir : Bool
      end-in-P : P (Bool-rec (π₀ edge) (π₁ edge) dir)
      end-notin-P : ¬ (P (Bool-rec (π₁ edge) (π₀ edge) dir))

  {- If the graph is connected, P is decidable and we are given a vertex in P and a vertex outside P,
     then we can show there mereley exists an edge that crosses from P to ¬ P or vice versa. -}
  findedge : (dec : (v : V) → Dec (P v))  (u v : V) (uInP : P u) (vNotinP : ¬ (P v)) (p : c[ u ] == c[ v ] :> V / E) → ∥ Crossingedge ∥
  findedge dec u v uInP vNotinP p = equal-to-X c[ v ] p vNotinP
    where
      edgeequiv : (e : E) → ((¬ (P (π₀ e)) → ∥ Crossingedge ∥) ↔ (¬ (P (π₁ e)) → ∥ Crossingedge ∥))
      edgeequiv e =
        ⊔-rec
          (λ p0 → ⊔-rec
            (λ p1 → (λ _ f → ⊥-elim (f p1)) , λ _ f → ⊥-elim (f p0))
            (λ np1 → haveedge (crossingedge e true p0 np1))
            (dec (π₁ e)))
          (λ np0 → ⊔-rec
            (λ p1 → haveedge (crossingedge e false p1 np0))
            (λ np1 → (λ f _ → f np0) , λ f _ → f np1)
            (dec (π₁ e)))
          (dec ((π₀ e)))
          where
            haveedge : Crossingedge → ((¬ (P (π₀ e)) → ∥ Crossingedge ∥) ↔ (¬ (P (π₁ e)) → ∥ Crossingedge ∥))
            haveedge ce = (λ _ _ → [ ce ]) , λ _ _ → [ ce ]

      {- The key to the proof is to define a family of propositions X over the coequalizer of the graph.
         For this to be well defined we need the lemma edgeequiv above, together with
         propositional extensionality.
      -}
      X : V / E → Type (lmax j (lmax i k))
      X = Coeq-rec (λ v' → ¬ (P v') → ∥ Crossingedge ∥ ) (λ e → prop-extensionality (edgeequiv e))

      equal-to-X : (z : V / E) (p : c[ u ] == z) → X z
      equal-to-X .(c[ u ]) idp = λ nu → ⊥-elim (nu uInP)

module _ {i j k l : ULevel} (E : Type i) (V : Type j) ⦃ gph : Graph E V ⦄ where
  {- A subtree of E ⇉ V consists of a graph D ⇉ U such that U / D is contractible
     together with injection D ↪ E and decidable injection U ↪ V making the obvious squares commute. -}
  record SubTree (D : Type k) (U : Type l) : Type (lmax (lmax i j) (lmax k l)) where
    constructor subtree
    field
      ⦃ gphDU ⦄ : Graph D U
      inD : D → E
      inU : U → V
      D-inj : is-inj inD
      U-inj : is-inj inU
      U-dec : (v : V) → Dec (hfiber inU v)
      comm₀ : π₀ ∘ inD ∼ inU ∘ π₀
      comm₁ : π₁ ∘ inD ∼ inU ∘ π₁
      ⦃ DUistree ⦄ : is-tree gphDU

  {- If we are given subtree D ⇉ U and a vertex in V ∖ U, then we can extend the
     subtree to a slightly larger one that contains one new vertex.
  -}
  extend-subtree : {D : Type k} {U : Type l} ⦃ conn : gph-is-connected gph ⦄ (decV : has-dec-eq V)  → (t : SubTree D U) → (v : V) → ¬ (hfiber (SubTree.inU t) v) →
                   ∥ SubTree (⊤ ⊔ D) (U ⊔ ⊤) ∥
  extend-subtree {D} {U} decV record { gphDU = gphDU ; inD = inD ; inU = inU ; D-inj = D-inj ; U-inj = U-inj ; comm₀ = comm₀ ; comm₁ = comm₁ ; U-dec = U-dec} v f =
    do -- we use do notation to help deal with iterated recursion on propositional truncation (see the definion of >>= in Util/Misc.agda)
      u ← (Coeq-rec [_] (λ e → prop-has-all-paths _ _) (contr-center (⟨⟩ :> is-tree gphDU)))
      p ← (conn-to-path c[ inU u ] c[ v ])
      ce ← (findedge E V (hfiber inU) U-dec (inU u) v (u , idp) f p)
      [ from-ce ce ]
    where
      from-ce : Crossingedge E V (λ v → (hfiber inU v)) → (SubTree (⊤ ⊔ D) (U ⊔ ⊤))
      from-ce (crossingedge edge true end-in-P end-notin-P) =
        record
          { inD = λ { (inl _) → edge ; (inr d) → inD d}
          ; inU = λ { (inl u) → inU u ; (inr _) → π₁ edge}
          ; D-inj = λ { (inl unit) →
                        λ { (inl unit) _ → idp ; (inr d) p → ⊥-elim (end-notin-P ((π₁ d) , ! (ap π₁ p ∙ comm₁ d)))}
                      ; (inr d) →
                        λ { (inl unit) p → ⊥-elim (end-notin-P ((π₁ d) , ! (comm₁ d) ∙ ap π₁ p)) ; (inr d') p → ap inr (D-inj _ _ p)}}
          ; U-inj = λ { (inl u) →
                        λ { (inl u') p → ap inl (U-inj _ _ p) ; (inr unit) p → ⊥-elim (end-notin-P (u , p))}
                      ; (inr unit) →
                        λ { (inl u) p → ⊥-elim (end-notin-P (u , (! p))) ; (inr unit) _ → idp}}
          ; U-dec = λ v → ⊔-rec (λ {(u , p) → inl ((inl u) , p)})
                                   (λ f → ⊔-rec (λ p → inl ((inr unit) , ! p))
                                                (λ g → inr (λ {(inl u , p) → f ((u , p)) ; (inr unit , p) → g (! p)}))
                                                (decV v (π₁ edge)))
                                   (U-dec v)
          ; comm₀ = λ { (inl x) → ! (snd end-in-P) ; (inr d) → comm₀ d}
          ; comm₁ = λ { (inl _) → idp ; (inr d) → comm₁ d}
          ; DUistree = equiv-preserves-level (extn-equiv ⁻¹)
          }
        where
          instance
            gphDU' : Graph (⊤ ⊔ D) (U ⊔ ⊤)
            gphDU' = record { π₀ = λ { (inl _) → inl (fst end-in-P) ; (inr x) → inl (π₀ x) }
                           ; π₁ = λ { (inl _) → inr unit ; (inr x) → inl (π₁ x) }}

            extn-equiv : (U ⊔ ⊤) / (⊤ ⊔ D) ≃ U / D
            extn-equiv =
              (U ⊔ ⊤) / (⊤ ⊔ D)
                ≃⟨ edge-coproduct-expand ⟩
              ((U ⊔ ⊤) / ⊤) / D
                ≃⟨ (Coeq-emap (TExtensionCoeq-l.extn-equiv (fst end-in-P)) (ide D) (λ _ → idp) λ _ → idp) ⁻¹ ⟩
              U / D
                ≃∎
              where
                open CoeqCoprodEquiv (U ⊔ ⊤) ⊤ D -- also defines instances for (U ⊔ ⊤) / ⊤) / D

      from-ce (crossingedge edge false end-in-P end-notin-P) =
        record
          { inD = λ { (inl _) → edge ; (inr d) → inD d}
          ; inU = λ { (inl u) → inU u ; (inr _) → π₀ edge}
          ; D-inj = λ { (inl unit) →
                        λ { (inl unit) _ → idp ; (inr d) p → ⊥-elim (end-notin-P ((π₀ d) , ! (ap π₀ p ∙ comm₀ d)))}
                      ; (inr d) →
                        λ { (inl unit) p → ⊥-elim (end-notin-P ((π₀ d) , ! (comm₀ d) ∙ ap π₀ p)) ; (inr d') p → ap inr (D-inj _ _ p)}}
          ; U-inj = λ { (inl u) →
                        λ { (inl u') p → ap inl (U-inj _ _ p) ; (inr unit) p → ⊥-elim (end-notin-P (u , p))}
                      ; (inr unit) →
                        λ { (inl u) p → ⊥-elim (end-notin-P (u , (! p))) ; (inr unit) _ → idp}}
          ; U-dec = λ v → ⊔-rec (λ {(u , p) → inl ((inl u) , p)})
                                   (λ f → ⊔-rec (λ p → inl ((inr unit) , ! p))
                                                (λ g → inr (λ {(inl u , p) → f ((u , p)) ; (inr unit , p) → g (! p)}))
                                                (decV v (π₀ edge)))
                                   (U-dec v)
          ; comm₀ = λ { (inl _) → idp ; (inr d) → comm₀ d}
          ; comm₁ = λ { (inl x) → ! (snd end-in-P) ; (inr d) → comm₁ d}
          ; DUistree = equiv-preserves-level (extn-equiv ⁻¹)
          }
          where
            instance
              gphDU' : Graph (⊤ ⊔ D) (U ⊔ ⊤)
              gphDU' = record { π₀ = λ { (inl _) →  inr unit ; (inr x) → inl (π₀ x) }
                             ; π₁ = λ { (inl _) → inl (fst end-in-P) ; (inr x) → inl (π₁ x) }}

              extn-equiv : (U ⊔ ⊤) / (⊤ ⊔ D) ≃ U / D
              extn-equiv =
                (U ⊔ ⊤) / (⊤ ⊔ D)
                  ≃⟨ edge-coproduct-expand ⟩
                ((U ⊔ ⊤) / ⊤) / D
                    ≃⟨ Coeq-emap (TExtensionCoeq-r.extn-equiv (fst end-in-P)) (ide D) (λ _ → idp) (λ _ → idp) ⁻¹ ⟩
                U / D
                  ≃∎
                where
                  open CoeqCoprodEquiv (U ⊔ ⊤) ⊤ D -- also defines instances for (U ⊔ ⊤) / ⊤) / D


------------------------------------------------------------------------
-- Higher lenses, defined using the requirement that the remainder
-- function should be surjective
------------------------------------------------------------------------

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

import Equality.Path as P

module Lens.Non-dependent.Higher.Surjective-remainder
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq hiding (univ)
open import Equivalence equality-with-J as Eq using (_≃_; Is-equivalence)
open import Function-universe equality-with-J as F
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher eq as Higher

private
  variable
    a b : Level
    A B : Set a

-- A variant of the lenses defined in Lens.Non-dependent.Higher. In
-- this definition the function called inhabited is replaced by a
-- requirement that the remainder function should be surjective.

Lens : Set a → Set b → Set (lsuc (a ⊔ b))
Lens {a = a} {b = b} A B =
  ∃ λ (get       : A → B) →
  ∃ λ (R         : Set (a ⊔ b)) →
  ∃ λ (remainder : A → R) →
    Is-equivalence (λ a → remainder a , get a) ×
    Surjective remainder

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = λ (get , _) → get
    ; set = λ (_ , _ , rem , equiv , _) a b →
              _≃_.from Eq.⟨ _ , equiv ⟩ (rem a , b)
    }

-- Higher.Lens A B is isomorphic to Lens A B.

Higher-lens↔Lens : Higher.Lens A B ↔ Lens A B
Higher-lens↔Lens {A = A} {B = B} =

  Higher.Lens A B                                         ↝⟨ Higher.Lens-as-Σ ⟩

  (∃ λ (R : Set _) →
     (A ≃ (R × B)) ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ _ → Eq.≃-as-Σ ×-cong F.id) ⟩

  (∃ λ (R : Set _) →
     (∃ λ (f : A → R × B) → Eq.Is-equivalence f) ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ _ → inverse Σ-assoc) ⟩

  (∃ λ (R : Set _) →
   ∃ λ (f : A → R × B) →
     Eq.Is-equivalence f ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ _ → Σ-cong ΠΣ-comm λ _ → F.id) ⟩

  (∃ λ (R  : Set _) →
   ∃ λ (rg : (A → R) × (A → B)) →
     Eq.Is-equivalence (λ a → proj₁ rg a , proj₂ rg a) ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ _ → inverse Σ-assoc) ⟩

  (∃ λ (R         : Set _) →
   ∃ λ (remainder : A → R) →
   ∃ λ (get       : A → B) →
     Eq.Is-equivalence (λ a → remainder a , get a) ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ _ → ∃-comm) ⟩

  (∃ λ (R         : Set _) →
   ∃ λ (get       : A → B) →
   ∃ λ (remainder : A → R) →
     Eq.Is-equivalence (λ a → remainder a , get a) ×
     (R → ∥ B ∥))                                         ↝⟨ ∃-comm ⟩

  (∃ λ (get       : A → B) →
   ∃ λ (R         : Set _) →
   ∃ λ (remainder : A → R) →
     Eq.Is-equivalence (λ a → remainder a , get a) ×
     (R → ∥ B ∥))                                         ↝⟨ (∃-cong λ get → ∃-cong λ R → ∃-cong λ rem → ∃-cong λ eq →
                                                              ∀-cong ext λ _ → ∥∥-cong $
                                                              lemma get R rem eq _) ⟩□
  (∃ λ (get       : A → B) →
   ∃ λ (R         : Set _) →
   ∃ λ (remainder : A → R) →
     Eq.Is-equivalence (λ a → remainder a , get a) ×
     Surjective remainder)                                □

  where
  lemma : ∀ _ _ _ _ _ → _
  lemma = λ _ _ remainder eq r →
    B                            ↝⟨ (inverse $ drop-⊤-right λ _ →
                                     _⇔_.to contractible⇔↔⊤ $
                                     singleton-contractible _) ⟩
    B × Singleton r              ↝⟨ Σ-assoc ⟩
    (∃ λ { (_ , r′) → r′ ≡ r })  ↝⟨ (Σ-cong ×-comm λ _ → F.id) ⟩
    (∃ λ { (r′ , _) → r′ ≡ r })  ↝⟨ (inverse $ Σ-cong Eq.⟨ _ , eq ⟩ λ _ → F.id) ⟩□
    (∃ λ a → remainder a ≡ r)    □

-- The isomorphism preserves getters and setters.

Higher-lens↔Lens-preserves-getters-and-setters :
  Preserves-getters-and-setters-⇔ A B
    (_↔_.logical-equivalence Higher-lens↔Lens)
Higher-lens↔Lens-preserves-getters-and-setters =
  Preserves-getters-and-setters-→-↠-⇔
    (_↔_.surjection Higher-lens↔Lens)
    (λ _ → refl _ , refl _)


module Human.Humanity where

-- Use agda-prelude instead of agda-stdlib?

open import Human.JS public
open import Human.Unit public
open import Human.Nat public
open import Human.List public
open import Human.Bool public
open import Human.String public
open import Human.IO public
open import Human.Float public
open import Human.Int public

Lazy : ∀ (A : Set) → Set
Lazy A = Unit → A

then:_ : ∀ {A : Set} → A → Lazy A
then: a = λ x → a

else:_ : ∀ {A : Set} → A → Lazy A
else: a = λ x → a

if : ∀ {A : Set} → Bool → Lazy A → Lazy A → A
if true  t f = t unit
if false t f = f unit

init-to : ∀ {A : Set} → Nat → A → (Nat → A → A) → A
init-to zero    x fn = x
init-to (suc i) x fn = init-to i (fn zero x) (λ i → fn (suc i))

{-# COMPILE JS init-to = A => n => x => fn => { for (var i = 0, l = n.toJSValue(); i < l; ++i) x = fn(agdaRTS.primIntegerFromString(String(i)))(x); return x; } #-}

syntax init-to m x (λ i → b) = init x for i to m do: b

init-from-to : ∀ {A : Set} → Nat → A → Nat → (Nat → A → A) → A
init-from-to n x m f = init-to (m - n) x (λ i x → f (n + i) x)

syntax init-from-to n x m (λ i → b) = init x for i from n to m do: b

for-to : Nat → (Nat → IO Unit) → IO Unit
for-to zero    act = return unit
for-to (suc n) act = act zero >> for-to n (λ i → act (suc i))

syntax for-from-to n m (λ i → b) = for i from n to m do: b

for-from-to : Nat → Nat → (Nat → IO Unit) → IO Unit
for-from-to n m f = for-to (m - n) (λ i → f (n + i))

syntax for-to m (λ i → b) = for i to m do: b

_++_ : String → String → String
_++_ = primStringAppend

show : Nat → String
show zero    = "Z"
show (suc n) = "S" ++ show n

Program : Set
Program = Lazy (IO Unit)

_f+_ : Float → Float → Float
_f+_ = primFloatPlus


postulate
  A : Set

open import Agda.Builtin.Equality

foo : (f : A → A → A) (@0 g : @0 A → @0 A → A)
    → @0 _≡_ {A = @0 A → @0 A → A} g (\ x y → f y x)
    → @0 A → @0 A → A
foo f g refl = g
  -- In the goal, `C-c C-n g` gives
  -- λ (@0 x) (@0 y) → f y x
  -- which is only well-typed in an erased context.

bad : (f : A → A → A) → @0 A → @0 A → A
bad f = foo f (\ x y → f y x) refl


{-# OPTIONS --prop --cubical-compatible #-}

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


module Miscellaneous.InstanceLoop where

open import Type

postulate A : TYPE
postulate B : TYPE
postulate C : TYPE

instance
  postulate ab : ⦃ A ⦄ → B

instance
  postulate ba : ⦃ B ⦄ → A

postulate a : A

test-a : B
test-a = ab


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

module LLev where

--****************
-- Universe polymorphism
--****************

data Level : Set where
      ze : Level
      su  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO ze  #-}
{-# BUILTIN LEVELSUC  su   #-}

max : Level -> Level -> Level
max  ze     m     = m
max (su n)  ze    = su n
max (su n) (su m) = su (max n m)

{-# BUILTIN LEVELMAX max #-}

record Up {l : Level} (A : Set l) : Set (su l) where
  constructor up
  field down : A
open Up

record Sg {l : Level}(S : Set l)(T : S -> Set l) : Set l where
  constructor _,_
  field
    fst : S
    snd : T fst
open Sg
_*_ : {l : Level} -> Set l -> Set l -> Set l
S * T = Sg S \ _ -> T
infixr 4 _*_ _,_

data Zero : Set where

record One {l : Level} : Set l where
  constructor <>

data Desc {l : Level}(I : Set l) : Set (su l) where
  var : (i : I) -> Desc I
  con : (A : Set l) -> Desc I
  sg pi : (S : Set l)(T : S -> Desc I) -> Desc I
  _**_ : (S T : Desc I) -> Desc I
infixr 4 _**_

[!_!] : {l : Level}{I : Set l} -> Desc I -> (I -> Set l) -> Set l
[! var i !] X = X i
[! con A !] X = A
[! sg S T !] X = Sg S \ s -> [! T s !] X
[! pi S T !] X = (s : S) -> [! T s !] X
[! S ** T !] X = [! S !] X * [! T !] X

{-
data Mu {l : Level}(I : Set l)(F : I -> Desc I)(i : I) : Set l where
  <_> : [! F i !] (Mu I F) -> Mu I F i
-}

All : {l : Level}{I : Set l}
      (D : Desc I)(X : I -> Set l) -> [! D !] X -> Desc (Sg I X)
All (var i) X x = var (i , x)
All (con A) X d = con One
All (sg S T) X (s , t) = All (T s) X t
All (pi S T) X f = pi S \ s -> All (T s) X (f s)
All (S ** T) X (s , t) = All S X s ** All T X t

all : {l : Level}{I : Set l}
      (D : Desc I)(X : I -> Set l)(P : Sg I X -> Set l) ->
      ((ix : Sg I X) -> P ix) ->
      (d : [! D !] X) -> [! All D X d !] P
all (var i) X P p x = p (i , x)
all (con A) X P p d = _
all (sg S T) X P p (s , t) = all (T s) X P p t
all (pi S T) X P p f = \ s -> all (T s) X P p (f s)
all (S ** T) X P p (s , t) = all S X P p s , all T X P p t

{-
induction :  {l : Level}{I : Set l}{F : I -> Desc I}
             (P : Sg I (Mu I F) -> Set l) ->
             ((i : I)(d : [! F i !] (Mu I F)) ->
               [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
             (ix : Sg I (Mu I F)) -> P ix
induction {F = F} P p (i , < d >) = p i d (all (F i) (Mu _ F) P (induction P p) d)
-}

{-
mutual
  induction :  {l : Level}{I : Set l}{F : I -> Desc I}
               (P : Sg I (Mu I F) -> Set l) ->
               ((i : I)(d : [! F i !] (Mu I F)) ->
                 [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
               {i : I}(x : Mu I F i) -> P (i , x)
  induction {F = F} P p {i} < d > = p i d (allInduction F P p (F i) d)
  allInduction : {l : Level}{I : Set l}(F : I -> Desc I)
                 (P : Sg I (Mu I F) -> Set l) ->
                 ((i : I)(d : [! F i !] (Mu I F)) ->
                    [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
                 (D : Desc I) ->
                 (d : [! D !] (Mu I F)) -> [! All D (Mu I F) d !] P
  allInduction F P p (var i) d = induction P p d
  allInduction F P p (con A) d = _
  allInduction F P p (sg S T) (s , t) = allInduction F P p (T s) t
  allInduction F P p (pi S T) f = \ s -> allInduction F P p (T s) (f s)
  allInduction F P p (S ** T) (s , t) = allInduction F P p S s , allInduction F P p T t
-}

data List {l : Level}(X : Set l) : Set l where
  [] : List X
  _::_ : X -> List X -> List X
infixr 3 _::_

map : {k l : Level}{X : Set k}{Y : Set l} -> (X -> Y) -> List X -> List Y
map f [] = []
map f (x :: xs) = f x :: map f xs

data UId {l : Level} : Set l where
  ze : UId
  su : UId {l} -> UId

data # {l : Level} : List {l} UId -> Set l where
  ze : forall {x xs} -> # (x :: xs)
  su : forall {x xs} -> # xs -> # (x :: xs)

Constrs : {l : Level} -> Set l -> Set (su l)
Constrs I = List (Up UId * Desc I)

Constr : {l : Level}{I : Set l} -> Constrs I -> Set l
Constr uDs = # (map (\ uD -> down (fst uD)) uDs)

ConD : {l : Level}{I : Set l}(uDs : Constrs I) -> Constr uDs -> Desc I
ConD [] ()
ConD (uD :: _)  ze     = snd uD
ConD (_ :: uDs) (su c) = ConD uDs c

data Data {l : Level}{I : Set l}(F : I -> Constrs I)(i : I) : Set l where
  _/_ : (u : Constr (F i))(d : [! ConD (F i) u !] (Data F)) -> Data F i

{-
DataD : {l : Level}{I : Set l} -> Constrs I -> Desc I
DataD uDs = sg (Constr uDs) (ConD uDs)

Data : {l : Level}{I : Set l}(F : I -> Constrs I)(i : I) -> Set l
Data F = Mu _ \ i -> DataD (F i)
-}

MethodD : {l : Level}{I : Set l}(X : I -> Set l)
          (uDs : Constrs I)
          (P : Sg I X -> Set l)
          (i : I) -> ((u : Constr uDs)(d : [! ConD uDs u !] X) -> X i) -> Set l
MethodD X [] P i c = One
MethodD X ((u , D) :: uDs) P i c
  = ((d : [! D !] X) -> [! All D X d !] P -> P (i , c ze d))
  * MethodD X uDs P i (\ u d -> c (su u) d)

mutual
  induction : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I}(x : Data F i)
              (P : Sg I (Data F) -> Set l)
              (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
              -> P (i , x)
  induction {F = F}{i = i}(u / d) P ps = indMethod P ps (F i) _/_ (ps i) u d
  indMethod : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I}
              (P : Sg I (Data F) -> Set l)
              (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
              (uDs : Constrs I)
              (c : (u : Constr uDs) -> [! ConD uDs u !] (Data F) -> Data F i)
              (ms : MethodD (Data F) uDs P i c)
              (u : Constr uDs)
              (d : [! ConD uDs u !] (Data F))
              -> P (i , c u d)
  indMethod P ps [] c ms () d
  indMethod P ps ((u , D) :: _) c (p , ms) ze d = p d (indHyps P ps D d)
  indMethod P ps ((_ , _) :: uDs) c (m , ms) (su u) d
    = indMethod P ps uDs _ ms u d
  indHyps : {l : Level}{I : Set l}{F : I -> Constrs I}
            (P : Sg I (Data F) -> Set l)
            (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
            (D : Desc I)
            (d : [! D !] (Data F))
            -> [! All D (Data F) d !] P
  indHyps P ps (var i) x = induction x P ps
  indHyps P ps (con A) a = _
  indHyps P ps (sg S T) (s , t) = indHyps P ps (T s) t
  indHyps P ps (pi S T) f = \ s -> indHyps P ps (T s) (f s)
  indHyps P ps (S ** T) (s , t) = indHyps P ps S s , indHyps P ps T t

zi : {l : Level} -> UId {l}
zi = ze

si : {l : Level} -> UId {l}
si = su ze

data UQ {l : Level}(x : UId {l}) : UId {l} -> Set l where
  yes : UQ x x
  no  : {y : UId {l}} -> UQ x y

uq : {l : Level}(x y : UId {l}) -> UQ x y
uq ze ze = yes
uq ze (su y) = no
uq (su x) ze = no
uq (su x) (su y) with uq x y
uq (su x) (su .x) | yes = yes
uq (su x) (su y)  | no  = no

UIn : {l : Level}(x : UId {l}) -> List (UId {l}) -> Set
UIn x [] = Zero
UIn x (y :: ys) with uq x y
UIn x (.x :: _) | yes = One
UIn x (_ :: ys) | no = UIn x ys

uin : {l : Level}(x : UId {l})(ys : List (UId {l})) -> UIn x ys -> # ys
uin x [] ()
uin x (y :: ys) p with uq x y
uin x (.x :: _) _ | yes = ze
uin x (_ :: ys) p | no  = su (uin x ys p)

_!_ : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I} ->
      let us = map (\ uD -> down (fst uD)) (F i) in
      (u : UId {l}){p : UIn u us} ->
      [! ConD (F i) (uin u us p) !] (Data F) ->
      Data F i
_!_ {l}{I}{F}{i} u {p} d = uin u (map (\ uD -> down (fst uD)) (F i)) p / d

infixr 3 _!_

NAT : {l : Level} -> One {l} -> Constrs {l} One
NAT _ = up zi , con One
     :: up si , var _ ** con One
     :: []

ZE : {l : Level} -> Data {l} NAT <>
ZE = zi ! <>

SU : {l : Level} -> Data {l} NAT <> -> Data {l} NAT <>
SU n = si ! n , <>

vari : {l : Level} -> UId {l}
vari = ze
coni : {l : Level} -> UId {l}
coni = su ze
sgi : {l : Level} -> UId {l}
sgi = su (su ze)
pii : {l : Level} -> UId {l}
pii = su (su (su ze))
asti : {l : Level} -> UId {l}
asti = su (su (su (su ze)))

DESC : {l : Level}(I : Set l) -> One {su l} -> Constrs {su l} One
DESC I _ = up vari , con (Up I) ** con One
        :: up coni , con (Set _) ** con One
        :: up sgi , (sg (Set _) \ S -> (pi (Up S) \ _ -> var _) ** con One)
        :: up pii , (sg (Set _) \ S -> (pi (Up S) \ _ -> var _) ** con One)
        :: up asti , var _ ** var _ ** con One
        :: []


module Issue87 where

data I : Set where

data D : I -> Set where
  d : forall {i} (x : D i) -> D i

bar : forall {i} -> D i -> D i -> D i
bar (d x) (d     y) with y
bar (d x) (d {i} y) | z = d {i} y

-- ERROR WAS:
-- Panic: unbound variable i
-- when checking that the expression i has type I

-- Andreas, 2016-06-02
-- This looks weird, but is accepted currently:
test : ∀ i → D i → D i → D i
test .i (d {i} x) (d {.i} y) with y
test .i (d {j} x) (d {i} y) | _ = d {i} y
-- Note the {j}!


-- An implementation of Olivier Danvy's Type-Directed Partial Evaluation (POPL 1996)
-- for STLC with sum types using continuations in form of shift and reset.
--
-- The algorithm was originally for a two-level lambda-calculus.

-- Our use of Kripke semantics makes the effect of fresh variable generation explicit and formal.

open import Library

module DanvyShiftResetLiftable where

data Base : Set where
  α β : Base

open import Formulas    Base
open import Derivations Base

-- Continutation monad with answer type R.
-- (Cf. Haskell's Control.Monad.Cont.Cont = (A → R) → R).

record M (R A : Cxt → Set) (Γ : Cxt) : Set where
  constructor shift
  field run : KFun (KFun A R) R Γ
open M

-- shift : ∀{R A Γ} (f : KFun (KFun A R) R Γ) → M R A Γ
-- shift f .run σ k = f σ k

reset : ∀{A} → M A A →̇ A
reset m = m .run id≤ λ τ → id

return : ∀{R A} → □ A →̇ M R A
return x .run τ k = k id≤ (x τ)

return' : ∀{R A} → □ A →̇ M R (□ A)
return' x .run τ k = k id≤ λ τ₁ → x (τ₁ • τ)

-- Bind

_>>=_ : ∀{R A B Γ} (m : M R A Γ) (f : KFun A (M R B) Γ) → M R B Γ
(m >>= f) .run σ k = m .run σ λ τ a → f (τ • σ) a .run id≤ λ τ′ → k (τ′ • τ)

-- Map

_<$>_ : ∀{R A B} (f : A →̇ B) → M R A →̇ M R B
(f <$> m) .run σ k = m .run σ λ τ → k τ ∘ f

_<&>_ : ∀{R A B Γ} (m : M R A Γ) (f : A →̇ B) → M R B Γ
(m <&> f) .run σ k = m .run σ λ τ → k τ ∘ f

-- Kripke map

K$ : ∀{R A B} → KFun A B →̇ KFun (M R A) (M R B)
K$ f τ m .run σ k = m .run σ λ τ′ a →  k τ′ (f (τ′ • (σ • τ)) a)

-- We use a continuation monad with answer type Nf.

M' : (X : Cxt → Set) (Γ : Cxt) → Set
M' X Γ = ∀ {C} → M (Nf' C) X Γ

T⟦_⟧ : (A : Form) (Γ : Cxt) → Set
T⟦ Atom P ⟧ = □ (Nf' (Atom P))
T⟦ True   ⟧ Γ = ⊤
T⟦ False  ⟧ Γ = ⊥
T⟦ A ∨ B  ⟧ Γ = T⟦ A ⟧ Γ ⊎ T⟦ B ⟧ Γ
T⟦ A ∧ B  ⟧ Γ = T⟦ A ⟧ Γ × T⟦ B ⟧ Γ
T⟦ A ⇒ B  ⟧ Γ = ∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → M' T⟦ B ⟧ Δ

-- Monotonicity of the model is proven by induction on the proposition.

-- monT : ∀ A {Γ Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ → T⟦ A ⟧ Δ

monT : ∀ A → Mon T⟦ A ⟧
monT (Atom P) = mon□
monT True     = _
monT False  τ ()
monT (A ∨ B) τ = map-⊎ (monT A τ) (monT B τ)
monT (A ∧ B) τ (a , b) = monT A τ a , monT B τ b
monT (A ⇒ B) τ f σ = f (σ • τ)

fresh : ∀{A Γ} → □ (Ne' A) (Γ ∙ A)
fresh τ′ = hyp (monH τ′ top)

-- Reflection / reification, proven simultaneously by induction on the proposition.

-- Reflection is η-expansion (and recursively reflection);

mutual

  reflect : ∀ A → □ (Ne' A) →̇ M' T⟦ A ⟧
  reflect (Atom P) t = return' (ne ∘′ t) -- λ τ → ne (monNe τ t)
  reflect True     t = return _
  reflect False    t = shift λ τ k → falseE (t τ)
  reflect (A ∨ B)  t = shift λ τ k → orE (t τ)
    (reset (K$ k (weak id≤) (inj₁ <$> reflect A fresh)))
    (reset (K$ k (weak id≤) (inj₂ <$> reflect B fresh)))

    -- ((inj₂ <$> reflect B (hyp top)) .run λ τ → k (τ • weak id≤))
    -- Wrong:
    --     (reset (k (weak id≤) <$> (inj₁ <$> reflect A (hyp top))))

  -- reflect (A ∧ B) t = do
  --   a ← reflect A (andE₁ t)
  --   b ← reflect B (andE₂ t)
  --   return (a , b)

  reflect (A ∧ B) t =
    reflect A (                andE₁ ∘ t ) >>= λ τ a →
    reflect B (mon□ {Ne' B} τ (andE₂ ∘ t)) >>= λ τ′ b →
    return λ τ₁ → monT A (τ₁ • τ′) a , monT B τ₁ b

  reflect (A ⇒ B)  t = return' λ τ a → reflect B λ τ′ → impE (t (τ′ • τ)) (reify A a τ′)

  reify : ∀ A → T⟦ A ⟧ →̇ □ (Nf' A)

  reify (Atom P) t = t
  reify True     _       τ = trueI
  reify False   ()
  reify (A ∨ B) (inj₁ a) τ = orI₁ (reify A a τ)
  reify (A ∨ B) (inj₂ b) τ = orI₂ (reify B b τ)
  reify (A ∧ B) (a , b) τ = andI (reify A a τ) (reify B b τ)

  reify (A ⇒ B) f       τ = impI $ reset $
    reflect A fresh >>= λ τ′ a →
    f (τ′ • weak τ) a <&> λ b →
    reify B b id≤

-- Fundamental theorem

-- Delayed lifting

record ◇ (G : Cxt → Set) (Γ : Cxt) : Set where
  constructor dia; field
    {Δ} : Cxt
    τ   : Γ ≤ Δ
    γ   : G Δ

mon◇ : ∀{P} → Mon (◇ P)
mon◇ τ′ (dia τ p) = dia (τ′ • τ) p

-- NB: ◇ is a monad

module Monad◇ where

  return◇ : ∀{P} → P →̇ ◇ P
  return◇ = dia id≤

  join◇ : ∀{P} → ◇ (◇ P) →̇ ◇ P
  join◇ (dia τ d) = mon◇ τ d
  -- join◇ (dia τ (dia τ′ a)) = dia (τ • τ′) a

  map◇ : ∀{P Q} → (P →̇ Q) → ◇ P →̇ ◇ Q
  map◇ f (dia τ p) = dia τ (f p)

-- Extension of T⟦_⟧ to contexts to classify semantic environments.

G⟦_⟧ : ∀ (Γ Δ : Cxt) → Set
G⟦ ε     ⟧ _ = ⊤
G⟦ Γ ∙ A ⟧ = ◇ λ Δ → G⟦ Γ ⟧ Δ × T⟦ A ⟧ Δ

-- monG is lazy except for matching on the context.

monG : ∀{Γ} → Mon G⟦ Γ ⟧
monG {ε} τ _ = _
monG {Γ ∙ A} τ γ = mon◇ τ γ

-- Environment extension.

ext : ∀ A {Γ Δ₁ Δ} →
      (τ : Δ ≤ Δ₁) (γ : G⟦ Γ ⟧ Δ₁) →
      (a : T⟦ A ⟧ Δ) →
      □ G⟦ Γ ∙ A ⟧ Δ
ext A τ γ a τ′ = dia τ′ (monG τ γ , a)

-- Lookup in the environment.
-- Accumulates embedded weakenings from environment.

fundH : ∀{A Γ} (x : Hyp A Γ) → G⟦ Γ ⟧  →̇ □ T⟦ A ⟧
fundH {A} top (dia τ′ (_ , a)) τ = monT A (τ • τ′) a
fundH (pop x) (dia τ′ (γ , _)) τ = fundH x γ (τ • τ′)

-- The fundamental theorem:
-- A call-by-value interpreter.

fund :  ∀{Γ A} (t : Γ ⊢ A) → G⟦ Γ ⟧  →̇ M' T⟦ A ⟧

fund (hyp {A} x) γ = return (fundH x γ)
fund (impI {A} t) γ = return' λ τ a → fund t (ext A τ γ a id≤)

fund (impE t u)  γ =
  fund t γ          >>= λ τ f →
  fund u (monG τ γ) >>= λ τ′ a →
  f τ′ a

fund (andI {A} {B} t u) γ =
  fund t γ          >>= λ τ a →
  fund u (monG τ γ) >>= λ τ′ b →
  return λ τ₁ → monT A (τ₁ • τ′) a , monT B τ₁ b

fund (andE₁ t)    γ = proj₁ <$> fund t γ
fund (andE₂ t)    γ = proj₂ <$> fund t γ
fund (orI₁ t)     γ = inj₁  <$> fund t γ
fund (orI₂ t)     γ = inj₂  <$> fund t γ

fund (orE {A} {B} t u v) γ = fund t γ >>= λ τ →
  [ (λ a → fund u (ext A τ γ a id≤))
  , (λ b → fund v (ext B τ γ b id≤))
  ]

fund (falseE t)  γ = fund t γ >>= λ τ ()
fund trueI       γ = return _

-- Identity environment

ide : ∀ Γ → □ (M' G⟦ Γ ⟧) Γ
ide ε       τ = return _
ide (Γ ∙ A) τ =
  ide Γ (τ • weak id≤)           >>= λ τ₁ γ →
  reflect A (mon□ (τ₁ • τ) fresh) >>= λ τ₂ a →
  return (ext A τ₂ γ a)
  -- return λ τ₃ → dia τ₃ (monG τ₂ γ , a)

-- Normalization

norm : ∀{A Γ} (t : Γ ⊢ A) → Nf Γ A
norm {A} {Γ} t = reset $
  ide Γ id≤ >>= λ _ γ →
  fund t γ <&> λ a →
  reify A a id≤

-- Testing

idD : (A : Form) → ε ⊢ (A ⇒ A)
idD A = impI (hyp top)

test : let A = Atom α; B = Atom β in Nf ε (A ∨ B ⇒ A ∨ B)
test = norm (idD (Atom α ∨ Atom β))

test2 = norm (idD (Atom α ∨ Atom β ∨ Atom α))

test3 = norm (idD False)

-- Q.E.D. -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


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

module M-types.Base.Core where
    open import Agda.Primitive public using (Level) renaming
        (
            lzero to ℓ-zero ;
            lsuc to ℓ-suc ;
            _⊔_ to ℓ-max
        )

    variable
        ℓ ℓ₀ ℓ₁ ℓ₂ : Level

    Ty : (ℓ : Level) → Set (ℓ-suc ℓ)
    Ty ℓ = Set ℓ


open import Signature

-- | In this module, we construct the free monad and the free completely
-- iterative monad over a signature Σ (see Aczel, Adamek, Milius and Velebil).
-- The first assigns to a set V of variables the set TV of finite terms over Σ
-- (that is, finite trees labelled with symbols in f ∈ ∥Σ∥ and ar(f) branching).
-- The second extends this to also allow for infinite trees, the set of those
-- is then denoted by T∞(V).
-- Categorically, T(V) is the initial (Σ + V)-algebra, whereas T∞(V) is the
-- final (Σ + V)-coalgebra.
module Terms (Σ : Sig) where

open import Function
open import Data.Empty
open import Data.Unit hiding (_≤_)
open import Data.Product as Prod renaming (Σ to ⨿)
open import Data.Nat as Nat
open import Data.Sum as Sum
open import Relation.Binary.PropositionalEquality hiding ([_])
open ≡-Reasoning
open import Relation.Binary hiding (_⇒_)
open import Relation.Unary hiding (_⇒_)
import Streams as Str
open import Streams hiding (corec)

-- | Natural transformations
Nat : (Set → Set) → (Set → Set) → Set₁
Nat F G = ∀{X} → F X → G X

Id : Set → Set
Id = id

least : {X : Set} (_⊑_ : Rel X _) (P : X → Set) → X → Set
least _⊑_ P x = (P x) × (∀ {y} → P y → x ⊑ y)

least-unique : {X : Set} {_⊑_ : Rel X _} → (IsTotalOrder _≡_ _⊑_) →
               {P : X → Set} → (x y : X) → least _⊑_ P x → least _⊑_ P y → x ≡ y
least-unique isTO x y (p , l₁) (q , l₂) with IsTotalOrder.total isTO x y
least-unique isTO x y (p , l₁) (q , l₂) | inj₁ x⊑y =
  IsTotalOrder.antisym isTO x⊑y (l₂ p)
least-unique isTO x y (p , l₁) (q , l₂) | inj₂ y⊑x =
  IsTotalOrder.antisym isTO (l₁ q) y⊑x

infixr 1 _⇒_
_⇒_ = Nat

data T (V : Set) : Set where
  sup : ⟪ Σ ⟫ (T V) ⊎ V → T V

rec : ∀{V X} → (f : ⟪ Σ ⟫ X ⊎ V → X) → T V → X
rec f (sup (inj₁ (s , α))) = f (inj₁ (s , λ i → rec f (α i)))
rec f (sup (inj₂ y))       = f (inj₂ y)

rec-hom : ∀{V X} → (f : ⟪ Σ ⟫ X ⊎ V → X) (u : ⟪ Σ ⟫ (T V) ⊎ V) →
          rec f (sup u) ≡ f (Sum.map (⟪ Σ ⟫₁ (rec f)) id u)
rec-hom f (inj₁ (s , α)) = cong (λ u → f (inj₁ (s , u))) refl
rec-hom f (inj₂ v) = refl

-- | Functor T, on morphisms
T₁ : ∀ {V W} → (V → W) → T V → T W
T₁ f = rec (sup ∘ Sum.map id f)

η : Id ⇒ T
η = sup ∘ inj₂

μ : T ∘ T ⇒ T
μ {V} = rec f
  where
    f : ⟪ Σ ⟫ (T V) ⊎ T V → T V
    f = [ sup ∘ inj₁ , id ]

-- | First monad law
postulate unitᵣ : ∀{V} {t : T V} → μ (T₁ η t) ≡ t
{-
unitᵣ {V} {t} =
  begin
    μ (T₁ η t)
  ≡⟨ {!!} ⟩
    t
  ∎
-}

-- | T is free over Σ with inclusion
ι : ⟪ Σ ⟫ ⇒ T
ι = sup ∘ inj₁ ∘ ⟪ Σ ⟫₁ η

postulate T₁-top-sym : ∀{V W} (f : V → W) (s : ∥ Σ ∥) (α : ar Σ s → T V) →
             T₁ f (μ (ι (s , α))) ≡ μ (ι (s , T₁ f ∘ α))
-- T₁-top-sym = {!!}

-- | Kleisli morphsims for T∞ V
Subst : Set → Set → Set
Subst V W = V → T W

infixr 9 _•_

-- | Kleisli composition
_•_ : ∀ {U V W} → Subst V W → Subst U V → Subst U W
τ • σ = μ ∘ T₁ τ ∘ σ

-- | Application of substitutions to infinite terms
app : ∀ {V W} → Subst V W → T V → T W
app σ = μ ∘ T₁ σ

infixl 1 _≡ₛ_

_≡ₛ_ : ∀{V W} → Rel (Subst V W) _
σ ≡ₛ τ = ∀ {v} → σ v ≡ τ v

-- | Order on subsitutions
_⊑_ : ∀{V W} → Rel (Subst V W) _
σ₁ ⊑ σ₂ = ∃ λ σ → σ • σ₁ ≡ₛ σ₂

matches : ∀{V W} → T V → T W → Subst V W → Set
matches t s σ = app σ t ≡ s

-- | Most general matcher
mgm : ∀{V W} → T V → T W → Subst V W → Set
mgm t s = least _⊑_ (matches t s)

η-mgm : ∀{V} (t : T V) → mgm t t η
η-mgm {V} t = m , min t
  where
    m : matches t t η
    m =
      begin
        app η t
      ≡⟨ refl ⟩
        μ (T₁ η t)
      ≡⟨ unitᵣ ⟩
        t
      ∎

    min : {σ : Subst V V} (t : T V) → matches t t σ → η ⊑ σ
    min {σ} t m with app σ t
    min {σ} (sup (inj₁ y)) refl | sup (inj₁ .y) = σ , refl
    min (sup (inj₁ x)) () | sup (inj₂ w)
    min (sup (inj₂ v)) () | sup (inj₁ y)
    min {σ} (sup (inj₂ v)) refl | sup (inj₂ .v) = σ , refl

unifies : ∀{V W} → T V → T V → Subst V W → Set
unifies t s σ = app σ t ≡ app σ s

-- | Most general unifier
mgu : ∀{V W} → T V → T V → Subst V W → Set
mgu t s = least _⊑_ (unifies t s)

-- | Free variables
fv : ∀{V} → T V → Pred V _
fv (sup (inj₁ (s , α))) v = ⨿ (Sig.ar Σ s) λ i → (fv (α i) v)
fv (sup (inj₂ v₁))      v = v₁ ≡ v

isCons : ∀{V} → Pred (T V) _
isCons (sup (inj₁ x)) = ⊤
isCons (sup (inj₂ y)) = ⊥

isVar : ∀{V} → Pred (T V) _
isVar (sup (inj₁ x)) = ⊥
isVar (sup (inj₂ y)) = ⊤

record T∞ (V : Set) : Set where
  coinductive
  field out : ⟪ Σ ⟫ (T∞ V) ⊎ V
open T∞ public

sum-lift : {A B : Set} (R₁ : A → A → Set) (R₂ : B → B → Set) (x y : A ⊎ B) → Set
sum-lift R₁ R₂ (inj₁ x) (inj₁ y) = R₁ x y
sum-lift R₁ R₂ (inj₁ x) (inj₂ y) = ⊥
sum-lift R₁ R₂ (inj₂ x) (inj₁ y) = ⊥
sum-lift R₁ R₂ (inj₂ x) (inj₂ y) = R₂ x y

~-data : ∀{V} (R : T∞ V → T∞ V → Set) (u w : ⟪ Σ ⟫ (T∞ V) ⊎ V) → Set
~-data R = sum-lift (sig-lift R) _≡_

record _~_ {V : Set} (t s : T∞ V) : Set where
  coinductive
  field out~ : ~-data _~_ (out t) (out s)
open _~_ public

corec : ∀{V X} → (f : X → ⟪ Σ ⟫ X ⊎ V) → X → T∞ V
out (corec f x) with f x
... | inj₁ (s , α) = inj₁ (s , (λ i → corec f (α i)))
... | inj₂ v       = inj₂ v

prim-corec : ∀{V X} → (f : X → ⟪ Σ ⟫ X ⊎ V ⊎ T∞ V) → X → T∞ V
out (prim-corec {V} {X} f x) with f x
... | inj₁ (s , α)  = inj₁ (s , (λ i → prim-corec f (α i)))
... | inj₂ (inj₁ v) = inj₂ v
... | inj₂ (inj₂ t) = out t

sup∞ : ∀{V} → ⟪ Σ ⟫ (T∞ V) ⊎ V → T∞ V
out (sup∞ (inj₁ u)) = inj₁ u
out (sup∞ (inj₂ v)) = inj₂ v

-- | Functor T∞, on morphisms
T∞₁ : ∀ {V W} → (V → W) → T∞ V → T∞ W
T∞₁ f = corec (Sum.map id f ∘ out)

η∞ : Id ⇒ T∞
η∞ = sup∞ ∘ inj₂

μ∞ : T∞ ∘ T∞ ⇒ T∞
μ∞ {V} = corec f
  where
    g : T∞ V → ⟪ Σ ⟫ (T∞ (T∞ V)) ⊎ V
    g = Sum.map (⟪ Σ ⟫₁ η∞) id ∘ out

    f : T∞ (T∞ V) → ⟪ Σ ⟫ (T∞ (T∞ V)) ⊎ V
    f = [ inj₁ , g ] ∘ out

ι∞ : ⟪ Σ ⟫ ⇒ T∞
ι∞ {V} = g ∘ inj₁
  where
    g : ⟪ Σ ⟫ V ⊎ T∞ V → T∞ V
    g = prim-corec [ inj₁ ∘ ⟪ Σ ⟫₁ (inj₂ ∘ η∞) , inj₂ ∘ inj₂ ]

-- | T is a submonad of T∞
χ : T ⇒ T∞
χ = rec sup∞

-- | Kleisli morphsims for T∞ V
Subst∞ : Set → Set → Set
Subst∞ V W = V → T∞ W

infixl 1 _≡ₛ∞_

_≡ₛ∞_ : ∀{V W} → Rel (Subst∞ V W) _
σ ≡ₛ∞ τ = ∀ {v} → σ v ~ τ v

infixr 9 _•∞_

-- | Kleisli composition
_•∞_ : ∀ {U V W} → Subst∞ V W → Subst∞ U V → Subst∞ U W
τ •∞ σ = μ∞ ∘ T∞₁ τ ∘ σ

-- | Application of substitutions to infinite terms
app∞ : ∀ {V W} → Subst∞ V W → T∞ V → T∞ W
app∞ σ = μ∞ ∘ T∞₁ σ

isVar∞ : ∀{V} → Pred (T∞ V) _
isVar∞ t with out t
isVar∞ t | inj₁ x = ⊥
isVar∞ t | inj₂ v = ⊤

varNowOrLater : ∀{V} → (T∞ V → Pred V _) → T∞ V → Pred V _
varNowOrLater R t v with out t
... | inj₁ (f , α) = ∃ (λ i → R (α i) v)
... | inj₂ v₁      = v ≡ v₁

record fv∞ {V : Set} (t : T∞ V) (v : V) : Set where
  coinductive
  field isFv∞ : varNowOrLater fv∞ t v

root-matches : ∀{V} → T V → ∥ Σ ∥ → Set
root-matches (sup (inj₁ (g , _))) f = g ≡ f
root-matches (sup (inj₂ y))       f = ⊥

record RootsMatch {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) : Set where
  coinductive
  field
    hd-match : root-matches (hd s) f
    tl-match : RootsMatch (tl s) f
open RootsMatch

-- | Nasty hack: assume that RootsMatch is propositional
postulate
  RootsMatch-unique : ∀{V} {s : Stream (T V)} {f : ∥ Σ ∥}
                      (p q : RootsMatch s f) → p ≡ q

split : {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) → RootsMatch s f →
        ar Σ f → Stream (T V)
hd (split s f p i) with hd s | hd-match p
hd (split s f p i) | sup (inj₁ (.f , α)) | refl = α i
hd (split s f p i) | sup (inj₂ y) | ()
tl (split s f p i) = split (tl s) f (tl-match p) i

root-matches∞ : ∀{V} → T∞ V → ∥ Σ ∥ → Set
root-matches∞ t f with out t
root-matches∞ t f | inj₁ (g , _) = f ≡ g
root-matches∞ t f | inj₂ v       = ⊥

split∞ : {V : Set} → (t : T∞ V) (f : ∥ Σ ∥) → root-matches∞ t f →
        ar Σ f → T∞ V
split∞ t f p i with out t
split∞ t f refl i | inj₁ (.f , α) = α i
split∞ t f ()   i | inj₂ y

data AnyRootMatch {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) : Stream (T V) → Set where
  match-hd : root-matches (hd s) f → AnyRootMatch s f s
  match-tl : AnyRootMatch (tl s) f (tl s) → AnyRootMatch s f (tl s)

first-root-match : ∀{V} → Stream (T V) → ∥ Σ ∥ → ℕ → Set
first-root-match s f = least _≤_ (λ k → root-matches (s at k) f)

conv-branch : {V : Set} (R : Stream (T V) → T∞ V → Set) →
               Stream (T V) → T∞ V → T V → ⟪ Σ ⟫ (T∞ V) ⊎ V → Set
conv-branch R s t (sup (inj₁ (f , α))) (inj₁ (g , β)) =
  ⨿ (f ≡ g) λ p →
  ⨿ (RootsMatch (tl s) f) λ q →
  ∀ i → R (split (tl s) f q i) (β (subst (ar Σ) p i))
conv-branch R s t (sup (inj₁ (f , α))) (inj₂ v) = ⊥
conv-branch R s t (sup (inj₂ v)) (inj₁ (f , α)) =
  ∃ λ s' → AnyRootMatch s f s' × R s' t
conv-branch R s t (sup (inj₂ v)) (inj₂ w) = v ≡ w × R (tl s) t

-- | A sequence s of finite terms converges to a possibly infinite term,
-- if for all i, sᵢ₊₁ = sᵢ[σ] for some substitution σ : V → T V and t = sᵢ[τ]
-- for some τ : V → T∞ V.
-- Note that this coincides with convergence in the prefix metric.
record _→∞_ {V : Set} (s : Stream (T V)) (t : T∞ V) : Set where
  coinductive
  field
    conv-out : conv-branch _→∞_ s t (hd s) (out t)
open _→∞_ public

{-
unique-conv : ∀{V} (s : Stream (T V)) (t₁ t₂ : T∞ V) →
              s →∞ t₁ → s →∞ t₂ → t₁ ~ t₂
-}

ProperlyRefining : ∀{V} → T V → Pred (Subst V V) _
ProperlyRefining t σ = ∀ v → v ∈ fv t → isCons (σ v)

record ProperlyRefiningSeq {V : Set} (t : T V) : Set where
  coinductive
  field
    hd-ref : Subst V V
    hd-is-ref : hd-ref ∈ ProperlyRefining t
    tl-ref : ProperlyRefiningSeq (app hd-ref t)
open ProperlyRefiningSeq public

{-

refining-on-subterms : ∀{V f α} (t : T V) → t ≡ sup (inj₁ (f , α)) →
                       ProperlyRefiningSeq t →
                       (i : ar Σ f) → ProperlyRefiningSeq (α i)
hd-ref    (refining-on-subterms ._ refl p i) = hd-ref p
hd-is-ref (refining-on-subterms ._ refl p i) = {!!}
tl-ref    (refining-on-subterms ._ refl p i) = {!!} -- refining-on-subterms {!!} {!!} {!!} {!!}

-- | A non-trivial substitution is a substitution σ, such that, for all v ∈ V
-- we have that either σ(v) is a non-trivial term or if it is a variable w, then
-- w = v.
-- This allows us to stop substituting the first time we hit a variable.
NonTrivSubst : Set → Set
NonTrivSubst V = ⨿ (Subst V V) λ σ → (∀ v → isVar (σ v) → σ v ≡ η v)

term-seq-from-subst-seq : ∀{V} (t : T V) → ProperlyRefiningSeq t → Stream (T V)
hd (term-seq-from-subst-seq t Δ) = t
tl (term-seq-from-subst-seq t Δ) =
  term-seq-from-subst-seq (app (hd-ref Δ) t) (tl-ref Δ)

var-app-lem : ∀{V} → (σ : Subst V V) → ∀ v → app σ (η v) ≡ σ v
var-app-lem = {!!}

∞term-from-subst-seq : ∀{V} (t : T V) → ProperlyRefiningSeq t → T∞ V
out (∞term-from-subst-seq {V} (sup (inj₁ (f , α))) Δ) = inj₁ (f , β)
  where
    β : ar Σ f → T∞ V
    β i = ∞term-from-subst-seq
          (α i)
          (refining-on-subterms (sup (inj₁ (f , α))) refl Δ i)
out (∞term-from-subst-seq {V} (sup (inj₂ v)) Δ) = {!!}
--  with fv (sup (inj₂ v)) v | hd-ref Δ v | hd-is-ref Δ v refl
  where
    g : ∀{σ} → σ ∈ ProperlyRefining (sup (inj₂ v)) → ⟪ Σ ⟫ (T∞ V)
    g {σ} p with σ v | p v refl
    g p | sup (inj₁ (f , α)) | tt = f , β
      where
        β : ar Σ f → T∞ V
        β i = ∞term-from-subst-seq
              (α i)
              (refining-on-subterms (sup (inj₁ (f , α)))
                                    refl
                                    {!!}
                                    i)
    g p | sup (inj₂ w) | ()

-}

{-

out (∞term-from-subst-seq {V} (sup (inj₂ v)) Δ) | p | sup (inj₁ (f , α)) | tt =
  inj₁ (f , β {!refl!})
  where
    foo : hd-ref Δ v ≡ sup (inj₁ (f , α)) → app (hd-ref Δ) (sup (inj₂ v)) ≡ sup (inj₁ (f , α))
    foo p =
      begin
        app (hd-ref Δ) (sup (inj₂ v))
      ≡⟨ {!!} ⟩
        hd-ref Δ v
      ≡⟨ {!refl!} ⟩
        sup (inj₁ (f , α))
      ∎

    β : hd-ref Δ v ≡ sup (inj₁ (f , α)) → ar Σ f → T∞ V
    β p i = ∞term-from-subst-seq
            (α i)
            (refining-on-subterms (sup (inj₁ (f , α)))
                                  refl
                                  (subst ProperlyRefiningSeq {!!} (tl-ref Δ))
                                  i)
          -- (app (hd-ref Δ) (η v)) (var-app-lem {!!} v)
out (∞term-from-subst-seq (sup (inj₂ v)) Δ) | p | sup (inj₂ y) | ()
-}

{-
∞term-from-subst-seq : ∀{V} → Stream (NonTrivSubst V) → T V → T∞ V
out (∞term-from-subst-seq Δ (sup (inj₁ (s , α)))) =
  inj₁ (s , (λ i → ∞term-from-subst-seq Δ (α i)))
out (∞term-from-subst-seq Δ (sup (inj₂ v))) with proj₁ (hd Δ) v | proj₂ (hd Δ) v
... | sup (inj₁ (s , α)) | f =
  inj₁ (s , (λ i → ∞term-from-subst-seq (tl Δ) (α i)))
... | sup (inj₂ v₁)      | f with f tt
out (∞term-from-subst-seq Δ (sup (inj₂ v))) | sup (inj₂ .v) | f | refl =
  inj₂ v
-}

{-
∞term-from-subst-seq-converges :
  ∀{V} → (Δ : Stream (NonTrivSubst V)) → (t : T V) →
  term-seq-from-subst-seq Δ t →∞ ∞term-from-subst-seq Δ t
-}


{-# OPTIONS --rewriting --confluence-check #-}
module Issue4333.M where

postulate
  A : Set
  _==_ : A → A → Set
{-# BUILTIN REWRITE _==_ #-}

postulate
  a a₀' a₁' : A
  p₀ : a == a₀'
  p₁ : a == a₁'
  B : A → Set
  b : B a


module Examples.OpSem where

open import Luau.OpSem using (_⊢_⟶ᴱ_⊣_; _⊢_⟶ᴮ_⊣_; subst)
open import Luau.Syntax using (var; nil; local_←_; _∙_; done; return)
open import Luau.Heap using (emp)

x = var "x"

ex1 : emp ⊢ (local "x" ← nil ∙ return x ∙ done) ⟶ᴮ (return nil ∙ done) ⊣ emp
ex1 = subst


module BabyAgda where
data Nat : Set where
    zero : Nat
    suc : Nat -> Nat
    stuff : Nat

nonDependent : Nat -> Nat -> Nat
nonDependent a b = a

dependent : {A : Set} -> A -> A
dependent a = a

asdf : {A : Set} -> {B : Nat} -> {renameMe0 : Nat} -> Nat
asdf {_} {_} {zero} = zero
asdf {_} {_} {suc c} = dependent c


open import Relation.Binary.Core

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

open import BBHeap _≤_
open import BBHeap.Properties _≤_
open import BBHeap.Subtyping.Properties _≤_ trans≤
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Bound.Lower.Order.Properties _≤_ trans≤
open import Data.Sum renaming (_⊎_ to _∨_)
open import Order.Total _≤_ tot≤

mutual
  insert : {b : Bound}{x : A} → LeB b (val x) → BBHeap b → BBHeap b
  insert b≤x leaf = left b≤x lf⋘
  insert {x = x} b≤x (left {x = y} b≤y l⋘r)
      with tot≤ x y
  ... | inj₁ x≤y
      with lemma-insert⋘ (lexy refl≤) l⋘r
  ... | inj₁ lᵢ⋘r = left b≤x (subtyping⋘ (lexy x≤y) (lexy x≤y) lᵢ⋘r)
  ... | inj₂ lᵢ⋗r = right b≤x (subtyping⋙ (lexy x≤y) (lexy x≤y) (lemma⋗ lᵢ⋗r))
  insert {x = x} b≤x (left {x = y} b≤y l⋘r) | inj₂ y≤x
      with lemma-insert⋘ (lexy y≤x) l⋘r
  ... | inj₁ lᵢ⋘r = left b≤y lᵢ⋘r
  ... | inj₂ lᵢ⋗r = right b≤y (lemma⋗ lᵢ⋗r)
  insert {x = x} b≤x (right {x = y} b≤y l⋙r)
      with tot≤ x y
  ... | inj₁ x≤y
      with lemma-insert⋙ (lexy refl≤) l⋙r
  ... | inj₁ l⋙rᵢ = right b≤x (subtyping⋙ (lexy x≤y) (lexy x≤y) l⋙rᵢ)
  ... | inj₂ l≃rᵢ = left b≤x (subtyping⋘ (lexy x≤y) (lexy x≤y) (lemma≃ l≃rᵢ))
  insert {x = x} b≤x (right {x = y} b≤y l⋙r) | inj₂ y≤x
      with lemma-insert⋙ (lexy y≤x) l⋙r
  ... | inj₁ l⋙rᵢ = right b≤y l⋙rᵢ
  ... | inj₂ l≃rᵢ = left b≤y (lemma≃ l≃rᵢ)

  lemma-insert⋘ : {b b' : Bound}{x : A}{h : BBHeap b}{h' : BBHeap b'} → (b≤x : LeB b (val x)) → h ⋘ h' → insert b≤x h ⋘ h' ∨ insert b≤x h ⋗ h'
  lemma-insert⋘ b≤x lf⋘ = inj₂ (⋗lf b≤x)
  lemma-insert⋘ {x = x} b≤x (ll⋘ {x = y} b≤y b'≤y' l⋘r l'⋘r' l'≃r' r≃l')
      with tot≤ x y
  ... | inj₁ x≤y
      with lemma-insert⋘ (lexy refl≤) l⋘r
  ... | inj₁ lᵢ⋘r = inj₁ (ll⋘ b≤x b'≤y' (subtyping⋘ (lexy x≤y) (lexy x≤y) lᵢ⋘r) l'⋘r' l'≃r' (subtyping≃l (lexy x≤y) r≃l'))
  ... | inj₂ lᵢ⋗r = inj₁ (lr⋘ b≤x b'≤y' (subtyping⋙ (lexy x≤y) (lexy x≤y) (lemma⋗ lᵢ⋗r)) l'⋘r' l'≃r' (subtyping⋗l (lexy x≤y) (lemma⋗≃ lᵢ⋗r r≃l')))
  lemma-insert⋘ {x = x} b≤x (ll⋘ {x = y} b≤y b'≤y' l⋘r l'⋘r' l'≃r' r≃l') | inj₂ y≤x
      with lemma-insert⋘ (lexy y≤x) l⋘r
  ... | inj₁ lᵢ⋘r = inj₁ (ll⋘ b≤y b'≤y' lᵢ⋘r l'⋘r' l'≃r' r≃l')
  ... | inj₂ lᵢ⋗r = inj₁ (lr⋘ b≤y b'≤y' (lemma⋗ lᵢ⋗r) l'⋘r' l'≃r' (lemma⋗≃ lᵢ⋗r r≃l'))
  lemma-insert⋘ {x = x} b≤x (lr⋘ {x = y} b≤y b'≤y' l⋙r l'⋘r' l'≃r' l⋗l')
      with tot≤ x y
  ... | inj₁ x≤y
      with lemma-insert⋙ (lexy refl≤) l⋙r
  ... | inj₁ l⋙rᵢ = inj₁ (lr⋘ b≤x b'≤y' (subtyping⋙ (lexy x≤y) (lexy x≤y) l⋙rᵢ) l'⋘r' l'≃r' (subtyping⋗l (lexy x≤y) l⋗l'))
  ... | inj₂ l≃rᵢ = inj₂ (⋗nd b≤x b'≤y' (subtyping⋘ (lexy x≤y) (lexy x≤y) (lemma≃ l≃rᵢ)) l'⋘r' (subtyping≃ (lexy x≤y) (lexy x≤y) l≃rᵢ) l'≃r' (subtyping⋗l (lexy x≤y) l⋗l'))
  lemma-insert⋘ {x = x} b≤x (lr⋘ {x = y} b≤y b'≤y' l⋙r l'⋘r' l'≃r' l⋗l') | inj₂ y≤x
      with lemma-insert⋙ (lexy y≤x) l⋙r
  ... | inj₁ l⋙rᵢ = inj₁ (lr⋘ b≤y b'≤y' l⋙rᵢ l'⋘r' l'≃r' l⋗l')
  ... | inj₂ l≃rᵢ = inj₂ (⋗nd b≤y b'≤y' (lemma≃ l≃rᵢ) l'⋘r' l≃rᵢ l'≃r' l⋗l')

  lemma-insert⋙ : {b b' : Bound}{x : A}{h : BBHeap b}{h' : BBHeap b'} → (b'≤x : LeB b' (val x)) → h ⋙ h' → h ⋙ insert b'≤x h' ∨ h ≃ insert b'≤x h'
  lemma-insert⋙ {x = x} b'≤x (⋙lf {x = y} b≤y) = inj₂ (≃nd b≤y b'≤x lf⋘ lf⋘ ≃lf ≃lf ≃lf)
  lemma-insert⋙ {x = x} b'≤x (⋙rl {x' = y'} b≤y b'≤y' l⋘r l≃r l'⋘r' l⋗r')
      with tot≤ x y'
  ... | inj₁ x≤y'
      with lemma-insert⋘ (lexy refl≤) l'⋘r'
  ... | inj₁ l'ᵢ⋘r' = inj₁ (⋙rl b≤y b'≤x l⋘r l≃r (subtyping⋘ (lexy x≤y') (lexy x≤y') l'ᵢ⋘r') (subtyping⋗r (lexy x≤y') l⋗r'))
  ... | inj₂ l'ᵢ⋗r' = inj₁ (⋙rr b≤y b'≤x l⋘r l≃r (subtyping⋙ (lexy x≤y') (lexy x≤y') (lemma⋗ l'ᵢ⋗r')) (subtyping≃r (lexy x≤y') (lemma⋗⋗ l⋗r' l'ᵢ⋗r')))
  lemma-insert⋙ {x = x} b'≤x (⋙rl {x' = y'} b≤y b'≤y' l⋘r l≃r l'⋘r' l⋗r') | inj₂ y'≤x
      with lemma-insert⋘ (lexy y'≤x) l'⋘r'
  ... | inj₁ l'ᵢ⋘r' = inj₁ (⋙rl b≤y b'≤y' l⋘r l≃r l'ᵢ⋘r' l⋗r')
  ... | inj₂ l'ᵢ⋗r' = inj₁ (⋙rr b≤y b'≤y' l⋘r l≃r (lemma⋗ l'ᵢ⋗r') (lemma⋗⋗ l⋗r' l'ᵢ⋗r'))
  lemma-insert⋙ {x = x} b'≤x (⋙rr {x' = y'} b≤y b'≤y' l⋘r l≃r l'⋙r' l≃l')
      with tot≤ x y'
  ... | inj₁ x≤y'
      with lemma-insert⋙ (lexy refl≤) l'⋙r'
  ... | inj₁ l'⋙r'ᵢ = inj₁ (⋙rr b≤y b'≤x l⋘r l≃r (subtyping⋙ (lexy x≤y') (lexy x≤y') l'⋙r'ᵢ) (subtyping≃r (lexy x≤y') l≃l'))
  ... | inj₂ l'≃r'ᵢ = inj₂ (≃nd b≤y b'≤x l⋘r (subtyping⋘ (lexy x≤y') (lexy x≤y') (lemma≃ l'≃r'ᵢ)) l≃r (subtyping≃ (lexy x≤y') (lexy x≤y') l'≃r'ᵢ) (subtyping≃r (lexy x≤y') l≃l'))
  lemma-insert⋙ {x = x} b'≤x (⋙rr {x' = y'} b≤y b'≤y' l⋘r l≃r l'⋙r' l≃l') | inj₂ y'≤x
      with lemma-insert⋙ (lexy y'≤x) l'⋙r'
  ... | inj₁ l'⋙r'ᵢ = inj₁ (⋙rr b≤y b'≤y' l⋘r l≃r l'⋙r'ᵢ l≃l')
  ... | inj₂ l'≃r'ᵢ = inj₂ (≃nd b≤y b'≤y' l⋘r (lemma≃ l'≃r'ᵢ) l≃r l'≃r'ᵢ l≃l')


------------------------------------------------------------------------
-- The Agda standard library
--
-- The lifting of a strict order to incorporate new extrema
------------------------------------------------------------------------

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

-- This module is designed to be used with
-- Relation.Nullary.Construct.Add.Extrema

open import Relation.Binary

module Relation.Binary.Construct.Add.Extrema.Strict
  {a ℓ} {A : Set a} (_<_ : Rel A ℓ) where

open import Level
open import Function
open import Relation.Nullary

import Relation.Nullary.Construct.Add.Infimum as I
open import Relation.Nullary.Construct.Add.Extrema
import Relation.Binary.Construct.Add.Infimum.Strict as AddInfimum
import Relation.Binary.Construct.Add.Supremum.Strict as AddSupremum
import Relation.Binary.Construct.Add.Extrema.Equality as Equality
import Relation.Binary.Construct.Add.Extrema.NonStrict as NonStrict

------------------------------------------------------------------------
-- Definition

private
  module Inf = AddInfimum _<_
  module Sup = AddSupremum Inf._<₋_

open Sup using () renaming (_<⁺_ to _<±_) public

------------------------------------------------------------------------
-- Useful pattern synonyms

pattern ⊥±<[_] l = Sup.[ Inf.⊥₋<[ l ] ]
pattern [_] p    = Sup.[ Inf.[ p ] ]
pattern ⊥±<⊤±    = Sup.[ I.⊥₋ ]<⊤⁺
pattern [_]<⊤± k = Sup.[ I.[ k ] ]<⊤⁺

------------------------------------------------------------------------
-- Relational properties

[<]-injective : ∀ {k l} → [ k ] <± [ l ] → k < l
[<]-injective = Inf.[<]-injective ∘′ Sup.[<]-injective

<±-asym : Asymmetric _<_ → Asymmetric _<±_
<±-asym = Sup.<⁺-asym ∘′ Inf.<₋-asym

<±-trans : Transitive _<_ → Transitive _<±_
<±-trans = Sup.<⁺-trans ∘′ Inf.<₋-trans

<±-dec : Decidable _<_ → Decidable _<±_
<±-dec = Sup.<⁺-dec ∘′ Inf.<₋-dec

<±-irrelevant : Irrelevant _<_ → Irrelevant _<±_
<±-irrelevant = Sup.<⁺-irrelevant ∘′ Inf.<₋-irrelevant

module _ {e} {_≈_ : Rel A e} where

  open Equality _≈_

  <±-cmp : Trichotomous _≈_ _<_ → Trichotomous _≈±_ _<±_
  <±-cmp = Sup.<⁺-cmp ∘′ Inf.<₋-cmp

  <±-irrefl : Irreflexive _≈_ _<_ → Irreflexive _≈±_ _<±_
  <±-irrefl = Sup.<⁺-irrefl ∘′ Inf.<₋-irrefl

  <±-respˡ-≈± : _<_ Respectsˡ _≈_ → _<±_ Respectsˡ _≈±_
  <±-respˡ-≈± = Sup.<⁺-respˡ-≈⁺ ∘′ Inf.<₋-respˡ-≈₋

  <±-respʳ-≈± : _<_ Respectsʳ _≈_ → _<±_ Respectsʳ _≈±_
  <±-respʳ-≈± = Sup.<⁺-respʳ-≈⁺ ∘′ Inf.<₋-respʳ-≈₋

  <±-resp-≈± : _<_ Respects₂ _≈_ → _<±_ Respects₂ _≈±_
  <±-resp-≈± = Sup.<⁺-resp-≈⁺ ∘′ Inf.<₋-resp-≈₋

module _ {r} {_≤_ : Rel A r} where

  open NonStrict _≤_

  <±-transʳ : Trans _≤_ _<_ _<_ → Trans _≤±_ _<±_ _<±_
  <±-transʳ = Sup.<⁺-transʳ ∘′ Inf.<₋-transʳ

  <±-transˡ : Trans _<_ _≤_ _<_ → Trans _<±_ _≤±_ _<±_
  <±-transˡ = Sup.<⁺-transˡ ∘′ Inf.<₋-transˡ

------------------------------------------------------------------------
-- Structures

module _ {e} {_≈_ : Rel A e} where

  open Equality _≈_

  <±-isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_ →
                            IsStrictPartialOrder _≈±_ _<±_
  <±-isStrictPartialOrder =
    Sup.<⁺-isStrictPartialOrder ∘′ Inf.<₋-isStrictPartialOrder

  <±-isDecStrictPartialOrder : IsDecStrictPartialOrder _≈_ _<_ →
                               IsDecStrictPartialOrder _≈±_ _<±_
  <±-isDecStrictPartialOrder =
    Sup.<⁺-isDecStrictPartialOrder ∘′ Inf.<₋-isDecStrictPartialOrder

  <±-isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_ →
                          IsStrictTotalOrder _≈±_ _<±_
  <±-isStrictTotalOrder =
    Sup.<⁺-isStrictTotalOrder ∘′ Inf.<₋-isStrictTotalOrder


open import Function using (_∘_)
open import Data.List using (List; _++_) renaming (_∷_ to _,_; _∷ʳ_ to _,′_; [] to ∅)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (∃; _,_)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Decidable using (True; toWitness)
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl; sym; cong)

module LambekGrishinCalculus (U : Set) (R : U) (⟦_⟧ᵁ : U → Set) where

infixr 30 _⊗_ _⊕_
infixr 20 _⇒_ _⇛_
infixl 20 _⇐_ _⇚_
infix  5  _⊢_ [_]⊢_ _⊢[_]

data Polarity : Set where
  + : Polarity
  - : Polarity

_≟ᴾ_ : (p q : Polarity) → Dec (p ≡ q)
+ ≟ᴾ + = yes refl
+ ≟ᴾ - = no (λ ())
- ≟ᴾ + = no (λ ())
- ≟ᴾ - = yes refl

data Type : Set where
  el   : (A : U) → (p : Polarity) → Type
  _⊗_  : Type → Type → Type
  _⇒_  : Type → Type → Type
  _⇐_  : Type → Type → Type
  _⊕_  : Type → Type → Type
  _⇚_  : Type → Type → Type
  _⇛_  : Type → Type → Type

data Pos : Type → Set where
  el : ∀ A → Pos (el A +)
  _⊗_ : ∀ A B → Pos (A ⊗ B)
  _⇚_ : ∀ B A → Pos (B ⇚ A)
  _⇛_ : ∀ A B → Pos (A ⇛ B)

Pos? : ∀ A → Dec (Pos A)
Pos? (el A +) = yes (el A)
Pos? (el A -) = no (λ ())
Pos? (A ⊗ B) = yes (A ⊗ B)
Pos? (A ⇒ B) = no (λ ())
Pos? (A ⇐ B) = no (λ ())
Pos? (A ⊕ B) = no (λ ())
Pos? (A ⇚ B) = yes (A ⇚ B)
Pos? (A ⇛ B) = yes (A ⇛ B)

data Neg : Type → Set where
  el : ∀ A → Neg (el A -)
  _⊕_ : ∀ A B → Neg (A ⊕ B)
  _⇒_ : ∀ A B → Neg (A ⇒ B)
  _⇐_ : ∀ B A → Neg (B ⇐ A)

Neg? : ∀ A → Dec (Neg A)
Neg? (el A +) = no (λ ())
Neg? (el A -) = yes (el A)
Neg? (A ⊗ B) = no (λ ())
Neg? (A ⇒ B) = yes (A ⇒ B)
Neg? (A ⇐ B) = yes (A ⇐ B)
Neg? (A ⊕ B) = yes (A ⊕ B)
Neg? (A ⇚ B) = no (λ ())
Neg? (A ⇛ B) = no (λ ())

Pol? : ∀ A → Pos A ⊎ Neg A
Pol? (el A +)  = inj₁ (el A)
Pol? (el A -)  = inj₂ (el A)
Pol? (A ⊗ B)   = inj₁ (A ⊗ B)
Pol? (A ⇚ B)  = inj₁ (A ⇚ B)
Pol? (A ⇛ B)  = inj₁ (A ⇛ B)
Pol? (A ⊕ B)   = inj₂ (A ⊕ B)
Pol? (A ⇒ B)  = inj₂ (A ⇒ B)
Pol? (A ⇐ B)  = inj₂ (A ⇐ B)

mutual
  data Struct+ : Set where
    ·_·  : Type → Struct+
    _⊗_  : Struct+ → Struct+ → Struct+
    _⇚_  : Struct+ → Struct- → Struct+
    _⇛_  : Struct- → Struct+ → Struct+

  data Struct- : Set where
    ·_·  : Type → Struct-
    _⊕_  : Struct- → Struct- → Struct-
    _⇒_  : Struct+ → Struct- → Struct-
    _⇐_  : Struct- → Struct+ → Struct-

mutual
  data _⊢[_] : Struct+ → Type → Set where
    var    : ∀ {A} → · A · ⊢[ A ]
    μ      : ∀ {X A} {p : True (Neg? A)} → X ⊢ · A · → X ⊢[ A ]
    ⊗R     : ∀ {X Y A B} → X ⊢[ A ] → Y ⊢[ B ] → X ⊗ Y ⊢[ A ⊗ B ]
    ⇚R    : ∀ {X Y A B} → X ⊢[ A ] → [ B ]⊢ Y → X ⇚ Y ⊢[ A ⇚ B ]
    ⇛R    : ∀ {X Y A B} → [ A ]⊢ X → Y ⊢[ B ] → X ⇛ Y ⊢[ A ⇛ B ]

  data [_]⊢_ : Type → Struct- → Set where
    covar  : ∀ {A} → [ A ]⊢ · A ·
    μ̃      : ∀ {X A} {p : True (Pos? A)} → · A · ⊢ X → [ A ]⊢ X
    ⊕L     : ∀ {X Y A B} → [ A ]⊢ Y → [ B ]⊢ X → [ A ⊕ B ]⊢ X ⊕ Y
    ⇒L    : ∀ {X Y A B} → X ⊢[ A ] → [ B ]⊢ Y → [ A ⇒ B ]⊢ X ⇒ Y
    ⇐L    : ∀ {X Y A B} → [ A ]⊢ Y → X ⊢[ B ] → [ A ⇐ B ]⊢ Y ⇐ X

  data _⊢_ : Struct+ → Struct- → Set where
    μ*     : ∀ {X A} {p : True (Pos? A)} → X ⊢[ A ] → X ⊢ · A ·
    μ̃*     : ∀ {X A} {p : True (Neg? A)}→ [ A ]⊢ X → · A · ⊢ X
    ⊗L     : ∀ {X A B} → · A · ⊗ · B · ⊢ X → · A ⊗ B · ⊢ X
    ⇚L    : ∀ {X A B} → · A · ⇚ · B · ⊢ X → · A ⇚ B · ⊢ X
    ⇛L    : ∀ {X A B} → · A · ⇛ · B · ⊢ X → · A ⇛ B · ⊢ X
    ⊕R     : ∀ {X A B} → X ⊢ · A · ⊕ · B · → X ⊢ · A ⊕ B ·
    ⇒R    : ∀ {X A B} → X ⊢ · A · ⇒ · B · → X ⊢ · A ⇒ B ·
    ⇐R    : ∀ {X A B} → X ⊢ · A · ⇐ · B · → X ⊢ · A ⇐ B ·
    res₁   : ∀ {X Y Z} → Y ⊢ X ⇒ Z → X ⊗ Y ⊢ Z
    res₂   : ∀ {X Y Z} → X ⊗ Y ⊢ Z → Y ⊢ X ⇒ Z
    res₃   : ∀ {X Y Z} → X ⊢ Z ⇐ Y → X ⊗ Y ⊢ Z
    res₄   : ∀ {X Y Z} → X ⊗ Y ⊢ Z → X ⊢ Z ⇐ Y
    dres₁  : ∀ {X Y Z} → Z ⇚ X ⊢ Y → Z ⊢ Y ⊕ X
    dres₂  : ∀ {X Y Z} → Z ⊢ Y ⊕ X → Z ⇚ X ⊢ Y
    dres₃  : ∀ {X Y Z} → Y ⇛ Z ⊢ X → Z ⊢ Y ⊕ X
    dres₄  : ∀ {X Y Z} → Z ⊢ Y ⊕ X → Y ⇛ Z ⊢ X
    dist₁  : ∀ {X Y Z W} → X ⊗ Y ⊢ Z ⊕ W → X ⇚ W ⊢ Z ⇐ Y
    dist₂  : ∀ {X Y Z W} → X ⊗ Y ⊢ Z ⊕ W → Y ⇚ W ⊢ X ⇒ Z
    dist₃  : ∀ {X Y Z W} → X ⊗ Y ⊢ Z ⊕ W → Z ⇛ X ⊢ W ⇐ Y
    dist₄  : ∀ {X Y Z W} → X ⊗ Y ⊢ Z ⊕ W → Z ⇛ Y ⊢ X ⇒ W

raise : ∀ {A B} → · A · ⊢ · (B ⇐ A) ⇒ B ·
raise = ⇒R (res₂ (res₃ (μ̃* (⇐L covar var))))

lower : ∀ {A B} → · B ⇚ (A ⇛ B) · ⊢ · A ·
lower = ⇚L (dres₂ (dres₃ (μ* (⇛R covar var))))

import IntuitionisticLogic U ⟦_⟧ᵁ as IL
open IL.Explicit hiding ([_]; _⊢_; reify)
import LinearLogic U R ⟦_⟧ᵁ as LP
open LP renaming (Type to TypeLP; _⊢_ to _⊢LP_; [_] to reifyLP)

mutual
  ⟦_⟧+ : Type → TypeLP
  ⟦ el A +  ⟧+ = el A
  ⟦ el A -  ⟧+ = ¬ (¬ el A)
  ⟦ A ⊗ B   ⟧+ =      ⟦ A ⟧+ ⊗ ⟦ B ⟧+
  ⟦ A ⇚ B  ⟧+ =      ⟦ A ⟧+ ⊗ ⟦ B ⟧-
  ⟦ A ⇛ B  ⟧+ =      ⟦ A ⟧- ⊗ ⟦ B ⟧+
  ⟦ A ⊕ B   ⟧+ = ¬ (  ⟦ A ⟧- ⊗ ⟦ B ⟧-)
  ⟦ A ⇒ B  ⟧+ = ¬ (  ⟦ A ⟧+ ⊗ ⟦ B ⟧-)
  ⟦ A ⇐ B  ⟧+ = ¬ (  ⟦ A ⟧- ⊗ ⟦ B ⟧+)

  ⟦_⟧- : Type → TypeLP
  ⟦ el A +  ⟧- = ¬ el A
  ⟦ el A -  ⟧- = ¬ el A
  ⟦ A ⊗ B   ⟧- = ¬ (  ⟦ A ⟧+ ⊗ ⟦ B ⟧+)
  ⟦ A ⇚ B  ⟧- = ¬ (  ⟦ A ⟧+ ⊗ ⟦ B ⟧-)
  ⟦ A ⇛ B  ⟧- = ¬ (  ⟦ A ⟧- ⊗ ⟦ B ⟧+)
  ⟦ A ⊕ B   ⟧- =      ⟦ A ⟧- ⊗ ⟦ B ⟧-
  ⟦ A ⇒ B  ⟧- =      ⟦ A ⟧+ ⊗ ⟦ B ⟧-
  ⟦ A ⇐ B  ⟧- =      ⟦ A ⟧- ⊗ ⟦ B ⟧+

mutual
  str+ : Struct+ → List TypeLP
  str+ (· A ·)   = ⟦ A ⟧+ , ∅
  str+ (A ⊗ B)   = str+ A ++ str+ B
  str+ (A ⇚ B)  = str+ A ++ str- B
  str+ (A ⇛ B)  = str- A ++ str+ B

  str- : Struct- → List TypeLP
  str- (· A ·)   = ⟦ A ⟧- , ∅
  str- (A ⊕ B)   = str- A ++ str- B
  str- (A ⇒ B)  = str+ A ++ str- B
  str- (A ⇐ B)  = str- A ++ str+ B

open Reify {{...}} using (⟦_⟧)

instance
  Struct+Reify : Reify Struct+ (List TypeLP)
  Struct+Reify = record { ⟦_⟧ = str+ }

instance
  Struct-Reify : Reify Struct- (List TypeLP)
  Struct-Reify = record { ⟦_⟧ = str- }

instance
  TypeReify : Reify Type Set
  TypeReify = record { ⟦_⟧ = λ A → ⟦ ⟦ ⟦ A ⟧+ ⟧ ⟧ }

instance
  StructReify : Reify Struct+ (List Set)
  StructReify = record { ⟦_⟧ = λ X → ⟦ ⟦ ⟦ X ⟧ ⟧ ⟧ }

Neg-≡ : ∀ {A} → Neg A → ⟦ A ⟧+ ≡ ⟦ A ⟧- ⊸ ⊥
Neg-≡ {.(el A -)} (el A) = refl
Neg-≡ {.(A ⊕ B)} (A ⊕ B) = refl
Neg-≡ {.(A ⇒ B)} (A ⇒ B) = refl
Neg-≡ {.(A ⇐ B)} (A ⇐ B) = refl

Pos-≡ : ∀ {A} → Pos A → ⟦ A ⟧- ≡ ⟦ A ⟧+ ⊸ ⊥
Pos-≡ {.(el A +)} (el A) = refl
Pos-≡ {.(A ⊗ B)} (A ⊗ B) = refl
Pos-≡ {.(A ⇚ B)} (A ⇚ B) = refl
Pos-≡ {.(A ⇛ B)} (A ⇛ B) = refl

mutual
  reifyʳ : ∀ {X A} → X ⊢[ A ] → ⟦ X ⟧ ⊢LP ⟦ A ⟧+
  reifyʳ var = var
  reifyʳ (μ {X} {A} {q} t) rewrite Neg-≡ (toWitness q) = abs (to-back (reify t))
  reifyʳ (⊗R {X} {Y} {A} {B} s t) = pair (reifyʳ s) (reifyʳ t)
  reifyʳ (⇚R {X} {Y} {A} {B} s t) = pair (reifyʳ s) (reifyˡ t)
  reifyʳ (⇛R {X} {Y} {A} {B} s t) = pair (reifyˡ s) (reifyʳ t)

  reifyˡ : ∀ {A Y} → [ A ]⊢ Y → ⟦ Y ⟧ ⊢LP ⟦ A ⟧-
  reifyˡ covar = var
  reifyˡ (μ̃ {X} {A} {p} t) rewrite Pos-≡ (toWitness p) = abs (reify t)
  reifyˡ (⊕L {X} {Y} {A} {B} s t) = YX↝XY ⟦ X ⟧ ⟦ Y ⟧ (pair (reifyˡ s) (reifyˡ t))
  reifyˡ (⇒L {X} {Y} {A} {B} s t) = pair (reifyʳ s) (reifyˡ t)
  reifyˡ (⇐L {X} {Y} {A} {B} s t) = pair (reifyˡ s) (reifyʳ t)

  reify  : ∀ {X Y} → X ⊢ Y → ⟦ X ⟧ ++ ⟦ Y ⟧ ⊢LP ⊥
  reify (μ* {X} {A} {p} t) rewrite Pos-≡ (toWitness p) = to-front (app var (reifyʳ t))
  reify (μ̃* {X} {A} {q} t) rewrite Neg-≡ (toWitness q) = app var (reifyˡ t)
  reify (⊗L {X} {A} {B} t) = pair-left (reify t)
  reify (⇚L {X} {A} {B} t) = pair-left (reify t)
  reify (⇛L {X} {A} {B} t) = pair-left (reify t)
  reify (⊕R {X} {A} {B} t) = pair-left′ {⟦ X ⟧} {⟦ A ⟧- } {⟦ B ⟧- } (reify t)
  reify (⇒R {X} {A} {B} t) = pair-left′ {⟦ X ⟧} {⟦ A ⟧+ } {⟦ B ⟧- } (reify t)
  reify (⇐R {X} {A} {B} t) = pair-left′ {⟦ X ⟧} {⟦ A ⟧- } {⟦ B ⟧+ } (reify t)
  reify (res₁ {X} {Y} {Z} t) rewrite sym (++-assoc ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧) = Y[XZ]↝X[YZ] ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ (reify t)
  reify (res₂ {X} {Y} {Z} t) rewrite      ++-assoc ⟦ Y ⟧ ⟦ X ⟧ ⟦ Z ⟧  = [YX]Z↝[XY]Z ⟦ Y ⟧ ⟦ X ⟧ ⟦ Z ⟧ (reify t)
  reify (res₃ {X} {Y} {Z} t) rewrite sym (++-assoc ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧) = X[ZY]↝X[YZ] ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ (reify t)
  reify (res₄ {X} {Y} {Z} t) rewrite      ++-assoc ⟦ X ⟧ ⟦ Z ⟧ ⟦ Y ⟧  = [XZ]Y↝[XY]Z ⟦ X ⟧ ⟦ Z ⟧ ⟦ Y ⟧ (reify t)
  reify (dres₁ {X} {Y} {Z} t) rewrite      ++-assoc ⟦ Z ⟧ ⟦ Y ⟧ ⟦ X ⟧  = [XZ]Y↝[XY]Z ⟦ Z ⟧ ⟦ Y ⟧ ⟦ X ⟧ (reify t)
  reify (dres₂ {X} {Y} {Z} t) rewrite sym (++-assoc ⟦ Z ⟧ ⟦ X ⟧ ⟦ Y ⟧) = X[ZY]↝X[YZ] ⟦ Z ⟧ ⟦ X ⟧ ⟦ Y ⟧ (reify t)
  reify (dres₃ {X} {Y} {Z} t) rewrite      ++-assoc ⟦ Z ⟧ ⟦ Y ⟧ ⟦ X ⟧  = [YX]Z↝[XY]Z ⟦ Z ⟧ ⟦ Y ⟧ ⟦ X ⟧ (reify t)
  reify (dres₄ {X} {Y} {Z} t) rewrite sym (++-assoc ⟦ Y ⟧ ⟦ Z ⟧ ⟦ X ⟧) = Y[XZ]↝X[YZ] ⟦ Y ⟧ ⟦ Z ⟧ ⟦ X ⟧ (reify t)
  reify (dist₁ {X} {Y} {Z} {W} t) = XYZW↝XWZY ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ ⟦ W ⟧ (reify t)
  reify (dist₂ {X} {Y} {Z} {W} t) = XYZW↝YWXZ ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ ⟦ W ⟧ (reify t)
  reify (dist₃ {X} {Y} {Z} {W} t) = XYZW↝ZXWY ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ ⟦ W ⟧ (reify t)
  reify (dist₄ {X} {Y} {Z} {W} t) = XYZW↝ZYXW ⟦ X ⟧ ⟦ Y ⟧ ⟦ Z ⟧ ⟦ W ⟧ (reify t)

[_] : ∀ {X A} → X ⊢[ A ] → (Ctxt ⟦ X ⟧ → ⟦ A ⟧)
[_] = reifyLP ∘ reifyʳ


open import Coinduction using ( ∞ ; ♯_ ; ♭ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong )
open import System.IO.Transducers.Lazy using ( _⇒_ ; inp ; out ; done ; _⟫_ ; ⟦_⟧ ; _≃_ ; equiv )
open import System.IO.Transducers.Session using ( Session ; I ; Σ ; _∼_ ; ∼-refl ; ∼-trans )
open import System.IO.Transducers.Trace using ( Trace ; [] ; _∷_ )
open import System.IO.Transducers.Properties.Lemmas using ( ⟦⟧-resp-∼ ; ≃-refl ; ≃-sym ; IsEquiv ; isEquiv ; ≃-equiv ; ∷-refl-≡₁ ; ∷-refl-≡₂ )

module System.IO.Transducers.Properties.Category where

open Relation.Binary.PropositionalEquality.≡-Reasoning

infixr 6 _⟦⟫⟧_

-- Coinductive equivalence of programs, note that in the
-- case where done has type I ⇒ I, this is syntactic
-- identity.

data _⇒_⊨_≣_ : ∀ S T (P Q : S ⇒ T) → Set₁ where
  inp : ∀ {A V F T P Q} → ∞ (∀ a → ♭ F a ⇒ T ⊨ ♭ P a ≣ ♭ Q a) →
    (Σ {A} V F ⇒ T ⊨ inp P ≣ inp Q)
  out : ∀ {B W G S} b {P Q} → (S ⇒ ♭ G b ⊨ P ≣ Q) →
    (S ⇒ Σ {B} W G ⊨ out b P ≣ out b Q)
  done : ∀ {S} →
    (S ⇒ S ⊨ done ≣ done)
  inp-done : ∀ {A V F P} → ∞ (∀ a → ♭ F a ⇒ Σ V F ⊨ ♭ P a ≣ out a done) →
    (Σ {A} V F ⇒ Σ V F ⊨ inp P ≣ done)
  done-inp : ∀ {A V F P} → ∞ (∀ a → ♭ F a ⇒ Σ V F ⊨ out a done ≣ ♭ P a) →
    (Σ {A} V F ⇒ Σ V F ⊨ done ≣ inp P)

_≣_ : ∀ {S T} (P Q : S ⇒ T) → Set₁
P ≣ Q = _ ⇒ _ ⊨ P ≣ Q

-- Coinductive equivalence implies semantic equivalence

⟦⟧-resp-≣ : ∀ {S T} {P Q : S ⇒ T} → (P ≣ Q) → (⟦ P ⟧ ≃ ⟦ Q ⟧)
⟦⟧-resp-≣ (inp P≣Q) []                   = refl
⟦⟧-resp-≣ (inp P≣Q) (a ∷ as)             = ⟦⟧-resp-≣ (♭ P≣Q a) as
⟦⟧-resp-≣ (out b P≣Q) as                 = cong (_∷_ b) (⟦⟧-resp-≣ P≣Q as)
⟦⟧-resp-≣ done as                        = refl
⟦⟧-resp-≣ (inp-done P≣outadone) []       = refl
⟦⟧-resp-≣ (inp-done P≣outadone) (a ∷ as) = ⟦⟧-resp-≣ (♭ P≣outadone a) as
⟦⟧-resp-≣ (done-inp outadone≣P) []       = refl
⟦⟧-resp-≣ (done-inp outadone≣P) (a ∷ as) = ⟦⟧-resp-≣ (♭ outadone≣P a) as

-- Semantic equivalence implies coinductive equivalence

⟦⟧-refl-≣ : ∀ {S T} (P Q : S ⇒ T) → (⟦ P ⟧ ≃ ⟦ Q ⟧) → (P ≣ Q)
⟦⟧-refl-≣ (inp P)   (inp Q)    P≃Q        = inp (♯ λ a → ⟦⟧-refl-≣ (♭ P a) (♭ Q a) (λ as → P≃Q (a ∷ as)))
⟦⟧-refl-≣ (inp P)   done       P≃Q        = inp-done (♯ λ a → ⟦⟧-refl-≣ (♭ P a) (out a done) (λ as → P≃Q (a ∷ as)))
⟦⟧-refl-≣ (out b P) (out c Q)  P≃Q with ∷-refl-≡₁ refl refl (P≃Q [])
⟦⟧-refl-≣ (out b P) (out .b Q) P≃Q | refl = out b (⟦⟧-refl-≣ P Q (λ as → ∷-refl-≡₂ refl refl (P≃Q as)))
⟦⟧-refl-≣ done      (inp Q)    P≃Q        = done-inp (♯ λ a → ⟦⟧-refl-≣ (out a done) (♭ Q a) (λ as → P≃Q (a ∷ as)))
⟦⟧-refl-≣ done      done       P≃Q        = done
⟦⟧-refl-≣ (inp P)   (out b Q)  P≃Q with P≃Q []
⟦⟧-refl-≣ (inp P)   (out b Q)  P≃Q | ()
⟦⟧-refl-≣ (out b P) (inp Q)    P≃Q with P≃Q []
⟦⟧-refl-≣ (out b P) (inp Q)    P≃Q | ()
⟦⟧-refl-≣ (out b P) done       P≃Q with P≃Q []
⟦⟧-refl-≣ (out b P) done       P≃Q | ()
⟦⟧-refl-≣ done      (out b Q)  P≃Q with P≃Q []
⟦⟧-refl-≣ done      (out b Q)  P≃Q | ()

-- Trace semantics of identity

⟦done⟧ : ∀ {S} → (Trace S)  → (Trace S)
⟦done⟧ as = as

done-semantics : ∀ {S} → ⟦ done {S} ⟧ ≃ ⟦done⟧
done-semantics as = refl

-- Trace semantics of composition

_⟦⟫⟧_ : ∀ {S T U} →
  (f : Trace S → Trace T) → (g : Trace T → Trace U) →
    (Trace S) → (Trace U)
(f ⟦⟫⟧ g) as = g (f as)

⟫-semantics : ∀ {S T U} (P : S ⇒ T) (Q : T ⇒ U) →
    (⟦ P ⟫ Q ⟧ ≃ ⟦ P ⟧ ⟦⟫⟧ ⟦ Q ⟧)
⟫-semantics (inp P)   (inp Q)   []       = refl
⟫-semantics (inp P)   (inp Q)   (a ∷ as) = ⟫-semantics (♭ P a) (inp Q) as
⟫-semantics (inp P)   (out c Q) as       = cong (_∷_ c) (⟫-semantics (inp P) Q as)
⟫-semantics (inp P)   done      as       = refl
⟫-semantics (out b P) (inp Q)   as       = ⟫-semantics P (♭ Q b) as
⟫-semantics (out b P) (out c Q) as       = cong (_∷_ c) (⟫-semantics (out b P) Q as)
⟫-semantics (out b P) done      as       = refl
⟫-semantics done      Q         as       = refl

⟫-≃-⟦⟫⟧ : ∀ {S T U}
  {P : S ⇒ T} {f : Trace S → Trace T} {Q : T ⇒ U} {g : Trace T → Trace U} →
    (⟦ P ⟧ ≃ f) → (⟦ Q ⟧ ≃ g) → (⟦ P ⟫ Q ⟧ ≃ f ⟦⟫⟧ g)
⟫-≃-⟦⟫⟧ {S} {T} {U} {P} {f} {Q} {g} P≃f Q≃g as =
  begin
    ⟦ P ⟫ Q ⟧ as
  ≡⟨ ⟫-semantics P Q as ⟩
    ⟦ Q ⟧ (⟦ P ⟧ as)
  ≡⟨ cong ⟦ Q ⟧ (P≃f as) ⟩
    ⟦ Q ⟧ (f as)
  ≡⟨ Q≃g (f as) ⟩
    g (f as)
  ∎

-- Composition respects ≃

⟫-resp-≃ : ∀ {S T U} {P₁ P₂ : S ⇒ T} {Q₁ Q₂ : T ⇒ U} →
  (⟦ P₁ ⟧ ≃ ⟦ P₂ ⟧) → (⟦ Q₁ ⟧ ≃ ⟦ Q₂ ⟧) →
    (⟦ P₁ ⟫ Q₁ ⟧ ≃ ⟦ P₂ ⟫ Q₂ ⟧)
⟫-resp-≃ {S} {T} {U} {P₁} {P₂} {Q₁} {Q₂} P₁≃P₂ Q₁≃Q₂ as =
  begin
    ⟦ P₁ ⟫ Q₁ ⟧ as
  ≡⟨ ⟫-≃-⟦⟫⟧ P₁≃P₂ Q₁≃Q₂ as ⟩
    (⟦ P₂ ⟧ ⟦⟫⟧ ⟦ Q₂ ⟧) as
  ≡⟨ sym (⟫-semantics P₂ Q₂ as) ⟩
    ⟦ P₂ ⟫ Q₂ ⟧ as
  ∎

-- Left identity of composition

⟫-identity₁ : ∀ {S T} (P : S ⇒ T) → ⟦ done ⟫ P ⟧ ≃ ⟦ P ⟧
⟫-identity₁ P = ⟫-semantics done P

-- Right identity of composition

⟫-identity₂ : ∀ {S T} (P : S ⇒ T) → ⟦ P ⟫ done ⟧ ≃ ⟦ P ⟧
⟫-identity₂ P = ⟫-semantics P done

-- Associativity of composition

⟫-assoc : ∀ {S T U V} (P : S ⇒ T) (Q : T ⇒ U) (R : U ⇒ V) →
    ⟦ (P ⟫ Q) ⟫ R ⟧ ≃ ⟦ P ⟫ (Q ⟫ R) ⟧
⟫-assoc P Q R as =
  begin
    ⟦ (P ⟫ Q) ⟫ R ⟧ as
  ≡⟨ ⟫-≃-⟦⟫⟧ (⟫-semantics P Q) ≃-refl as ⟩
    (⟦ P ⟧ ⟦⟫⟧ ⟦ Q ⟧ ⟦⟫⟧ ⟦ R ⟧) as
  ≡⟨ sym (⟫-≃-⟦⟫⟧ ≃-refl (⟫-semantics Q R) as) ⟩
    ⟦ P ⟫ (Q ⟫ R) ⟧ as
  ∎

-- Identity is an equivalence

equiv-resp-done : ∀ {S} → ⟦ done ⟧ ≃ ⟦ equiv (∼-refl {S}) ⟧
equiv-resp-done {I}     as = refl
equiv-resp-done {Σ V F} [] = refl
equiv-resp-done {Σ V F} (a ∷ as) = cong (_∷_ a) (equiv-resp-done as)

done-isEquiv : ∀ {S} → IsEquiv (done {S})
done-isEquiv = isEquiv {P = done} ∼-refl equiv-resp-done

-- Composition respects being an equivalence

equiv-resp-⟦⟫⟧ : ∀ {S T U} (S∼T : S ∼ T) (T∼U : T ∼ U) →
  ⟦ equiv S∼T ⟧ ⟦⟫⟧ ⟦ equiv T∼U ⟧ ≃ ⟦ equiv (∼-trans S∼T T∼U) ⟧
equiv-resp-⟦⟫⟧ I       I        as       = refl
equiv-resp-⟦⟫⟧ (Σ W F) (Σ .W G) []       = refl
equiv-resp-⟦⟫⟧ (Σ W F) (Σ .W G) (a ∷ as) = cong (_∷_ a) (equiv-resp-⟦⟫⟧ (♭ F a) (♭ G a) as)

equiv-resp-⟫ : ∀ {S T U} (S∼T : S ∼ T) (T∼U : T ∼ U) →
  ⟦ equiv S∼T ⟫ equiv T∼U ⟧ ≃ ⟦ equiv (∼-trans S∼T T∼U) ⟧
equiv-resp-⟫ S∼T T∼U as =
  begin
    ⟦ equiv S∼T ⟫ equiv T∼U ⟧ as
  ≡⟨ ⟫-semantics (equiv S∼T) (equiv T∼U) as ⟩
    (⟦ equiv S∼T ⟧ ⟦⟫⟧ ⟦ equiv T∼U ⟧) as
  ≡⟨ equiv-resp-⟦⟫⟧ S∼T T∼U as ⟩
    ⟦ equiv (∼-trans S∼T T∼U) ⟧ as
  ∎

⟫-isEquiv : ∀ {S T U} {P : S ⇒ T} {Q : T ⇒ U} →
  (IsEquiv P) → (IsEquiv Q) → (IsEquiv (P ⟫ Q))
⟫-isEquiv {S} {T} {U} {P} {Q} (isEquiv S∼T P≃S∼T) (isEquiv (T∼U) (Q≃T∼U)) =
  isEquiv (∼-trans S∼T T∼U) λ as →
    begin
      ⟦ P ⟫ Q ⟧ as
    ≡⟨ ⟫-resp-≃ P≃S∼T Q≃T∼U as ⟩
      ⟦ equiv S∼T ⟫ equiv T∼U ⟧ as
    ≡⟨ equiv-resp-⟫ S∼T T∼U as ⟩
      ⟦ equiv (∼-trans S∼T T∼U) ⟧ as
    ∎

-- Equivalences form isos

equiv-is-iso : ∀ {S T} {P : S ⇒ T} {Q : T ⇒ S} →
  (IsEquiv P) → (IsEquiv Q) → ⟦ P ⟫ Q ⟧ ≃ ⟦ done ⟧
equiv-is-iso PisEq QisEq =
  ≃-equiv (⟫-isEquiv PisEq QisEq) done-isEquiv


{-# OPTIONS --inversion-max-depth=10 #-}

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

data ⊥ : Set where

double : Nat → Nat
double zero    = zero
double (suc n) = suc (suc (double n))

postulate
  doubleSuc : (x y : Nat) → double x ≡ suc (double y) → ⊥

diverge : ⊥
diverge = doubleSuc _ _ refl

{-
  double ?x == suc (double ?y)
    ?x := suc ?x₁
  suc (suc (double ?x₁)) == suc (double ?y)
  suc (double ?x₁) == double ?y
    ?y := suc ?y₁
  double ?x₁ == suc (double ?y₁)
  .
  .
  .
-}


module Univalence where

------------------------------------------------------------------------------
-- Basic utilities

open import LeqLemmas
open import FinNatLemmas
open import FiniteFunctions
open import VectorLemmas     -- only _!!_ and lookupassoc are needed
open import Proofs

-- Proofs is a wrapper over all the basic utilities
-- The only thing imported from now on is Proofs

------------------------------------------------------------------------------
-- Structures (Definitions)

-- We use (and extend) the package Categories.

open import Categories.Category
open import Categories.Groupoid
open import Categories.Monoidal
open import Categories.Monoidal.Helpers
open import Categories.Functor
open import Categories.Bifunctor
open import Categories.NaturalIsomorphism
open import Categories.Monoidal.Braided
open import Categories.Monoidal.Symmetric
open import Categories.RigCategory
open import Categories.Bicategory

------------------------------------------------------------------------------
-- General
--
-- We have three representations of types: Agda types, Pi types, and
-- Fin types. We have three equivalence relations between types:
-- extensional equivalences, Pi combinators, and Vec
-- permutations. Each type representation suggests a natural choice
-- for the equivalence relation:
--
-- Agda_Type <===== extensional equivalence =====> Agda_Type
-- Pi_Type   <=====      Pi combinator      =====> Pi_Type
-- Fin_Type  <=====     Vec permutation     =====> Fin_Type
--
--
------------------------------------------------------------------------------
-- Equivalences

open import Equiv
-- Defines extensional equality of functions ∼; quasi-inverses; and
-- then equivalences ≃ between spaces

open import EquivEquiv
-- Defines an extensional equivalence relation to be used to equate
-- equivalences so we can talk about equivalences up to equivalence

------------------------------------------------------------------------------
-- Equivalences between Agda types (extensional type isomorphisms)

open import TypeEquiv
-- Proves that types and type equivalences form a commutative semiring
-- in the Algebra sense

open import TypeEquivEquiv
-- All the equivalences between (type) equivalences

open import Data.Sum.Properties
-- Proves simple properties about type equivalences such as:
-- uniti₊ (unite₊ x) ≡ x

open import Data.SumProd.Properties
-- Proves simple properties about type equivalences such as:
-- distzr x ≡ distz (swap⋆ x)

open import TypeEquivCat
-- Proves that types and type equivalences form a symmetric rig
-- groupoid up to extensional equality of equivalences

------------------------------------------------------------------------------
-- Equivalences between Pi types (combinators)
--
-- Because Pi does not rely on extensionality it is easy to iterate
-- equivalences up and down. The following shows levels -2, -1, 0, and
-- 1.

open import PiU

-- First we introduce a univere U of finite types

open import PiLevelm2
open import Pim2Cat

-- A trivial relation on finite types is to identify all the types;
-- this makes U a contractible (-2)-type, i.e., a singleton.
--
-- The Pi types with the trivial relation that identifies all the
-- types form a trivial symmetric rig groupoid up to propositional
-- equality.
--
-- A (-1)-type is either empty or a singleton. The previous setup at
-- level -2 collapsed U to a singleton and hence also makes U a
-- (-1)-type

open import PiLevel0
open import Pi0Cat

-- If the relation on finite types is modeled after type isomorphisms
-- and all isomorphisms of the same type are equated, we collapse U to
-- the set of natural numbers which makes it a 0-type. (We do not
-- distinguish 'id' and 'not'.)

open import Pi0Examples

-- Pi0 is interesting as a programming language for reversible
-- circuits. This module has a few examples.

open import PiLevel1
open import Pi1Cat

-- If the relation on finite types is modeled after type isomorphisms
-- and only the isomorphisms corresponding to the coherence conditions
-- of rig categories are equated, we make U a 1-type. (We do
-- distinguish 'id' and 'not'.) The higher-level equality on the
-- 2-morphisms is trivial, i.e., all two level morphisms are
-- equated. This should yield a weak 2-category (i.e., a bicategory).

open import Pi1Examples

-- Pi1 is interesting as a programming language for reversible
-- circuits that has its own optimizer. This module has a few
-- examples.

open import PiEquiv

-- Each pi combinator is an equivalence

-- How to make U a 2-type, 3-type, etc. ???

------------------------------------------------------------------------------
-- Equivalences between Fin types (permutations)
--
-- A finite type is a set Fin n for some n. It is possible to directly
-- write permutations between finite types but this is extremely
-- tedious especially if we want to prove that we have enough
-- structure to model a symmetric rig groupoid. What we will do
-- instead is to derive these permutations from equivalences as
-- illustrated by the digram below:
--
-- Fin m <—-Equivalence-—> Fin n
--            ||
--            || Univalence
--            ||
-- Fin m <—-Permutation-—> Fin n
--
-- The vertical line is evocative of the univalence postulate: it is
-- an equivalence between equivalences and concrete identifications
-- expressed as permutations. It is relatively easy to establish the
-- symmetric rig groupoid structure in the top line and then
-- automatically transport it to the bottom line.

open import ConcretePermutation

-- Defines a permutation of a finite set 'Fin m' using two vectors of
-- the form Vec (Fin m) m. The first occurrence of m bounds the values
-- in the vector and the second bounds the length of the vector. In
-- general, a permutation 'Vec (Fin m) n' can be viewed as a function
-- that maps indices in 'Fin n' to values in 'Fin m'. To guarantee
-- that each value in Fin m occurs exactly once in the vector, the
-- representation of permutations includes two proofs that the
-- composition of the two vectors is the identity permutation (in both
-- directions). A crucial property of such permutations is that they
-- can be compared for equality using just ≡ which is elaborated on in
-- the module.
--
-- Ultimately we want to prove that finite sets and permutations form
-- a symmetric rig groupoid. Although it is possible to prove this
-- directly, it is extremely tedious. We will instead develop all the
-- infrastructure using equivalences on finite sets and transport it
-- using a specialized instance of 'univalence'.

open import FinEquivPlusTimes
open import FinEquivTypeEquiv

-- Defines the top line. We prove various equivalences between
-- Fin types like:
--   Fin (m + n) ≃ Fin m ⊎ Fin n
-- and
--   Fin (m * n) ≃ Fin m × Fin n
-- We make sure we have enough equivalences to model a commutative
-- semiring.

-- open import FinEquivEquivPlus
-- open import FinEquivEquivTimes
-- open import FinEquivEquivPlusTimes
-- open import FinEquivCat

-- Establishes that finite types and equivalences for a symmetric rig
-- groupoid. This is the structure we want to transport to permutations.

open import SEquivSCPermEquiv

-- An instance of univalence that allows us to transport all the
-- structure from FinEquivCat to permutations

-- open import CPermCat

-- Establishes that CPerm m n is a symmetric rig category by
-- transporting the structure from FinEquivCat using univalence

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Wavefront ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-- Composes previously defined equivalences to establish things like:
-- FiniteType (A ⊎ B) (m + n) ≃ FiniteType (B ⊎ A) (n + m)

-- FiniteTpyeEquivCat
-- show that Finite types and equivalences for a symmetric rig groupoid

-- define Permutation
-- should be simple definition

-- define EquivPerm
-- big thm

-- define EquivPermTransport
-- might be just an application of thm to derive the symmetric rig
-- structure on permutations

-- Finding a good representation of permutations is tricky.

-- We can compose equivalences from FinEquiv and TypeEquiv to get
-- equivalences that correspond to permutations on finite sets, e.g.,
--   Fin (m + n) ≃ Fin m ⊎ Fin n ≃ Fin n ⊎ Fin m ≃ Fin (n + m)
-- At this point these permutations are represented as extensional
-- functions. In FinVec, we represent these extensional functions
-- using the one-line notation of permutations represented in Agda as
-- the type 'Vec (Fin m) n' (which we abbreviate as 'FinVec m n').
-- The setup allows us to directly extract one-line permutations from
-- the equivalences. For example, the one-line notation for:
--   FinVec ((m + n) + o) (m + (n + o))
-- is extracted using 'tabulate' of the equivalence between:
--   Fin ((m + n) + o) and Fin (m + (n + o))
-- The fact that we have equivalences for the entire commutative
-- semiring axioms means that we also easily define the one-line
-- notation for composing permutations:
--   FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ + n₁) (m₂ + n₂)
--   FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ * n₁) (m₂ * n₂)

-- What remains now is to explicitly include proofs that the one-line
-- notation has an inverse and that the two compositions yield the
-- identity permutation. This is one in ConcretePermutation and
-- consists mostly of making explicit the proofs that are implicit in
-- FinEquiv and FinVec.

-- open import FinEquiv
-- Establishes that Fin m ≃ Fin n is a commutative semiring

-- open import ConcretePermutation
-- Establishes that CPerm m n is a commutative semiring (including
-- symmetry now)

-- open import ConcretePermutationProperties
-- Establishes properties of concrete permutations that are necessary
-- to show that it is symmetric rig category

-- open import CPermCat
-- Establishes that CPerm m n is a symmetric rig category

-- FiniteType ???
-- SCEquivSCPermEquiv ???

-- We have so far presented each instance separately. Now we focus on
-- relating the different type representations.
--

-- Now we want to relate Pi-types and type equivalences. The punchline
-- would be that TypeEquivCat is isomorphic to Pi1Cat. But the setup
-- for Pi1Cat allows us to keep going up and down the levels unlike
-- the setup for TypeEquivCat which has extensional equivalence
-- hardwired and can't be generalized to level 2.

-- Are they really really necessary as a stepping stone to prove the
-- correspondence between TypeEquivCat and Pi1Cat ???

-- Equivalences between finite sets (enumerations and permutations);
-- Equivalences between setoids; Equivalences between equivalences;
-- Unfinished files; Unused files

-- open import EnumEquiv
-- equivalence between A and Fin m is an enumeration of A

-- open import SetoidEquiv
-- do a version of EquivSetoid specialized for finite sets that
-- include an enumeration just like quasi-inverses include one
-- particular function to specify the equivalence; must really be done
-- in conjection with SEquivSCPermEquiv so let's wait until
-- dependencies satisfied...

-- open import SEquivSCPermEquiv
-- open import PiPerm
-- open import PiEquiv

-- open import SkFinSetCategory
-- open import Pim1Cat

-- open import LeftCancellation
-- Proves that ((⊤ ⊎ A) ≃ (⊤ ⊎ B)) → A ≃ B
-- open import RepresPerm
-- open import Groupoid
-- should be subsumed by Categories.Groupoid

-- Old proofs
-- open import SubstLemmas
-- open import PathLemmas

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


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
import      LibraBFT.Concrete.Properties.PreferredRound as PR

open import LibraBFT.Concrete.Obligations

-- In this module, we (will) prove the implementation obligation for the PreferredRound rule.

module LibraBFT.Impl.Properties.PreferredRound where

  postulate  -- TODO-3 : prove.  Note that this is a substantial
             -- undertaking that should not be started before we have
             -- a proof for the similar-but-much-simpler VotesOnce
             -- property, and also not before we have an
             -- implementation (perhaps some incremental extension of
             -- our current fake/simple implementaion) that we can
             -- reasonably hope actually ensures the property!
    pr₁ : PR.ImplObligation₁


{-# OPTIONS --safe  #-}
module Cubical.HITs.SetCoequalizer where

open import Cubical.HITs.SetCoequalizer.Base public
open import Cubical.HITs.SetCoequalizer.Properties public