{-# OPTIONS --without-K #-}
module Model.Exponential where

open import Cats.Category

open import Model.RGraph as RG using (RGraph)
open import Model.Type.Core
open import Model.Product
open import Util.HoTT.HLevel
open import Util.Prelude hiding (_×_ ; id ; _∘_)

open RGraph
open RG._⇒_

private
  variable Δ : RGraph

infixr 9 _↝_

Ap : ⟦Type⟧ Δ → Δ .Obj → RGraph
Ap {Δ} T δ = record
  { ObjHSet = T .ObjHSet δ
  ; eqHProp = eqHProp T (Δ .eq-refl _)
  ; eq-refl = λ x → T .eq-refl x
  }

_↝_ : (T U : ⟦Type⟧ Δ) → ⟦Type⟧ Δ
_↝_ T U = record
  { ObjHSet = λ γ → HLevel⁺ (Ap T γ RG.⇒ Ap U γ) (RG.⇒-IsSet {Ap T γ} {Ap U γ})
  ; eqHProp = λ γ≈γ′ f g
      → ∀∙-HProp λ x
      → ∀∙-HProp λ y
      → T .eqHProp γ≈γ′ x y →-HProp′ U .eqHProp γ≈γ′ (f .RG.fobj x) (g .RG.fobj y)
  ; eq-refl = λ f → f .RG.feq
  }

curry : (T U V : ⟦Type⟧ Δ)
  → T × U ⇒ V → T ⇒ U ↝ V
curry {Δ} T U V f = record
  { fobj = λ {δ} t → record
    { fobj = λ u → f .fobj (t , u)
    ; feq = λ x≈y → f .feq (Δ .eq-refl δ) (T .eq-refl t , x≈y)
    }
  ; feq = λ γ≈γ′ x≈y v≈w → f .feq γ≈γ′ (x≈y , v≈w)
  }

eval : (T U : ⟦Type⟧ Δ)
  → (T ↝ U) × T ⇒ U
eval T U = record
  { fobj = λ { (f , x) → f .RG.fobj x }
  ; feq = λ { γ≈γ′ (f≈g , x≈y) → f≈g x≈y }
  }

eval∘curry : (T U V : ⟦Type⟧ Δ) {f : T × U ⇒ V}
  → eval U V ∘ ⟨_×_⟩ {B = U} (curry T U V f) id ≈ f
eval∘curry T U V = ≈⁺ λ γ x → refl

instance
  hasExponentials : ∀ {Δ} → HasExponentials (⟦Types⟧ Δ)
  hasExponentials .HasExponentials.hasBinaryProducts = hasBinaryProducts
  hasExponentials .HasExponentials._↝′_ T U = record
    { Cᴮ = T ↝ U
    ; eval = eval T U
    ; curry′ = λ {A} f → record
      { arr = curry A T U f
      ; prop = eval∘curry A T U
      ; unique = λ {g} g-prop → ≈⁺ λ γ h → RG.≈→≡ (RG.≈⁺ λ x
          → sym (g-prop .≈⁻ γ (h , x)))
      }
    }

module ⟦Types⟧↝ {Δ} = HasExponentials (hasExponentials {Δ})

↝-resp-≈⟦Type⟧ : ∀ {Δ} (T T′ U U′ : ⟦Type⟧ Δ)
  → T ≈⟦Type⟧ T′
  → U ≈⟦Type⟧ U′
  → T ↝ U ≈⟦Type⟧ T′ ↝ U′
↝-resp-≈⟦Type⟧ {Δ} T T′ U U′ T≈T′ U≈U′
  = ⟦Types⟧↝.↝-resp-≅ {Δ} {T} {T′} {U} {U′} T≈T′ U≈U′

subT-↝ : ∀ {Γ Δ} (f : Γ RG.⇒ Δ)
  → (T U : ⟦Type⟧ Δ)
  → subT f T ↝ subT f U ≈⟦Type⟧ subT f (T ↝ U)
subT-↝ {Γ} {Δ} f T U = record
  { forth = record
    { fobj = λ g → record
      { fobj = g .fobj
      ; feq = λ {x y} x≈y → transportEq U (g .feq (transportEq T x≈y))
      }
    ; feq = λ γ≈γ′ f≈g x≈y → f≈g x≈y
    }
  ; back = record
    { fobj = λ g → record
      { fobj = g .fobj
      ; feq = λ {x y} x≈y → transportEq U (g .feq (transportEq T x≈y))
      }
    ; feq = λ γ≈γ′ f≈g x≈y → f≈g x≈y
    }
  ; back-forth = ≈⁺ λ γ x → RG.≈→≡ (RG.≈⁺ λ y → refl)
  ; forth-back = ≈⁺ λ γ x → RG.≈→≡ (RG.≈⁺ λ y → refl)
  }


module SizedIO.Object where

open import Data.Product

record Interface : Set₁ where
  field
    Method  : Set
    Result  : (m : Method) → Set
open Interface public

-- A simple object just returns for a method the response
-- and the object itself
record Object (i : Interface) : Set where
  coinductive
  field
    objectMethod : (m : Method i) → Result i m × Object i

open Object public

_▹_ : {A : Set} → {B : Set} → A → (A → B) → B
a ▹ f = f a


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

open import HoTT
open import cohomology.FunctionOver

{- The cofiber space of [winl : X → X ∨ Y] is equivalent to [Y],
 - and the cofiber space of [winr : Y → X ∨ Y] is equivalent to [X]. -}

module cohomology.WedgeCofiber where

module WedgeCofiber {i} (X Y : Ptd i) where

  module CofWinl where

    module Into = CofiberRec {f = winl} (snd Y) (projr X Y) (λ _ → idp)

    into = Into.f

    out : fst Y → Cofiber (winl {X = X} {Y = Y})
    out = cfcod ∘ winr

    out-into : (κ : Cofiber (winl {X = X} {Y = Y})) → out (into κ) == κ
    out-into = Cofiber-elim
      (! (cfglue (snd X) ∙ ap cfcod wglue))
      (Wedge-elim
        (λ x → ! (cfglue (snd X) ∙ ap cfcod wglue) ∙ cfglue x)
        (λ y → idp)
        (↓-='-from-square $
          (lemma (cfglue (snd X)) (ap cfcod wglue)
           ∙h⊡ (ap-∘ out (projr X Y) wglue ∙ ap (ap out) (Projr.glue-β X Y))
                ∙v⊡ bl-square (ap cfcod wglue))))
      (λ x → ↓-∘=idf-from-square out into $
        ! (∙-unit-r _) ∙h⊡
          ap (ap out) (Into.glue-β x) ∙v⊡
           hid-square {p = (! (cfglue' winl (snd X) ∙ ap cfcod wglue))}
           ⊡v connection {q = cfglue x})
      where
      lemma : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z)
        → ! (p ∙ q) ∙ p == ! q
      lemma idp idp = idp

    ⊙path : ⊙Cof (⊙winl {X = X} {Y = Y}) == Y
    ⊙path = ⊙ua (⊙≃-in (equiv into out (λ _ → idp) out-into) idp)

    cfcod-over : ⊙cfcod' ⊙winl == ⊙projr X Y
                 [ (λ U → fst (X ⊙∨ Y ⊙→ U)) ↓ ⊙path ]
    cfcod-over = codomain-over-⊙equiv (⊙cfcod' ⊙winl) _
                 ▹ pair= idp (∙-unit-r _ ∙ ap-! into (cfglue (snd X))
                              ∙ ap ! (Into.glue-β (snd X)))

  module CofWinr where

    module Into = CofiberRec {f = winr} (snd X) (projl X Y) (λ _ → idp)

    into = Into.f

    out : fst X → Cofiber (winr {X = X} {Y = Y})
    out = cfcod ∘ winl

    out-into : ∀ κ → out (into κ) == κ
    out-into = Cofiber-elim
      (ap cfcod wglue ∙ ! (cfglue (snd Y)))
      (Wedge-elim
        (λ x → idp)
        (λ y → (ap cfcod wglue ∙ ! (cfglue (snd Y))) ∙ cfglue y)
        (↓-='-from-square $
          (ap-∘ out (projl X Y) wglue ∙ ap (ap out) (Projl.glue-β X Y)) ∙v⊡
             connection
           ⊡h∙ ! (lemma (ap (cfcod' winr) wglue) (cfglue (snd Y)))))
      (λ y → ↓-∘=idf-from-square out into $
        ! (∙-unit-r _) ∙h⊡
          ap (ap out) (Into.glue-β y) ∙v⊡
            hid-square {p = (ap (cfcod' winr) wglue ∙ ! (cfglue (snd Y)))}
            ⊡v connection {q = cfglue y})
      where
      lemma : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : z == y)
        → (p ∙ ! q) ∙ q == p
      lemma idp idp = idp

    ⊙path : ⊙Cof ⊙winr == X
    ⊙path = ⊙ua (⊙≃-in (equiv into out (λ _ → idp) out-into) idp)

    cfcod-over : ⊙cfcod' ⊙winr == ⊙projl X Y
                 [ (λ U → fst (X ⊙∨ Y ⊙→ U)) ↓ ⊙path ]
    cfcod-over = codomain-over-⊙equiv (⊙cfcod' ⊙winr) _
                 ▹ pair= idp lemma
      where
      lemma : ap into (ap cfcod (! (! wglue)) ∙ ! (cfglue (snd Y))) ∙ idp
           == idp
      lemma =
        ap into (ap cfcod (! (! wglue)) ∙ ! (cfglue (snd Y))) ∙ idp
          =⟨ ∙-unit-r _ ⟩
        ap into (ap cfcod (! (! wglue)) ∙ ! (cfglue (snd Y)))
          =⟨ !-! wglue
             |in-ctx (λ w → ap into (ap cfcod w ∙ ! (cfglue (snd Y)))) ⟩
        ap into (ap cfcod wglue ∙ ! (cfglue (snd Y)))
          =⟨ ap-∙ into (ap cfcod wglue) (! (cfglue (snd Y))) ⟩
        ap into (ap cfcod wglue) ∙ ap into (! (cfglue (snd Y)))
          =⟨ ∘-ap into cfcod wglue
             |in-ctx (_∙ ap into (! (cfglue (snd Y)))) ⟩
        ap (projl X Y) wglue ∙ ap into (! (cfglue (snd Y)))
          =⟨ Projl.glue-β X Y
             |in-ctx (_∙ ap into (! (cfglue (snd Y)))) ⟩
        ap into (! (cfglue (snd Y)))
          =⟨ ap-! into (cfglue (snd Y)) ⟩
        ! (ap into (cfglue (snd Y)))
          =⟨ ap ! (Into.glue-β (snd Y)) ⟩
        idp ∎


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

open import Categories.Bicategory using (Bicategory)

-- The 1-cell dual (op) and 2-cell dual (co) of a given bicategory.

module Categories.Bicategory.Opposite where

open import Data.Product using (_,_)

import Categories.Bicategory.Extras as BicategoryExtras
open import Categories.Category using (Category)
import Categories.Category.Cartesian as Cartesian
import Categories.Morphism as Morphism
import Categories.Morphism.Reasoning as MorphismReasoning
open import Categories.Category.Product using (Swap)
open import Categories.Functor using (Functor; _∘F_)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; niHelper)

-- There several ways to dualize a bicategory:
--
--  * flip the 1-cells (op C), or
--  * flip the 2-cells (co C).
--  * flip both (coop C).
--
-- We implement all three.

module _ {o ℓ e t} (C : Bicategory o ℓ e t) where

  open BicategoryExtras C
  open Shorthands
  private
    module MR {A} {B} where
      open Morphism          (hom A B) public using (module ≅)
      open MorphismReasoning (hom A B) public using (switch-tofromʳ)
  open MR

  -- The 1-cell dual of C.
  --
  -- NOTE.  The definition here is specialized to the particular choice
  -- of tensor product (cartesian) and braiding (swap) used in the
  -- definition of Bicategories.  We could instead have defined the
  -- `enriched' field using the generic `op' operation defined in
  -- Categories.Enriched.Category.Opposite, but that would have resulted
  -- in much more complicated proofs of the triangle and pentagon
  -- identities.  That's because the definition of associativity and the
  -- unit laws in the generic opposite enriched category has to work for
  -- any choice of braiding and is therefore more involved.  When these
  -- laws become natural isomorphism in the definition of Bicategories,
  -- they turn into long chains consisting of mostly identity morphisms
  -- that make the types of the triangle and pentagon identities
  -- enormous.  We can avoid this by specializing the definitions of the
  -- associators and unitors below.
  --
  -- Note also that this version of `op' is almost a (definitional)
  -- involution.  The problematic fields are the triangle and pentagon
  -- identities which are not involutive on the nose.  This could be
  -- fixed by adding additional fields (in the style of `sym-assoc' in
  -- Category).  To also support `co` and `coop` would require two more
  -- variants of each equation, so there would be quite a lot of
  -- redundancy in the end.

  op : Bicategory o ℓ e t
  op = record
    { enriched = record
      { Obj = Obj
      ; hom = λ A B → hom B A
      ; id  = id
      ; ⊚   = ⊚ ∘F Swap
      ; ⊚-assoc = niHelper (record
        { η       = λ{ ((f , g) , h) → ⊚-assoc.⇐.η ((h , g) , f) }
        ; η⁻¹     = λ{ ((f , g) , h) → ⊚-assoc.⇒.η ((h , g) , f) }
        ; commute = λ{ ((α , β) , γ) → ⊚-assoc.⇐.commute ((γ , β) , α) }
        ; iso     = λ _ → record
          { isoˡ = ⊚-assoc.iso.isoʳ _ ; isoʳ = ⊚-assoc.iso.isoˡ _ }
        })
      ; unitˡ = niHelper (record
        { η       = λ{ (_ , g) → unitʳ.⇒.η (g , _) }
        ; η⁻¹     = λ{ (_ , g) → unitʳ.⇐.η (g , _) }
        ; commute = λ{ (_ , β) → unitʳ.⇒.commute (β , _) }
        ; iso     = λ{ (_ , g) → record
          { isoˡ = unitʳ.iso.isoˡ (g , _) ; isoʳ = unitʳ.iso.isoʳ (g , _) } }
        })
      ; unitʳ = niHelper (record
        { η       = λ{ (f , _) → unitˡ.⇒.η (_ , f) }
        ; η⁻¹     = λ{ (f , _) → unitˡ.⇐.η (_ , f) }
        ; commute = λ{ (α , _) → unitˡ.⇒.commute (_ , α) }
        ; iso     = λ{ (f , _) → record
          { isoˡ = unitˡ.iso.isoˡ (_ , f) ; isoʳ = unitˡ.iso.isoʳ (_ , f) } }
        })
      }
    ; triangle = λ {_ _ _ f g} → begin
        ρ⇒ ◁ g ∘ᵥ α⇐   ≈˘⟨ switch-tofromʳ (≅.sym associator) triangle ⟩
        f ▷ λ⇒         ∎
    ; pentagon = λ {_ _ _ _ _ f g h i} → begin
        α⇐ ◁ i ∘ᵥ α⇐ ∘ᵥ f ▷ α⇐     ≈˘⟨ hom.assoc ⟩
        (α⇐ ◁ i ∘ᵥ α⇐) ∘ᵥ f ▷ α⇐   ≈⟨ pentagon-inv ⟩
        α⇐ ∘ᵥ α⇐                   ∎
    }
    where open hom.HomReasoning

  -- The 2-cell dual of C.

  co : Bicategory o ℓ e t
  co = record
    { enriched = record
      { Obj     = Obj
      ; hom     = λ A B → Category.op (hom A B)
      ; id      = Functor.op id
      ; ⊚       = Functor.op ⊚
      ; ⊚-assoc = NaturalIsomorphism.op′ ⊚-assoc
      ; unitˡ   = NaturalIsomorphism.op′ unitˡ
      ; unitʳ   = NaturalIsomorphism.op′ unitʳ
      }
    ; triangle  = triangle-inv
    ; pentagon  = pentagon-inv
    }

-- The combined 1- and 2-cell dual of C.

coop : ∀ {o ℓ e t} → Bicategory o ℓ e t → Bicategory o ℓ e t
coop C = co (op C)


open import Type
open import Structure.Relator
open import Structure.Setoid renaming (_≡_ to _≡ₑ_)

module Structure.Sets.ZFC.Oper {ℓₛ ℓₗ ℓₑ} {S : Type{ℓₛ}} ⦃ equiv : Equiv{ℓₑ}(S) ⦄ (_∈_ : S → S → Type{ℓₗ}) ⦃ [∈]-binaryRelator : BinaryRelator(_∈_) ⦄ where

open import Functional using (id ; _∘₂_)
open import Functional.Dependent using (_∘_)
import      Lvl
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Properties
open import Structure.Relator.Proofs renaming ([≡]-binaryRelator to [≡ₑ]-binaryRelator)
open import Structure.Sets.ZFC(_∈_) ⦃ [∈]-binaryRelator ⦄
import      Structure.Sets.Names
open import Syntax.Function
open import Syntax.Implication

open        Structure.Sets.Names.From-[∈] (_∈_)
open        Structure.Sets.Names.Relations (_∈_)
open        Structure.Sets.Names.One                     (_∈_)
open        Structure.Sets.Names.Two                     (_∈_)(_∈_)
open        Structure.Sets.Names.TwoDifferent            (_∈_)(_∈_)
open        Structure.Sets.Names.TwoSame                 (_∈_)(_∈_)
open        Structure.Sets.Names.Three                   (_∈_)(_∈_)(_∈_)
open        Structure.Sets.Names.ThreeNestedTwoDifferent (_∈_)
open        Structure.Sets.Names.ThreeTwoNested          (_∈_)(_∈_)(_∈_)
open import Structure.Sets.Quantifiers(_∈_)
open import Structure.Sets.Quantifiers.Proofs(_∈_) ⦃ [∈]-binaryRelator ⦄

private variable ℓ : Lvl.Level
private variable A B C D E N a b c d e x y z As : S
private variable P : S → Type{ℓ}

module _ ⦃ zfc : ZFC ⦄ where
  open ZFC(zfc)

  infixl 3001 _∩_
  infixl 3002 _⨯_ _∖_

  -- Intersection operator.
  -- Constructs a set which consists of elements which are in both LHS and RHS.
  _∩_ : S → S → S
  a ∩ b = filter(_∈ b) ⦃ binary-unaryRelatorᵣ ⦄ a

  -- "Without"-operator.
  -- Constructs a set which consists of elements which are in LHS, but not RHS.
  _∖_ : S → S → S
  a ∖ b = filter(_∉ b) ⦃ [¬]-unaryRelator ⦃ rel-P = binary-unaryRelatorᵣ ⦄ ⦄ a

  -- Intersection over arbitrary sets.
  -- Constructs a set which consists of elements which are in all of the specified sets.
  ⋂ : S → S
  ⋂(As) = filter(a ↦ (∀ₛ(As) (a ∈_))) ⦃ [∀]-unaryRelator ⦃ rel-P = [→]-unaryRelator ⦃ rel-Q = binary-unaryRelatorᵣ ⦄ ⦄ ⦄ (⋃(As))

  -- Tuple value.
  -- An ordered pair of values.
  _,_ : S → S → S
  (a , b) = pair(singleton a) (pair a b)

  -- Set product (Set of tuples) (Cartesian product).
  _⨯_ : S → S → S
  A ⨯ B = filter(t ↦ ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ t ≡ₑ (a , b)))) ⦃ [∃ₛ]-unaryRelator ⦃ rel-P = [∃ₛ]-unaryRelator ⦃ rel-P = binary-unaryRelatorᵣ ⦃ rel-P = [≡ₑ]-binaryRelator ⦄ ⦄ ⦄ ⦄ (℘(℘(A ∪ B)))

  identityPair : S → S
  identityPair(D) = filter(xy ↦ ∃(a ↦ xy ≡ₑ (a , a))) ⦃ [∃]-unaryRelator ⦃ rel-P = binary-unaryRelatorᵣ ⦃ rel-P = [≡ₑ]-binaryRelator ⦄ ⦄ ⦄ (D ⨯ D)

  -- Quotient set.
  -- The set of equivalence classes.
  _/_ : S → (_▫_ : S → S → Type{ℓ}) ⦃ rel : BinaryRelator(_▫_) ⦄ → S
  (a / (_▫_)) ⦃ rel ⦄ = filter(aₛ ↦ ∀ₛ(aₛ)(x ↦ ∀ₛ(aₛ)(x ▫_))) ⦃ binary-unaryRelatorᵣ ⦃ rel-P = [∀ₛ]-binaryRelator {P = \x A _ → ∀ₛ(A) (x ▫_)} ⦃ rel-P = [∀ₛ]-binaryRelator ⦃ rel-P = const-binaryRelator ⦄ ⦄ ⦄ {∅} ⦄ (℘(a))

  -- Equivalence class.
  -- The set of elements which are equivalent to the specified one.
  [_of_,_] : S → S → (_▫_ : S → S → Type{ℓ}) ⦃ rel : BinaryRelator(_▫_) ⦄ → S
  [ x of a , (_▫_) ] = filter(x ▫_) ⦃ binary-unaryRelatorₗ ⦄ a

  -- The unmap of a set.
  -- The set of elements in the domain X when applied to a function gives an element in Y.
  -- Or: The inverse image of the function on the set.
  -- Or: The pre-image of the function on the set.
  -- Note:
  --   The domain is neccessary because a class function's domain is not neccesarily a set.
  --   For example: `const(x): Domain → Domain` for any (x: Domain) is a class function for which its domain is not a set.
  --   This is because const is defined for all objects in `Domain`, so if a set would have to have all objects in `Domain`, it has to be the universal set, but there is no universal set.
  unmap : S → (f : S → S) ⦃ func : Function(f) ⦄ → S → S
  unmap(X) f(Y) = filter(x ↦ f(x) ∈ Y) ⦃ [∘]-unaryRelator {P = _∈ Y} ⦃ binary-unaryRelatorᵣ ⦄ ⦄ X

  [∩]-inclusion : IntersectMembership(_∩_)
  [∩]-inclusion {A = A}{B = B}{x = x} =
    (x ∈ (A ∩ B))                     ⇔-[]
    x ∈ filter(_∈ B) ⦃ _ ⦄ A          ⇔-[ restricted-comprehension ⦃ _ ⦄ ]
    (x ∈ A) ∧ (x ∈ B)                 ⇔-end

  [∖]-inclusion : WithoutMembership(_∖_)
  [∖]-inclusion {A = A}{B = B}{x = x} =
    (x ∈ (A ∖ B))                     ⇔-[]
    x ∈ filter(_∉ B) ⦃ _ ⦄ A          ⇔-[ restricted-comprehension ⦃ _ ⦄ ]
    (x ∈ A) ∧ (x ∉ B)                 ⇔-end

  intersection : BigIntersectionMembershipWithEmpty(⋂)
  intersection {A = A}{x = x} =
    (x ∈ filter(a ↦ ∀ₛ(A)(a ∈_)) ⦃ _ ⦄ (⋃ A)) ⇔-[ restricted-comprehension ⦃ _ ⦄ ]
    (x ∈ ⋃ A) ∧ ∀ₛ(A)(x ∈_)                   ⇔-[ [∧]-map-[↔] union [↔]-reflexivity ]
    ∃(a ↦ (a ∈ A) ∧ (x ∈ a)) ∧ ∀ₛ(A)(x ∈_)    ⇔-end

  [⨯]-inclusion : (x ∈ (A ⨯ B)) ↔ ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ≡ₑ (a , b)))
  [⨯]-inclusion {x = x}{A = A}{B = B} =
    (x ∈ (A ⨯ B))                                                          ⇔-[]
    x ∈ filter(t ↦ ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ t ≡ₑ (a , b)))) ⦃ _ ⦄ (℘(℘(A ∪ B))) ⇔-[ restricted-comprehension ⦃ _ ⦄ ]
    (x ∈ ℘(℘(A ∪ B))) ∧ ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ (x ≡ₑ (a , b))))               ⇔-[ [↔]-intro (p ↦ [∧]-intro (l p) p) [∧]-elimᵣ ]
    ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ≡ₑ (a , b)))                                     ⇔-end
    where
      tuple-superset : (a ∈ A) → (b ∈ B) → ((a , b) ⊆ ℘(A ∪ B))
      tuple-superset pa pb = pair-superset
        ([↔]-to-[←] power (singleton-superset
          ([↔]-to-[←] [∪]-inclusion ([∨]-introₗ pa))
        ))
        ([↔]-to-[←] power (pair-superset
          ([↔]-to-[←] union ([∃]-intro A ⦃ [∧]-intro pair-contains-left  pa ⦄))
          ([↔]-to-[←] union ([∃]-intro B ⦃ [∧]-intro pair-contains-right pb ⦄))
        ))

      l =
        ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ≡ₑ (a , b)))                     ⇒-[ [∃]-map-proof ([∧]-map id ([∃]-map-proof ([∧]-map id ([↔]-to-[→] set-extensionality)))) ]
        ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ≡ (a , b)))                      ⇒-[ [∃]-map-proof ([∧]-map id ([∃]-map-proof ([∧]-map id (sub₂(_≡_)(_⊆_))))) ]
        ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ⊆ (a , b)))                      ⇒-[]
        ∃ₛ(A)(a ↦ ∃ₛ(B)(b ↦ x ⊆ pair(singleton a) (pair a b))) ⇒-[ (\([∃]-intro _ ⦃ [∧]-intro pa ([∃]-intro _ ⦃ [∧]-intro pb sub ⦄) ⦄) {y} → transitivity(_⊆_) sub (tuple-superset pa pb) {y}) ]
        x ⊆ ℘(A ∪ B)                                           ⇒-[ [↔]-to-[←] power ]
        x ∈ ℘(℘(A ∪ B))                                        ⇒-end

  instance
    ⋂-function : Function(⋂)
    Function.congruence ⋂-function {x = As}{y = Bs} AsBs = filter-function ⦃ _ ⦄ ⦃ _ ⦄ p (congruence₁(⋃) AsBs) where
      p : ∀{x} → (∀{A} → (A ∈ As) → (x ∈ A)) ↔ (∀{B} → (B ∈ Bs) → (x ∈ B))
      p = [↔]-intro (_∘ (substitute₂ᵣ(_∈_) AsBs)) (_∘ (substitute₂ᵣ(_∈_) (symmetry(_≡ₑ_) AsBs)))

  instance
    ∪-operator : BinaryOperator(_∪_)
    BinaryOperator.congruence ∪-operator = congruence₁(⋃) ∘₂ congruence₂(pair)

  instance
    ∩-operator : BinaryOperator(_∩_)
    BinaryOperator.congruence ∩-operator xy1 xy2 = filter-function ⦃ _ ⦄ ⦃ _ ⦄ ([↔]-to-[→] set-extensionality xy2) xy1

  instance
    ∖-operator : BinaryOperator(_∖_)
    BinaryOperator.congruence ∖-operator xy1 xy2 = filter-function ⦃ _ ⦄ ⦃ _ ⦄ ([¬]-unaryOperator ([↔]-to-[→] set-extensionality xy2)) xy1

  instance
    [,]-operator : BinaryOperator(_,_)
    BinaryOperator.congruence [,]-operator xy1 xy2 = congruence₂(pair) (congruence₁(singleton) xy1) (congruence₂(pair) xy1 xy2)


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

{-# OPTIONS --guardedness #-}

open import Agda.Builtin.Equality
open import Data.Product
open import Data.Sum
open import Level
open import Relation.Unary using (_⊆_)

module is-lib.InfSys.FlexCoinduction {𝓁} where

  private
    variable
      U : Set 𝓁

  open import is-lib.InfSys.Base {𝓁}
  open import is-lib.InfSys.Induction {𝓁}
  open import is-lib.InfSys.Coinduction {𝓁}
  open MetaRule
  open IS

  {- Generalized inference systems -}

  FCoInd⟦_,_⟧ : ∀{𝓁c 𝓁p 𝓁n 𝓁n'} → (I : IS {𝓁c} {𝓁p} {𝓁n} U) → (C : IS {𝓁c} {𝓁p} {𝓁n'} U) → U → Set _
  FCoInd⟦ I , C ⟧ = CoInd⟦ I ⊓ Ind⟦ I ∪ C ⟧ ⟧

  {- Bounded Coinduction Principle -}

  bdc-lem : ∀{𝓁c 𝓁p 𝓁n 𝓁' 𝓁''}
      → (I : IS {𝓁c} {𝓁p} {𝓁n} U)
      → (S : U → Set 𝓁')
      → (Q : U → Set 𝓁'')
      → S ⊆ Q
      → S ⊆ ISF[ I ] S
      → S ⊆ ISF[ I ⊓ Q ] S
  bdc-lem _ _ _ bd cn Su with cn Su
  ... | rn , c , refl , pr = rn , (c , bd Su) , refl , pr

  bounded-coind[_,_] : ∀{𝓁c 𝓁p 𝓁n 𝓁n' 𝓁'}
      → (I : IS {𝓁c} {𝓁p} {𝓁n} U)
      → (C : IS {𝓁c} {𝓁p} {𝓁n'} U)
      → (S : U → Set 𝓁')
      → S ⊆ Ind⟦ I ∪ C ⟧      -- S is bounded w.r.t. I ∪ C
      → S ⊆ ISF[ I ] S        -- S is consistent w.r.t. I
      → S ⊆ FCoInd⟦ I , C ⟧
  bounded-coind[ I , C ] S bd cn Su = coind[ I ⊓ Ind⟦ I ∪ C ⟧ ] S (bdc-lem I S Ind⟦ I ∪ C ⟧ bd cn) Su

  {- Get Ind from FCoInd -}

  fcoind-to-ind : ∀{𝓁c 𝓁p 𝓁n 𝓁n'}
      {is : IS {𝓁c} {𝓁p} {𝓁n} U}{cois : IS {𝓁c} {𝓁p} {𝓁n'} U}
      → FCoInd⟦ is , cois ⟧ ⊆ Ind⟦ is ∪ cois ⟧
  fcoind-to-ind co with CoInd⟦_⟧.unfold co
  ... | _ , (_ , sd) , refl , _ = sd

  {- Apply Rule -}

  apply-fcoind : ∀{𝓁c 𝓁p 𝓁n 𝓁n'}
      {is : IS {𝓁c} {𝓁p} {𝓁n} U}{cois : IS {𝓁c} {𝓁p} {𝓁n'} U}
      → (rn : is .Names) → RClosed (is .rules rn) FCoInd⟦ is , cois ⟧
  apply-fcoind rn c pr = apply-coind rn (c , apply-ind (inj₁ rn) c λ i → fcoind-to-ind (pr i)) pr

  {- Postfix - Prefix -}

  fcoind-postfix : ∀{𝓁c 𝓁p 𝓁n 𝓁n'}
      {is : IS {𝓁c} {𝓁p} {𝓁n} U}{cois : IS {𝓁c} {𝓁p} {𝓁n'} U}
      → FCoInd⟦ is , cois ⟧ ⊆ ISF[ is ] FCoInd⟦ is , cois ⟧
  fcoind-postfix FCoInd with FCoInd .CoInd⟦_⟧.unfold
  ... | rn , (c , _) , refl , pr = rn , c , refl , pr

  fcoind-prefix : ∀{𝓁c 𝓁p 𝓁n 𝓁n'}
      {is : IS {𝓁c} {𝓁p} {𝓁n} U}{cois : IS {𝓁c} {𝓁p} {𝓁n'} U}
      → ISF[ is ] FCoInd⟦ is , cois ⟧ ⊆ FCoInd⟦ is , cois ⟧
  fcoind-prefix (rn , c , refl , pr) = apply-fcoind rn c pr


open import Nat
open import Prelude
open import core
open import contexts
open import lemmas-disjointness
open import exchange

-- this module contains all the proofs of different weakening structural
-- properties that we use for the hypothetical judgements
module weakening where
  mutual
    weaken-subst-Δ : ∀{Δ1 Δ2 Γ σ Γ'} → Δ1 ## Δ2
                                     → Δ1 , Γ ⊢ σ :s: Γ'
                                     → (Δ1 ∪ Δ2) , Γ ⊢ σ :s: Γ'
    weaken-subst-Δ disj (STAId x) = STAId x
    weaken-subst-Δ disj (STASubst subst x) = STASubst (weaken-subst-Δ disj subst) (weaken-ta-Δ1 disj x)

    weaken-ta-Δ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2
                                  → Δ1 , Γ ⊢ d :: τ
                                  → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
    weaken-ta-Δ1 disj TAConst = TAConst
    weaken-ta-Δ1 disj (TAVar x₁) = TAVar x₁
    weaken-ta-Δ1 disj (TALam x₁ wt) = TALam x₁ (weaken-ta-Δ1 disj wt)
    weaken-ta-Δ1 disj (TAAp wt wt₁) = TAAp (weaken-ta-Δ1 disj wt) (weaken-ta-Δ1 disj wt₁)
    weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TAEHole {u = u} {Γ' = Γ'} x x₁) = TAEHole (x∈∪l Δ1 Δ2 u _ x ) (weaken-subst-Δ disj x₁)
    weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TANEHole {Γ' = Γ'} {u = u} x wt x₁) = TANEHole (x∈∪l Δ1 Δ2 u _ x) (weaken-ta-Δ1 disj wt) (weaken-subst-Δ disj x₁)
    weaken-ta-Δ1 disj (TACast wt x) = TACast (weaken-ta-Δ1 disj wt) x
    weaken-ta-Δ1 disj (TAFailedCast wt x x₁ x₂) = TAFailedCast (weaken-ta-Δ1 disj wt) x x₁ x₂

  -- this is a little bit of a time saver. since ∪ is commutative on
  -- disjoint contexts, and we need that premise anyway in both positions,
  -- there's no real reason to repeat the inductive argument above
  weaken-ta-Δ2 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2
                                → Δ2 , Γ ⊢ d :: τ
                                → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  weaken-ta-Δ2 {Δ1} {Δ2} {Γ} {d} {τ} disj D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1 (##-comm disj)) (weaken-ta-Δ1 (##-comm disj) D)

  -- note that these statements are somewhat stronger than usual. this is
  -- because we don't have implcit α-conversion. this reifies the
  -- often-silent on paper assumption that if you collide with a bound
  -- variable you can just α-convert it away and not worry.
  mutual
    weaken-synth : ∀{ x Γ e τ τ'} → freshh x e
                                  → Γ ⊢ e => τ
                                  → (Γ ,, (x , τ')) ⊢ e => τ
    weaken-synth FRHConst SConst = SConst
    weaken-synth (FRHAsc frsh) (SAsc x₁) = SAsc (weaken-ana frsh x₁)
    weaken-synth {Γ = Γ} (FRHVar {x = x} x₁) (SVar {x = y} x₂) = SVar (x∈∪l Γ (■(x , _)) y _  x₂)
    weaken-synth {Γ = Γ} (FRHLam2 x₁ frsh) (SLam x₂ wt) =
                    SLam (apart-extend1 Γ (flip x₁) x₂)
                         (exchange-synth {Γ = Γ} (flip x₁) ((weaken-synth frsh wt)))
    weaken-synth FRHEHole SEHole = SEHole
    weaken-synth (FRHNEHole frsh) (SNEHole x₁ wt) = SNEHole x₁ (weaken-synth frsh wt)
    weaken-synth (FRHAp frsh frsh₁) (SAp x₁ wt x₂ x₃) = SAp x₁ (weaken-synth frsh wt) x₂ (weaken-ana frsh₁ x₃)

    weaken-ana : ∀{x Γ e τ τ'} → freshh x e
                               → Γ ⊢ e <= τ
                               → (Γ ,, (x , τ')) ⊢ e <= τ
    weaken-ana frsh (ASubsume x₁ x₂) = ASubsume (weaken-synth frsh x₁) x₂
    weaken-ana {Γ = Γ} (FRHLam1 neq frsh) (ALam x₂ x₃ wt) =
                     ALam (apart-extend1 Γ (flip neq) x₂)
                          x₃
                          (exchange-ana {Γ = Γ} (flip neq) (weaken-ana frsh wt))

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-extend1 Γ (flip x₁) x₄) (exchange-ta-Γ {Γ = Γ} (flip x₁) (weaken-ta x₃ wt))
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃


open import Prelude
open import Data.Maybe using (Maybe; just; nothing)

open import RW.Language.RTerm
open import RW.Language.RTermUtils using (hole2Abs)
open import RW.Language.Instantiation using (RSubst)
open import RW.Utils.Error
open import RW.Strategy

module RW.Strategy.PropEq where

  pattern pat-≡  = (rdef (quote _≡_))

  private
    open UData

    ≡-when : RTermName → RTermName → Bool
    ≡-when pat-≡ pat-≡ = true
    ≡-when _     _     = false

    fixTrs : Trs → RTerm ⊥ → RTerm ⊥
    fixTrs Symmetry term = rapp (rdef (quote sym)) (term ∷ [])

    ≡-how : Name → UData → Err StratErr (RTerm ⊥)
    ≡-how act (u-data g□ σ trs)
      = i2 (rapp (rdef (quote cong))
                 ( hole2Abs g□
                 ∷ foldr fixTrs (makeApp act σ) trs
                 ∷ [])
           )

  ≡-strat : TStrat
  ≡-strat = record
    { when = ≡-when
    ; how  = ≡-how
    }

  open import RW.RW (≡-strat ∷ [])

  by*-≡ : by*-tactic
  by*-≡ = by* (quote trans)


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

-- Power Functors, Exponentials over a Category C

-- Mainly categories where the objects are functions (Fin n -> Obj) considered pointwise
--   and then upgraded to Functors.

module Categories.Functor.Power {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning

open import Level using (Level; _⊔_)
open import Data.Nat using (ℕ; _+_; zero; suc; _<_)
open import Data.Product using (_,_)
open import Data.Fin using (Fin; inject+; raise; zero; suc; fromℕ<)
open import Data.Sum using (_⊎_; inj₁; inj₂; map) renaming ([_,_] to ⟦_,_⟧; [_,_]′ to ⟦_,_⟧′)
open import Data.Vec.N-ary hiding (curryⁿ)
open import Function as Fun using (flip; _$_) renaming (_∘_ to _∙_; id to idf)

open import Categories.Category.Product using (Product; _⁂_)
open import Categories.Functor hiding (id)
open import Categories.Functor.Bifunctor using (Bifunctor; overlap-×)

private
  variable
    i j k : Level
    I I′ J J′ : Set i
    D E : Category i j k
    n n′ m m′ : ℕ

Exp : Set i → Category _ _ _
Exp I = record
  { Obj       = I → Obj
  ; _⇒_       = λ x y → ∀ i → x i ⇒ y i
  ; _≈_       = λ f g → ∀ i → f i ≈ g i
  ; id        = λ _ → id
  ; _∘_       = λ f g i → f i ∘ g i
  ; assoc     = λ _ → assoc
  ; sym-assoc = λ _ → sym-assoc
  ; identityˡ = λ _ → identityˡ
  ; identityʳ = λ _ → identityʳ
  ; identity² = λ _ → identity²
  ; equiv     = record
    { refl  = λ _ → refl
    ; sym   = λ eq i → sym $ eq i
    ; trans = λ eq₁ eq₂ i → trans (eq₁ i) (eq₂ i)
    }
  ; ∘-resp-≈  = λ eq₁ eq₂ i → ∘-resp-≈ (eq₁ i) (eq₂ i)
  }

Power : (n : ℕ) → Category o ℓ e
Power n = Exp (Fin n)

-- Convention: the ′ version is for a general index set, unprimed for a ℕ
-- representing Fin n.  So Powerfunctor D n is Exp C (Fin n) ⇒ D, i.e.
-- essentially C ^ n ⇒ D.
Powerfunctor′ : (D : Category o ℓ e) (I : Set i) → Set (i ⊔ e ⊔ ℓ ⊔ o)
Powerfunctor′ D I = Functor (Exp I) D

Powerfunctor : (D : Category o ℓ e) (n : ℕ) → Set (e ⊔ ℓ ⊔ o)
Powerfunctor D n = Powerfunctor′ D (Fin n)

-- With C = D, so Powerendo n is C ^ n => C
Powerendo′ : (I : Set i) → Set (i ⊔ e ⊔ ℓ ⊔ o)
Powerendo′ I = Powerfunctor′ C I

Powerendo : (n : ℕ) → Set (e ⊔ ℓ ⊔ o)
Powerendo n = Powerfunctor C n

-- Hyperendo n m is C ^ n ⇒ C ^ m
Hyperendo : (n m : ℕ) → Set (e ⊔ ℓ ⊔ o)
Hyperendo n m = Functor (Power n) (Power m)

-- Hyperendo′ I J is C ^ I → C ^ J
Hyperendo′ : (I : Set i) (J : Set j) → Set (i ⊔ j ⊔ e ⊔ ℓ ⊔ o)
Hyperendo′ I J = Functor (Exp I) (Exp J)

-- Parallel composition of Hyperendo′ (via disjoint union of index sets)
infixr 9 _par_

_par_ : (F : Hyperendo′ I I′) (G : Hyperendo′ J J′) → Hyperendo′ (I ⊎ J) (I′ ⊎ J′)
F par G = record
  { F₀           = λ xs →  ⟦ F.F₀ (xs ∙ inj₁) , G.F₀ (xs ∙ inj₂) ⟧′
  ; F₁           = λ fs → ⟦ F.F₁ (fs ∙ inj₁) , G.F₁ (fs ∙ inj₂) ⟧
  ; identity     = ⟦ F.identity , G.identity ⟧
  ; homomorphism = ⟦ F.homomorphism , G.homomorphism ⟧
  ; F-resp-≈     = λ fs≈gs → ⟦ F.F-resp-≈ (fs≈gs ∙ inj₁) , G.F-resp-≈ (fs≈gs ∙ inj₂) ⟧
  }
  where module F = Functor F
        module G = Functor G

-- "flattening" means going from a general disjoint union of Fin to a single Fin,
-- which has the effect of doing from Powerfunctor′ to Powerfunctor
flattenP : (F : Powerfunctor′ D (Fin n ⊎ Fin m)) → Powerfunctor D (n + m)
flattenP {n = n} {m = m} F = record
  { F₀           = λ As → F₀ (As ∙ pack)
  ; F₁           = λ fs → F₁ (fs ∙ pack)
  ; identity     = identity
  ; homomorphism = homomorphism
  ; F-resp-≈     = λ fs≈gs → F-resp-≈ (fs≈gs ∙ pack)
  }
  where open Functor F
        pack = ⟦ inject+ m , raise n ⟧′

-- TODO unpackFun (and pack above) should be in stdlib
private
  unpackFin : ∀ n → Fin (n + m) → Fin n ⊎ Fin m
  unpackFin zero f          = inj₂ f
  unpackFin (suc n) zero    = inj₁ zero
  unpackFin (suc n) (suc f) = map suc idf (unpackFin n f)

-- needs a better name?
unflattenP : Powerfunctor D (n + m) → Powerfunctor′ D (Fin n ⊎ Fin m)
unflattenP {n = n} {m = m} F = record
  { F₀           = λ As → F₀ (As ∙ unpackFin _)
  ; F₁           = λ fs → F₁ (fs ∙ unpackFin _)
  ; identity     = identity
  ; homomorphism = homomorphism
  ; F-resp-≈     = λ fs≈gs → F-resp-≈ (fs≈gs ∙ unpackFin _)
  }
  where open Functor F

-- flatten a Hyperendo′ "on the right" when over a union of Fin
flattenHʳ : (F : Hyperendo′ I (Fin n ⊎ Fin m)) → Hyperendo′ I (Fin (n + m))
flattenHʳ {n = n} {m = m} F = record
  { F₀           = λ As → F₀ As ∙ unpackFin n
  ; F₁           = λ fs → F₁ fs ∙ unpackFin n
  ; identity     = identity ∙ unpackFin n
  ; homomorphism = homomorphism ∙ unpackFin n
  ; F-resp-≈     = λ fs≈gs → F-resp-≈ fs≈gs ∙ unpackFin n
  }
  where open Functor F

-- flatten on both sides.
flattenH : (F : Hyperendo′ (Fin n ⊎ Fin m) (Fin n′ ⊎ Fin m′)) → Hyperendo (n + m) (n′ + m′)
flattenH = flattenHʳ ∙ flattenP

-- Pretty syntax for flattening of parallel composition of Hyperendo
infixr 9 _∥_

_∥_ : (F : Hyperendo n n′) (G : Hyperendo m m′) → Hyperendo (n + m) (n′ + m′)
F ∥ G = flattenH (F par G)

-- split is C ^ (I ⊎ J) to C ^ I × C ^ J, as a Functor
split : Functor (Exp (I ⊎ J)) (Product (Exp I) (Exp J))
split = record
  { F₀           = λ As → As ∙ inj₁ , As ∙ inj₂
  ; F₁           = λ fs → fs ∙ inj₁ , fs ∙ inj₂
  ; identity     = (λ _ → refl) , λ _ → refl
  ; homomorphism = (λ _ → refl) , λ _ → refl
  ; F-resp-≈     = λ eq → (λ i → eq (inj₁ i)) , λ i → eq (inj₂ i)
  }

reduce′ : (H : Bifunctor C C C) (F : Powerendo′ I) (G : Powerendo′ J) → Powerendo′ (I ⊎ J)
reduce′ H F G = H ∘F (F ⁂ G) ∘F split

reduce : ∀ (H : Bifunctor C C C) {n m} (F : Powerendo n) (G : Powerendo m) → Powerendo (n + m)
reduce H F G = flattenP $ reduce′ H F G

flattenP-assocʳ : ∀ {n₁ n₂ n₃} (F : Powerendo′ (Fin n₁ ⊎ Fin n₂ ⊎ Fin n₃)) → Powerendo (n₁ + n₂ + n₃)
flattenP-assocʳ {n₁} {n₂} {n₃} F = record
  { F₀           = λ As → F.F₀ (As ∙ pack)
  ; F₁           = λ fs → F.F₁ (fs ∙ pack)
  ; identity     = F.identity
  ; homomorphism = F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ (fs≈gs ∙ pack)
  }
  where module F = Functor F
        pack = ⟦ inject+ n₃ ∙ inject+ n₂ , ⟦ inject+ n₃ ∙ raise n₁ , raise (n₁ + n₂) ⟧′ ⟧′

reduce2ʳ : ∀ (G : Bifunctor C C C) {n₁ n₂ n₃} (F₁ : Powerendo n₁) (F₂ : Powerendo n₂) (F₃ : Powerendo n₃) → Powerendo ((n₁ + n₂) + n₃)
reduce2ʳ G F₁ F₂ F₃ = flattenP-assocʳ $ reduce′ G F₁ $ reduce′ G F₂ F₃

overlaps : (H : Bifunctor D D E) (F G : Powerfunctor′ D I) → Powerfunctor′ E I
overlaps = overlap-×

overlap2ʳ : (G : Bifunctor C C C) (F₁ F₂ F₃ : Powerendo n) → Powerendo n
overlap2ʳ G F₁ F₂ F₃ = overlaps G F₁ (overlaps G F₂ F₃)

-- select′ i always evaluates at i
select′ : (i : I) → Powerendo′ I
select′ i = record
  { F₀           = _$ i
  ; F₁           = _$ i
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = _$ i
  }

-- select (m < n) is really select′ (Fin n), but only for m < n
select : m < n → Powerendo n
select m<n = select′ (fromℕ< m<n)

triv : (n : ℕ) → Hyperendo n n
triv n = record
  { F₀           = idf
  ; F₁           = idf
  ; identity     = λ _ → refl
  ; homomorphism = λ _ → refl
  ; F-resp-≈     = idf
  }

-- pad a Hyperendo on the left and right by trivial (i.e. identity) endofunctors
pad : ∀ (l r : ℕ) (F : Hyperendo n m) → Hyperendo ((l + n) + r) ((l + m) + r)
pad l r F = (triv l ∥ F) ∥ triv r

padˡ : ∀ (l : ℕ) (F : Hyperendo n m) → Hyperendo (l + n) (l + m)
padˡ l F = triv l ∥ F

padʳ : ∀ (r : ℕ) (F : Hyperendo n m) → Hyperendo (n + r) (m + r)
padʳ r F = F ∥ triv r

unary : Endofunctor C → Powerendo 1
unary F = record
  { F₀           = λ As → F.F₀ (As zero)
  ; F₁           = λ fs → F.F₁ (fs zero)
  ; identity     = F.identity
  ; homomorphism = F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ (fs≈gs zero)
  }
  where module F = Functor F

unaryH : Endofunctor C → Hyperendo 1 1
unaryH F = record
  { F₀           = λ As → F.F₀ ∙ As
  ; F₁           = λ fs → F.F₁ ∙ fs
  ; identity     = λ _ → F.identity
  ; homomorphism = λ _ → F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ ∙ fs≈gs
  }
  where module F = Functor F

-- "constant"
nullary : Obj → Powerendo 0
nullary X = record
  { F₀           = λ _ → X
  ; F₁           = λ _ → id
  ; identity     = refl
  ; homomorphism = sym identity²
  ; F-resp-≈     = λ _ → refl
  }

nullaryH : Obj → Hyperendo 0 1
nullaryH X = record
  { F₀           = λ _ _ → X
  ; F₁           = λ _ _ → id
  ; identity     = λ _ → refl
  ; homomorphism = λ _ → sym identity²
  ; F-resp-≈     = λ _ _ → refl
  }

binary : Bifunctor C C C → Powerendo 2
binary F = record
  { F₀           = λ As → F.F₀ (As zero , As (suc zero))
  ; F₁           = λ fs → F.F₁ (fs zero , fs (suc zero))
  ; identity     = F.identity
  ; homomorphism = F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ (fs≈gs zero , fs≈gs (suc zero))
  }
  where module F = Functor F

binaryH : Bifunctor C C C → Hyperendo 2 1
binaryH F = record
  { F₀           = λ As _ → F.F₀ (As zero , As (suc zero))
  ; F₁           = λ fs _ → F.F₁ (fs zero , fs (suc zero))
  ; identity     = λ _ → F.identity
  ; homomorphism = λ _ → F.homomorphism
  ; F-resp-≈     = λ fs≈gs _ → F.F-resp-≈ (fs≈gs zero , fs≈gs (suc zero))
  }
  where module F = Functor F

hyp : Powerendo n → Hyperendo n 1
hyp F = record
  { F₀           = λ As _ → F.F₀ As
  ; F₁           = λ fs _ → F.F₁ fs
  ; identity     = λ _ → F.identity
  ; homomorphism = λ _ → F.homomorphism
  ; F-resp-≈     = λ fs≈gs _ → F.F-resp-≈ fs≈gs
  }
  where module F = Functor F

private
  curryⁿ : ∀ n {a b} {A : Set a} {B : Set b} → ((Fin n → A) → B) → N-ary n A B
  curryⁿ zero f     = f (λ ())
  curryⁿ (suc n) {A = A} f = λ x → curryⁿ n (f ∙ addon x)
    where addon : A → (Fin n → A) → Fin (suc n) → A
          addon x _ zero    = x
          addon _ g (suc i) = g i

plex′ : (J → Powerendo′ I) → Hyperendo′ I J
plex′ Fs = record
  { F₀           = flip (Functor.F₀ ∙ Fs)
  ; F₁           = flip (λ j → Functor.F₁ (Fs j))
  ; identity     = λ j → Functor.identity (Fs j)
  ; homomorphism = λ j → Functor.homomorphism (Fs j)
  ; F-resp-≈     = flip (λ j → Functor.F-resp-≈ (Fs j))
  }

plex : N-ary n (Powerendo′ I) (Hyperendo′ I (Fin n))
plex {n = n} = curryⁿ n plex′

-- like pad, but for Powerendo -- on left or right.
widenˡ : ∀ (l : ℕ) (F : Powerendo n) → Powerendo (l + n)
widenˡ l F = record
  { F₀           = λ As → F.F₀ (As ∙ pack)
  ; F₁           = λ {As Bs} fs → F.F₁ (fs ∙ pack)
  ; identity     = F.identity
  ; homomorphism = F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ (fs≈gs ∙ pack)
  }
  where module F = Functor F
        pack = raise l

widenʳ : ∀ (r : ℕ) (F : Powerendo n) → Powerendo (n + r)
widenʳ r F = record
  { F₀           = λ As → F.F₀ (As ∙ pack)
  ; F₁           = λ fs → F.F₁ (fs ∙ pack)
  ; identity     = F.identity
  ; homomorphism = F.homomorphism
  ; F-resp-≈     = λ fs≈gs → F.F-resp-≈ (fs≈gs ∙ pack)
  }
  where module F = Functor F
        pack = inject+ r


data A : Set₁ → Set where
  C : (S : Set₁) → A S


{-# OPTIONS --without-K #-}
open import container.core

module container.w.algebra
  {li la lb}(c : Container li la lb) where

open import sum
open import equality
open import container.w.core
open import function.extensionality
open import function.isomorphism
open import hott.level.core

open Container c

Alg : ∀ ℓ → Set _
Alg ℓ = Σ (I → Set ℓ) λ X → F X →ⁱ X

carrier : ∀ {ℓ} → Alg ℓ → I → Set ℓ
carrier (X , _) = X

IsMor : ∀ {ℓ₁ ℓ₂}(𝓧 : Alg ℓ₁)(𝓨 : Alg ℓ₂)
      → (carrier 𝓧 →ⁱ carrier 𝓨) → Set _
IsMor (X , θ) (Y , ψ) f = ψ ∘ⁱ imap f ≡ f ∘ⁱ θ

Mor : ∀ {ℓ₁ ℓ₂} → Alg ℓ₁ → Alg ℓ₂ → Set _
Mor 𝓧 𝓨 = Σ (carrier 𝓧 →ⁱ carrier 𝓨) (IsMor 𝓧 𝓨)

𝓦 : Alg _
𝓦 = W c , inW c

module _ {ℓ₁ ℓ₂}(𝓧 : Alg ℓ₁)(𝓨 : Alg ℓ₂) where
  private
    X = proj₁ 𝓧; θ = proj₂ 𝓧
    Y = proj₁ 𝓨; ψ = proj₂ 𝓨

  is-mor-transp : {f g : X →ⁱ Y}(p : f ≡ g)
                → (α : IsMor 𝓧 𝓨 f)
                → sym (ap (λ h → ψ ∘ⁱ imap h) p) · α · ap (λ h → h ∘ⁱ θ) p
                ≡ subst (IsMor 𝓧 𝓨) p α
  is-mor-transp {f} {.f} refl α = left-unit α

  MorEq : Mor 𝓧 𝓨 → Mor 𝓧 𝓨 → Set _
  MorEq (f , α) (g , β) = Σ (f ≡ g) λ p
    → sym (ap (λ h → ψ ∘ⁱ imap h) p) · α · ap (λ h → h ∘ⁱ θ) p ≡ β

  MorH : Mor 𝓧 𝓨 → Mor 𝓧 𝓨 → Set _
  MorH (f , α) (g , β) = Σ (∀ i x → f i x ≡ g i x) λ p
    → ∀ i x → sym (ap (ψ i) (hmap p i x)) · funext-invⁱ α i x · p i (θ i x)
            ≡ funext-invⁱ β i x

  mor-eq-h-iso : (f g : Mor 𝓧 𝓨) → MorEq f g ≅ MorH f g
  mor-eq-h-iso (f , α) (g , β) = Σ-ap-iso (sym≅ funext-isoⁱ) λ p → lem f g α β p
    where
      lem : (f g : X →ⁱ Y)(α : IsMor 𝓧 𝓨 f)(β : IsMor 𝓧 𝓨 g)(p : f ≡ g)
          → (sym (ap (λ h → ψ ∘ⁱ imap h) p) · α · ap (λ h → h ∘ⁱ θ) p ≡ β)
          ≅ (∀ i x → sym (ap (ψ i) (hmap (funext-invⁱ p) i x))
                   · funext-invⁱ α i x
                   · funext-invⁱ p i (θ i x)
                   ≡ funext-invⁱ β i x)
      lem f .f α β refl = begin
          (α · refl ≡ β)
        ≅⟨ sym≅ (trans≡-iso (left-unit α)) ⟩
          (α ≡ β)
        ≅⟨ iso≡ (sym≅ funext-isoⁱ) ⟩
          (funext-invⁱ α ≡ funext-invⁱ β)
        ≅⟨ sym≅ ((Π-ap-iso refl≅ λ _ → strong-funext-iso) ·≅ strong-funext-iso) ⟩
          (∀ i x → funext-invⁱ α i x ≡ funext-invⁱ β i x)
        ≅⟨ ( Π-ap-iso refl≅ λ i
            → Π-ap-iso refl≅ λ x
            → trans≡-iso (comp i x) ) ⟩
          (∀ i x → sym (ap (ψ i) (hmap (funext-invⁱ p₀) i x))
                 · funext-invⁱ α i x
                 · refl
                 ≡ funext-invⁱ β i x)
        ∎
        where
          open ≅-Reasoning

          p₀ : f ≡ f
          p₀ = refl

          comp : ∀ i x → sym (ap (ψ i) (hmap (funext-invⁱ (refl {x = f})) i x))
                       · funext-invⁱ α i x
                       · refl
                       ≡ funext-invⁱ α i x
          comp i x = ap (λ q → sym (ap (ψ i) q) · funext-invⁱ α i x · refl)
                        (hmap-id f i x)
                   · left-unit (funext-invⁱ α i x)

  eq-mor-iso : {f g : Mor 𝓧 𝓨} → (f ≡ g) ≅ MorH f g
  eq-mor-iso {f , α} {g , β} = begin
      ((f , α) ≡ (g , β))
    ≅⟨ sym≅ Σ-split-iso ⟩
      (Σ (f ≡ g) λ p → subst (IsMor 𝓧 𝓨) p α ≡ β)
    ≅⟨ (Σ-ap-iso refl≅ λ p → trans≡-iso (is-mor-transp p α)) ⟩
      MorEq (f , α) (g , β)
    ≅⟨ mor-eq-h-iso _ _ ⟩
      MorH (f , α) (g , β)
    ∎
    where
      open ≅-Reasoning

module _ {ℓ} (𝓧 : Alg ℓ) where
  private
    X = proj₁ 𝓧; θ = proj₂ 𝓧

    lem : ∀ {ℓ}{A : Set ℓ}{x y z w : A}
        → (p : x ≡ w) (q : y ≡ x) (r : y ≡ z) (s : z ≡ w)
        → p ≡ sym q · r · s → sym r · q · p ≡ s
    lem p refl refl refl α = α

  W-mor-prop : (f g : Mor 𝓦 𝓧) → f ≡ g
  W-mor-prop (f , α) (g , β) = invert (eq-mor-iso 𝓦 𝓧) (p , p-h)
    where
      p : ∀ i x → f i x ≡ g i x
      p i (sup a u)
        = sym (funext-invⁱ α i (a , u))
        · ap (θ i) (ap (_,_ a) (funext (λ b → p (r b) (u b))))
        · funext-invⁱ β i (a , u)

      p-h : ∀ i x
          → sym (ap (θ i) (hmap p i x))
          · funext-invⁱ α i x
          · p i (inW c i x)
          ≡ funext-invⁱ β i x
      p-h i (a , u) = lem (p i (sup a u))
                          (funext-invⁱ α i (a , u)) _
                          (funext-invⁱ β i (a , u))
                          refl

  W-mor : Mor 𝓦 𝓧
  W-mor = fold c θ , funextⁱ (λ i x → fold-β c θ x)

W-initial : ∀ {ℓ} (𝓧 : Alg ℓ) → contr (Mor 𝓦 𝓧)
W-initial 𝓧 = W-mor 𝓧 , W-mor-prop 𝓧 (W-mor 𝓧)

-- special case of the isomorphism above, with better
-- computational behaviour
W-initial-W : contr (Mor 𝓦 𝓦)
W-initial-W = id-mor , W-mor-prop 𝓦 id-mor
  where
    id-mor : Mor 𝓦 𝓦
    id-mor = (λ i x → x) , refl


module Issue482 where

open import Common.Level using (_⊔_)

postulate
  P      : ∀ a b → Set a → Set b → Set (a ⊔ b)
  F      : ∀ ℓ → Set ℓ
  p      : ∀ a (A : Set a) → P a a A (F a)
  Q      : ∀ a → Set a → ∀ b → Set (a ⊔ b)
  P-to-Q : ∀ a b (A : Set a) (B : Set b) → P a b A B → Q a A b

q : ∀ a (A : Set a) → Q a A _
q a A = P-to-Q _ _ _ _ (p _ _)

{-

  There was a bug in the level constraint solver that looks
  at pairs of constraints.

-}


-- Some proposition constructors.

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

module Tools.Nullary where

open import Relation.Nullary using (¬_; Dec; yes; no) public
open import Relation.Nullary.Decidable using (isYes) public

-- If A and B are logically equivalent, then so are Dec A and Dec B.

map : ∀ {ℓ₁ ℓ₂} {A : Set ℓ₁} {B : Set ℓ₂} → (A → B) → (B → A) → Dec A → Dec B
map f g (yes p) = yes (f p)
map f g (no ¬p) = no (λ x → ¬p (g x))


-- Mixing CatchAll branches with varying arity can be tricky.
--
-- If the number of arguments a catch all branch expects to be already abstracted over is smaller
-- than the number of arguments present in the failing clause/branch, we need to apply
-- the catch-all branch to the surplus arguments already abstracted over.

module CatchAllVarArity where

open import Common.Nat
open import Common.IO
open import Common.Unit

f : Nat → Nat → Nat
f zero = λ y → y
f (suc zero) (suc y) = suc y
f x y = (suc y)

case_of_ : ∀{A B : Set} → A → (A → B) → B
case a of f = f a

-- case tree variant of f
g : Nat → Nat → Nat
g = λ x →
    case x of
     λ{ zero     → λ y → y
      ; (suc x') →
        case x' of
         λ{ zero  → λ y →
            case y of
             λ{ (suc y') → suc y'
              ; _        → fallback (suc x') y
              }
          ; _ → λ y → fallback x y
          }
      }
  where
    fallback = λ x y → suc y

--expected:
-- 10
-- 21
-- 1
-- 0
-- 4
-- 1
main = printNat (f 0 10) ,,
  putStrLn "" ,,
  printNat (f 10 20) ,,
  putStrLn "" ,,
  printNat (f 10 0) ,,
  putStrLn "" ,,
  printNat (f 0 0) ,,
  putStrLn "" ,,
  printNat (f 1 4) ,,
  putStrLn "" ,,
  printNat (f 1 0) ,,
  putStrLn ""


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lexicographic products of binary relations
------------------------------------------------------------------------

-- The definition of lexicographic product used here is suitable if
-- the left-hand relation is a strict partial order.

module Relation.Binary.Product.StrictLex where

open import Function
open import Data.Product
open import Data.Sum
open import Data.Empty
open import Level
open import Relation.Nullary.Product
open import Relation.Nullary.Sum
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.Product.Pointwise as Pointwise
  using (_×-Rel_)
open import Relation.Nullary

module _ {a₁ a₂ ℓ₁ ℓ₂} {A₁ : Set a₁} {A₂ : Set a₂} where

  ×-Lex : (_≈₁_ _<₁_ : Rel A₁ ℓ₁) → (_≤₂_ : Rel A₂ ℓ₂) →
          Rel (A₁ × A₂) _
  ×-Lex _≈₁_ _<₁_ _≤₂_ =
    (_<₁_ on proj₁) -⊎- (_≈₁_ on proj₁) -×- (_≤₂_ on proj₂)

  -- Some properties which are preserved by ×-Lex (under certain
  -- assumptions).

  ×-reflexive : ∀ _≈₁_ _∼₁_ {_≈₂_ : Rel A₂ ℓ₂} _≤₂_ →
                _≈₂_ ⇒ _≤₂_ → (_≈₁_ ×-Rel _≈₂_) ⇒ (×-Lex _≈₁_ _∼₁_ _≤₂_)
  ×-reflexive _ _ _ refl₂ = λ x≈y →
    inj₂ (proj₁ x≈y , refl₂ (proj₂ x≈y))

  _×-irreflexive_ : ∀ {_≈₁_ _<₁_}             → Irreflexive _≈₁_ _<₁_ →
                    ∀ {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → Irreflexive _≈₂_ _<₂_ →
                    Irreflexive (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  (ir₁ ×-irreflexive ir₂) x≈y (inj₁ x₁<y₁) = ir₁ (proj₁ x≈y) x₁<y₁
  (ir₁ ×-irreflexive ir₂) x≈y (inj₂ x≈<y)  =
    ir₂ (proj₂ x≈y) (proj₂ x≈<y)

  ×-transitive :
    ∀ {_≈₁_ _<₁_} →
    IsEquivalence _≈₁_ → _<₁_ Respects₂ _≈₁_ → Transitive _<₁_ →
    ∀ {_≤₂_} →
    Transitive _≤₂_ →
    Transitive (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-transitive {_≈₁_ = _≈₁_} {_<₁_ = _<₁_} eq₁ resp₁ trans₁
               {_≤₂_ = _≤₂_} trans₂ {x} {y} {z} = trans {x} {y} {z}
    where
    module Eq₁ = IsEquivalence eq₁

    trans : Transitive (×-Lex _≈₁_ _<₁_ _≤₂_)
    trans (inj₁ x₁<y₁) (inj₁ y₁<z₁) = inj₁ (trans₁ x₁<y₁ y₁<z₁)
    trans (inj₁ x₁<y₁) (inj₂ y≈≤z)  =
      inj₁ (proj₁ resp₁ (proj₁ y≈≤z) x₁<y₁)
    trans (inj₂ x≈≤y)  (inj₁ y₁<z₁) =
      inj₁ (proj₂ resp₁ (Eq₁.sym $ proj₁ x≈≤y) y₁<z₁)
    trans (inj₂ x≈≤y)  (inj₂ y≈≤z)  =
      inj₂ ( Eq₁.trans (proj₁ x≈≤y) (proj₁ y≈≤z)
           , trans₂    (proj₂ x≈≤y) (proj₂ y≈≤z) )

  ×-antisymmetric :
    ∀ {_≈₁_ _<₁_} →
    Symmetric _≈₁_ → Irreflexive _≈₁_ _<₁_ → Asymmetric _<₁_ →
    ∀ {_≈₂_ _≤₂_ : Rel A₂ ℓ₂} →
    Antisymmetric _≈₂_ _≤₂_ →
    Antisymmetric (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-antisymmetric {_≈₁_ = _≈₁_} {_<₁_ = _<₁_} sym₁ irrefl₁ asym₁
                  {_≈₂_ = _≈₂_} {_≤₂_ = _≤₂_} antisym₂ {x} {y} =
    antisym {x} {y}
    where
    antisym : Antisymmetric (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _≤₂_)
    antisym (inj₁ x₁<y₁) (inj₁ y₁<x₁) = ⊥-elim $ asym₁ x₁<y₁ y₁<x₁
    antisym (inj₁ x₁<y₁) (inj₂ y≈≤x)  = ⊥-elim $ irrefl₁ (sym₁ $ proj₁ y≈≤x) x₁<y₁
    antisym (inj₂ x≈≤y)  (inj₁ y₁<x₁) = ⊥-elim $ irrefl₁ (sym₁ $ proj₁ x≈≤y) y₁<x₁
    antisym (inj₂ x≈≤y)  (inj₂ y≈≤x)  =
      proj₁ x≈≤y , antisym₂ (proj₂ x≈≤y) (proj₂ y≈≤x)

  ×-asymmetric :
    ∀ {_≈₁_ _<₁_} →
    Symmetric _≈₁_ → _<₁_ Respects₂ _≈₁_ → Asymmetric _<₁_ →
    ∀ {_<₂_} →
    Asymmetric _<₂_ →
    Asymmetric (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-asymmetric {_≈₁_ = _≈₁_} {_<₁_ = _<₁_} sym₁ resp₁ asym₁
               {_<₂_ = _<₂_} asym₂ {x} {y} = asym {x} {y}
    where
    irrefl₁ : Irreflexive _≈₁_ _<₁_
    irrefl₁ = asym⟶irr resp₁ sym₁ asym₁

    asym : Asymmetric (×-Lex _≈₁_ _<₁_ _<₂_)
    asym (inj₁ x₁<y₁) (inj₁ y₁<x₁) = asym₁ x₁<y₁ y₁<x₁
    asym (inj₁ x₁<y₁) (inj₂ y≈<x)  = irrefl₁ (sym₁ $ proj₁ y≈<x) x₁<y₁
    asym (inj₂ x≈<y)  (inj₁ y₁<x₁) = irrefl₁ (sym₁ $ proj₁ x≈<y) y₁<x₁
    asym (inj₂ x≈<y)  (inj₂ y≈<x)  = asym₂ (proj₂ x≈<y) (proj₂ y≈<x)

  ×-≈-respects₂ :
    ∀ {_≈₁_ _<₁_} → IsEquivalence _≈₁_ → _<₁_ Respects₂ _≈₁_ →
    {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → _<₂_ Respects₂ _≈₂_ →
    (×-Lex _≈₁_ _<₁_ _<₂_) Respects₂ (_≈₁_ ×-Rel _≈₂_)
  ×-≈-respects₂ {_≈₁_ = _≈₁_} {_<₁_ = _<₁_} eq₁ resp₁
                {_≈₂_ = _≈₂_} {_<₂_ = _<₂_}     resp₂ =
    (λ {x y z} → resp¹ {x} {y} {z}) ,
    (λ {x y z} → resp² {x} {y} {z})
    where
    _<_ = ×-Lex _≈₁_ _<₁_ _<₂_

    open IsEquivalence eq₁ renaming (sym to sym₁; trans to trans₁)

    resp¹ : ∀ {x} → (_<_ x) Respects (_≈₁_ ×-Rel _≈₂_)
    resp¹ y≈y' (inj₁ x₁<y₁) = inj₁ (proj₁ resp₁ (proj₁ y≈y') x₁<y₁)
    resp¹ y≈y' (inj₂ x≈<y)  =
      inj₂ ( trans₁ (proj₁ x≈<y) (proj₁ y≈y')
           , proj₁ resp₂ (proj₂ y≈y') (proj₂ x≈<y) )

    resp² : ∀ {y} → (flip _<_ y) Respects (_≈₁_ ×-Rel _≈₂_)
    resp² x≈x' (inj₁ x₁<y₁) = inj₁ (proj₂ resp₁ (proj₁ x≈x') x₁<y₁)
    resp² x≈x' (inj₂ x≈<y)  =
      inj₂ ( trans₁ (sym₁ $ proj₁ x≈x') (proj₁ x≈<y)
           , proj₂ resp₂ (proj₂ x≈x') (proj₂ x≈<y) )

  ×-decidable : ∀ {_≈₁_ _<₁_} → Decidable _≈₁_ → Decidable _<₁_ →
                ∀ {_≤₂_} → Decidable _≤₂_ →
                Decidable (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-decidable dec-≈₁ dec-<₁ dec-≤₂ = λ x y →
    dec-<₁ (proj₁ x) (proj₁ y)
      ⊎-dec
    (dec-≈₁ (proj₁ x) (proj₁ y)
       ×-dec
     dec-≤₂ (proj₂ x) (proj₂ y))

  ×-total : ∀ {_≈₁_ _<₁_} → Total _<₁_ →
            ∀ {_≤₂_} →
            Total (×-Lex _≈₁_ _<₁_ _≤₂_)
  ×-total {_≈₁_ = _≈₁_} {_<₁_ = _<₁_} total₁ {_≤₂_ = _≤₂_} = total
    where
    total : Total (×-Lex _≈₁_ _<₁_ _≤₂_)
    total x y with total₁ (proj₁ x) (proj₁ y)
    ... | inj₁ x₁<y₁ = inj₁ (inj₁ x₁<y₁)
    ... | inj₂ x₁>y₁ = inj₂ (inj₁ x₁>y₁)

  ×-compare :
    {_≈₁_ _<₁_ : Rel A₁ ℓ₁} → Symmetric _≈₁_ → Trichotomous _≈₁_ _<₁_ →
    {_≈₂_ _<₂_ : Rel A₂ ℓ₂} → Trichotomous _≈₂_ _<₂_ →
    Trichotomous (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  ×-compare {_≈₁_} {_<₁_} sym₁ compare₁ {_≈₂_} {_<₂_} compare₂ = cmp
    where
    cmp″ : ∀ {x₁ y₁ x₂ y₂} →
           ¬ (x₁ <₁ y₁) → x₁ ≈₁ y₁ → ¬ (y₁ <₁ x₁) →
           Tri (x₂ <₂ y₂) (x₂ ≈₂ y₂) (y₂ <₂ x₂) →
           Tri (×-Lex _≈₁_ _<₁_ _<₂_ (x₁ , x₂) (y₁ , y₂))
               ((_≈₁_ ×-Rel _≈₂_) (x₁ , x₂) (y₁ , y₂))
               (×-Lex _≈₁_ _<₁_ _<₂_ (y₁ , y₂) (x₁ , x₂))
    cmp″ x₁≮y₁ x₁≈y₁ x₁≯y₁ (tri< x₂<y₂ x₂≉y₂ x₂≯y₂) =
      tri< (inj₂ (x₁≈y₁ , x₂<y₂))
           (x₂≉y₂ ∘ proj₂)
           [ x₁≯y₁ , x₂≯y₂ ∘ proj₂ ]
    cmp″ x₁≮y₁ x₁≈y₁ x₁≯y₁ (tri> x₂≮y₂ x₂≉y₂ x₂>y₂) =
      tri> [ x₁≮y₁ , x₂≮y₂ ∘ proj₂ ]
           (x₂≉y₂ ∘ proj₂)
           (inj₂ (sym₁ x₁≈y₁ , x₂>y₂))
    cmp″ x₁≮y₁ x₁≈y₁ x₁≯y₁ (tri≈ x₂≮y₂ x₂≈y₂ x₂≯y₂) =
      tri≈ [ x₁≮y₁ , x₂≮y₂ ∘ proj₂ ]
           (x₁≈y₁ , x₂≈y₂)
           [ x₁≯y₁ , x₂≯y₂ ∘ proj₂ ]

    cmp′ : ∀ {x₁ y₁} → Tri (x₁ <₁ y₁) (x₁ ≈₁ y₁) (y₁ <₁ x₁) →
           ∀ x₂ y₂ →
           Tri (×-Lex _≈₁_ _<₁_ _<₂_ (x₁ , x₂) (y₁ , y₂))
               ((_≈₁_ ×-Rel _≈₂_) (x₁ , x₂) (y₁ , y₂))
               (×-Lex _≈₁_ _<₁_ _<₂_ (y₁ , y₂) (x₁ , x₂))
    cmp′ (tri< x₁<y₁ x₁≉y₁ x₁≯y₁) x₂ y₂ =
      tri< (inj₁ x₁<y₁) (x₁≉y₁ ∘ proj₁) [ x₁≯y₁ , x₁≉y₁ ∘ sym₁ ∘ proj₁ ]
    cmp′ (tri> x₁≮y₁ x₁≉y₁ x₁>y₁) x₂ y₂ =
      tri> [ x₁≮y₁ , x₁≉y₁ ∘ proj₁ ] (x₁≉y₁ ∘ proj₁) (inj₁ x₁>y₁)
    cmp′ (tri≈ x₁≮y₁ x₁≈y₁ x₁≯y₁) x₂ y₂ =
      cmp″ x₁≮y₁ x₁≈y₁ x₁≯y₁ (compare₂ x₂ y₂)

    cmp : Trichotomous (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
    cmp (x₁ , x₂) (y₁ , y₂) = cmp′ (compare₁ x₁ y₁) x₂ y₂

  -- Some collections of properties which are preserved by ×-Lex.

  _×-isPreorder_ : ∀ {_≈₁_ _∼₁_} → IsPreorder _≈₁_ _∼₁_ →
                   ∀ {_≈₂_ _∼₂_} → IsPreorder _≈₂_ _∼₂_ →
                   IsPreorder (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _∼₁_ _∼₂_)
  _×-isPreorder_ {_≈₁_ = _≈₁_} {_∼₁_ = _∼₁_} pre₁ {_∼₂_ = _∼₂_} pre₂ =
    record
      { isEquivalence = Pointwise._×-isEquivalence_
                          (isEquivalence pre₁) (isEquivalence pre₂)
      ; reflexive     = λ {x y} →
                        ×-reflexive _≈₁_ _∼₁_ _∼₂_ (reflexive pre₂)
                                    {x} {y}
      ; trans         = λ {x y z} →
                        ×-transitive
                          (isEquivalence pre₁) (∼-resp-≈ pre₁)
                          (trans pre₁) {_≤₂_ = _∼₂_} (trans pre₂)
                          {x} {y} {z}
      }
    where open IsPreorder

  _×-isStrictPartialOrder_ :
    ∀ {_≈₁_ _<₁_} → IsStrictPartialOrder _≈₁_ _<₁_ →
    ∀ {_≈₂_ _<₂_} → IsStrictPartialOrder _≈₂_ _<₂_ →
    IsStrictPartialOrder (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  _×-isStrictPartialOrder_ {_<₁_ = _<₁_} spo₁ {_<₂_ = _<₂_} spo₂ =
    record
      { isEquivalence = Pointwise._×-isEquivalence_
                          (isEquivalence spo₁) (isEquivalence spo₂)
      ; irrefl        = λ {x y} →
                        _×-irreflexive_ {_<₁_ = _<₁_} (irrefl spo₁)
                                        {_<₂_ = _<₂_} (irrefl spo₂)
                                        {x} {y}
      ; trans         = λ {x y z} →
                        ×-transitive
                          {_<₁_ = _<₁_} (isEquivalence spo₁)
                                        (<-resp-≈ spo₁) (trans spo₁)
                          {_≤₂_ = _<₂_} (trans spo₂) {x} {y} {z}
      ; <-resp-≈      = ×-≈-respects₂ (isEquivalence spo₁)
                                      (<-resp-≈ spo₁)
                                      (<-resp-≈ spo₂)
      }
    where open IsStrictPartialOrder

  _×-isStrictTotalOrder_ :
    ∀ {_≈₁_ _<₁_} → IsStrictTotalOrder _≈₁_ _<₁_ →
    ∀ {_≈₂_ _<₂_} → IsStrictTotalOrder _≈₂_ _<₂_ →
    IsStrictTotalOrder (_≈₁_ ×-Rel _≈₂_) (×-Lex _≈₁_ _<₁_ _<₂_)
  _×-isStrictTotalOrder_ {_<₁_ = _<₁_} spo₁ {_<₂_ = _<₂_} spo₂ =
    record
      { isEquivalence = Pointwise._×-isEquivalence_
                          (isEquivalence spo₁) (isEquivalence spo₂)
      ; trans         = λ {x y z} →
                        ×-transitive
                          {_<₁_ = _<₁_} (isEquivalence spo₁)
                                        (<-resp-≈ spo₁) (trans spo₁)
                          {_≤₂_ = _<₂_} (trans spo₂) {x} {y} {z}
      ; compare       = ×-compare (Eq.sym spo₁) (compare spo₁)
                                                (compare spo₂)
      ; <-resp-≈      = ×-≈-respects₂ (isEquivalence spo₁)
                                      (<-resp-≈ spo₁)
                                      (<-resp-≈ spo₂)
      }
    where open IsStrictTotalOrder

-- "Packages" (e.g. preorders) can also be combined.

_×-preorder_ :
  ∀ {p₁ p₂ p₃ p₄} →
  Preorder p₁ p₂ _ → Preorder p₃ p₄ _ → Preorder _ _ _
p₁ ×-preorder p₂ = record
  { isPreorder = isPreorder p₁ ×-isPreorder isPreorder p₂
  } where open Preorder

_×-strictPartialOrder_ :
  ∀ {s₁ s₂ s₃ s₄} →
  StrictPartialOrder s₁ s₂ _ → StrictPartialOrder s₃ s₄ _ →
  StrictPartialOrder _ _ _
s₁ ×-strictPartialOrder s₂ = record
  { isStrictPartialOrder = isStrictPartialOrder s₁
                             ×-isStrictPartialOrder
                           isStrictPartialOrder s₂
  } where open StrictPartialOrder

_×-strictTotalOrder_ :
  ∀ {s₁ s₂ s₃ s₄} →
  StrictTotalOrder s₁ s₂ _ → StrictTotalOrder s₃ s₄ _ →
  StrictTotalOrder _ _ _
s₁ ×-strictTotalOrder s₂ = record
  { isStrictTotalOrder = isStrictTotalOrder s₁
                           ×-isStrictTotalOrder
                         isStrictTotalOrder s₂
  } where open StrictTotalOrder


open import Common.IO
open import Common.Unit
open import Common.String
open import Common.Nat

record Stream (A : Set) : Set where
  coinductive
  field
    head : A
    tail : Stream A
open Stream public

repeat : ∀ {A} → A → Stream A
head (repeat x) = x
tail (repeat x) = repeat x

lookup : ∀ {A} → Stream A → Nat → A
lookup xs zero = xs .head
lookup xs (suc n) = lookup (xs .tail) n

main : IO Unit
main = putStr (lookup (repeat "hello") 1000000)


module PiQ.AuxLemmas where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import PiQ.Syntax
open import PiQ.Opsem

Lemma₁ : ∀ {A B C D v v' κ κ'} {c : A ↔ B} {c' : C ↔ D}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⟨ c' ∣ v' ∣ κ' ⟩◁
       → A ≡ C × B ≡ D
Lemma₁ ↦⃖₁ = refl , refl
Lemma₁ ↦⃖₂ = refl , refl
Lemma₁ ↦⃖ηₓ₁ = refl , refl
Lemma₁ ↦⃖εₓ = refl , refl

Lemma₂ : ∀ {A B v v' κ κ'} {c c' : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⟨ c' ∣ v' ∣ κ' ⟩◁
       → c ≡ c' × κ ≡ κ'
Lemma₂ ↦⃖₁ = refl , refl
Lemma₂ ↦⃖₂ = refl , refl
Lemma₂ ↦⃖ηₓ₁ = refl , refl
Lemma₂ ↦⃖εₓ = refl , refl

Lemma₃ : ∀ {A B v v' κ} {c : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⟨ c ∣ v' ∣ κ ⟩◁
       → base c ⊎ dual c ⊎ A ≡ B
Lemma₃ (↦⃖₁ {b = b}) = inj₁ b
Lemma₃ ↦⃖₂ = inj₂ (inj₂ refl)
Lemma₃ ↦⃖ηₓ₁ = inj₂ (inj₁ tt)
Lemma₃ ↦⃖εₓ = inj₂ (inj₁ tt)

Lemma₄ : ∀ {A v v' κ} {c : A ↔ A}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⟨ c ∣ v' ∣ κ ⟩◁
       → base c ⊎ c ≡ id↔
Lemma₄ (↦⃖₁ {b = b}) = inj₁ b
Lemma₄ ↦⃖₂ = inj₂ refl

Lemma₅ : ∀ {A B C D v v' κ κ'} {c : A ↔ B} {c' : C ↔ D}
       → ［ c ∣ v ∣ κ ］◁ ↦ ［ c' ∣ v' ∣ κ' ］▷
       → A ≡ C × B ≡ D
Lemma₅ ↦η₊₁ = refl , refl
Lemma₅ ↦η₊₂ = refl , refl

Lemma₆ : ∀ {A B v v' κ κ'} {c c' : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ［ c' ∣ v' ∣ κ' ］▷
       → c ≡ c' × κ ≡ κ'
Lemma₆ ↦η₊₁ = refl , refl
Lemma₆ ↦η₊₂ = refl , refl

Lemma₇ : ∀ {A B v v' κ} {c : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ［ c ∣ v' ∣ κ ］▷
       →  A ≡ 𝟘
Lemma₇ ↦η₊₁ = refl
Lemma₇ ↦η₊₂ = refl

Lemma₈ : ∀ {A B v κ} {c : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⊠
       → ¬ (base c)
Lemma₈ ↦⃖ηₓ₂ ()

Lemma₉ : ∀ {A B} {κ : Context} {v : ⟦ B ⟧} {v' : ⟦ A ⟧} {c : A ↔ B}
       → ［ c ∣ v ∣ κ ］◁ ↦ ⟨ c ∣ v' ∣ κ ⟩◁
       → ［ c ∣ v ∣ κ ］◁ ↦ ⊠
       → ⊥
Lemma₉ r' r with Lemma₈ r
Lemma₉ (↦⃖₁ {b = b}) r | nb = nb b
Lemma₉ (↦⃖ηₓ₁ {eq = eq}) (↦⃖ηₓ₂ {neq = neq}) | _ = ⊥-elim (neq eq)

Lemma₁₀ : ∀ {A B C D v v' κ κ'} {c : A ↔ B} {c' : C ↔ D}
        → ⟨ c ∣ v ∣ κ ⟩▷ ↦ ［ c' ∣ v' ∣ κ' ］▷
        → (A ≡ C × B ≡ D)
Lemma₁₀ ↦⃗₁ = refl , refl
Lemma₁₀ ↦⃗₂ = refl , refl
Lemma₁₀ ↦⃗ηₓ = refl , refl
Lemma₁₀ ↦⃗εₓ₁ = refl , refl

Lemma₁₁ : ∀ {A B v v' κ κ'} {c c' : A ↔ B}
        → ⟨ c ∣ v ∣ κ ⟩▷ ↦ ［ c' ∣ v' ∣ κ' ］▷
        → c ≡ c' × κ ≡ κ'
Lemma₁₁ ↦⃗₁ = refl , refl
Lemma₁₁ ↦⃗₂ = refl , refl
Lemma₁₁ ↦⃗ηₓ = refl , refl
Lemma₁₁ ↦⃗εₓ₁ = refl , refl

Lemma₁₂ : ∀ {A B v v' κ} {c : A ↔ B}
        → (r : ⟨ c ∣ v ∣ κ ⟩▷ ↦ ［ c ∣ v' ∣ κ ］▷)
        → base c ⊎ dual c ⊎ A ≡ B
Lemma₁₂ (↦⃗₁ {b = b}) = inj₁ b
Lemma₁₂ ↦⃗₂ = inj₂ (inj₂ refl)
Lemma₁₂ ↦⃗ηₓ = inj₂ (inj₁ tt)
Lemma₁₂ ↦⃗εₓ₁ = inj₂ (inj₁ tt)

Lemma₁₃ : ∀ {A v v' κ} {c : A ↔ A}
        → (r : ⟨ c ∣ v ∣ κ ⟩▷ ↦ ［ c ∣ v' ∣ κ ］▷)
        → base c ⊎ c ≡ id↔
Lemma₁₃ (↦⃗₁ {b = b}) = inj₁ b
Lemma₁₃ ↦⃗₂ = inj₂ refl


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRingSolver.HornerEval where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Int hiding (_+_ ; _·_ ; -_)
open import Cubical.Data.Vec
open import Cubical.Data.Bool

open import Cubical.Relation.Nullary.Base using (¬_; yes; no)

open import Cubical.Algebra.CommRingSolver.Utility
open import Cubical.Algebra.CommRingSolver.RawAlgebra
open import Cubical.Algebra.CommRingSolver.IntAsRawRing
open import Cubical.Algebra.CommRingSolver.HornerForms
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring

private
  variable
    ℓ ℓ' : Level

eval : {A : RawAlgebra ℤAsRawRing ℓ'}
       {n : ℕ} (P : IteratedHornerForms A n)
       → Vec ⟨ A ⟩ n → ⟨ A ⟩
eval {A = A} (const r) [] = RawAlgebra.scalar A r
eval {A = A} 0H (_ ∷ _) = RawAlgebra.0r A
eval {A = A} (P ·X+ Q) (x ∷ xs) =
     let open RawAlgebra A
         P' = (eval P (x ∷ xs))
         Q' = eval Q xs
     in if (isZero A P)
        then Q'
        else P' · x + Q'

module _ (R : CommRing ℓ) where
  private
    νR = CommRing→RawℤAlgebra R
  open CommRingStr (snd R)
  open RingTheory (CommRing→Ring R)
  open IteratedHornerOperations νR

  someCalculation : {x : fst R} → _ ≡ _
  someCalculation {x = x} =
    0r                   ≡⟨ sym (+IdR 0r) ⟩
    0r + 0r              ≡[ i ]⟨ 0LeftAnnihilates x (~ i) + 0r ⟩
    0r · x + 0r          ∎

  evalIsZero : {n : ℕ} (P : IteratedHornerForms νR n)
             → (l : Vec (fst R) n)
             → isZero νR P ≡ true
             → eval P l ≡ 0r
  evalIsZero (const (pos ℕ.zero)) [] isZeroP = refl
  evalIsZero (const (pos (ℕ.suc n))) [] isZeroP = byBoolAbsurdity isZeroP
  evalIsZero (const (negsuc _)) [] isZeroP = byBoolAbsurdity isZeroP
  evalIsZero 0H (x ∷ xs) _ = refl
  evalIsZero {n = ℕ.suc n} (P ·X+ Q) (x ∷ xs) isZeroPandQ with isZero νR P
  ... | true = eval Q xs   ≡⟨ evalIsZero Q xs isZeroQ ⟩
               0r ∎
               where isZeroQ = snd (extractFromAnd _ _ isZeroPandQ)
  ... | false = byBoolAbsurdity isZeroP
               where isZeroP = fst (extractFromAnd _ _ isZeroPandQ)

  computeEvalSummandIsZero :
               {n : ℕ}
               (P : IteratedHornerForms νR (ℕ.suc n))
               (Q : IteratedHornerForms νR n)
             → (xs : Vec (fst R) n)
             → (x : (fst R))
             → isZero νR P ≡ true
             → eval (P ·X+ Q) (x ∷ xs) ≡ eval Q xs
  computeEvalSummandIsZero P Q xs x isZeroP with isZero νR P
  ... | true = refl
  ... | false = byBoolAbsurdity isZeroP

  computeEvalNotZero :
               {n : ℕ}
               (P : IteratedHornerForms νR (ℕ.suc n))
               (Q : IteratedHornerForms νR n)
             → (xs : Vec (fst R) n)
             → (x : (fst R))
             → ¬ (isZero νR P ≡ true)
             → eval (P ·X+ Q) (x ∷ xs) ≡ (eval P (x ∷ xs)) · x + eval Q xs
  computeEvalNotZero P Q xs x notZeroP with isZero νR P
  ... | true = byBoolAbsurdity (sym (¬true→false true notZeroP))
  ... | false = refl

  combineCasesEval :
    {n : ℕ}  (P : IteratedHornerForms νR (ℕ.suc n)) (Q : IteratedHornerForms νR n)
    (x : (fst R)) (xs : Vec (fst R) n)
    →   eval (P ·X+ Q) (x ∷ xs)
      ≡ (eval P (x ∷ xs)) · x + eval Q xs
  combineCasesEval P Q x xs with isZero νR P ≟ true
  ... | yes p =
       eval (P ·X+ Q) (x ∷ xs)            ≡⟨ computeEvalSummandIsZero P Q xs x p ⟩
       eval Q xs                          ≡⟨ sym (+IdL _) ⟩
       0r + eval Q xs                     ≡[ i ]⟨ 0LeftAnnihilates x (~ i) + eval Q xs ⟩
       0r · x + eval Q xs                 ≡[ i ]⟨ (evalIsZero P (x ∷ xs) p (~ i)) · x + eval Q xs ⟩
       (eval P (x ∷ xs)) · x + eval Q xs ∎
  ... | no p  = computeEvalNotZero P Q xs x p

  compute+ₕEvalBothZero :
    (n : ℕ) (P Q : IteratedHornerForms νR (ℕ.suc n))
    (r s : IteratedHornerForms νR n)
    (x : (fst R)) (xs : Vec (fst R) n)
    → (isZero νR (P +ₕ Q) and isZero νR (r +ₕ s)) ≡ true
    → eval ((P ·X+ r) +ₕ (Q ·X+ s)) (x ∷ xs) ≡ eval ((P +ₕ Q) ·X+ (r +ₕ s)) (x ∷ xs)
  compute+ₕEvalBothZero n P Q r s x xs bothZero with isZero νR (P +ₕ Q) and isZero νR (r +ₕ s) | bothZero
  ... | true | p =
               eval {A = νR} 0H (x ∷ xs)                            ≡⟨ refl ⟩
               0r                                                   ≡⟨ someCalculation ⟩
               0r · x + 0r                                          ≡⟨ step1  ⟩
               (eval (P +ₕ Q) (x ∷ xs)) · x + eval (r +ₕ s) xs       ≡⟨ step2 ⟩
               eval ((P +ₕ Q) ·X+ (r +ₕ s)) (x ∷ xs) ∎
            where step1 : 0r · x + 0r ≡ (eval (P +ₕ Q) (x ∷ xs)) · x + eval (r +ₕ s) xs
                  step1 i = (evalIsZero (P +ₕ Q) (x ∷ xs) (fst (extractFromAnd _ _ (bothZero))) (~ i)) · x
                    + (evalIsZero (r +ₕ s) xs (snd (extractFromAnd _ _ (bothZero))) (~ i))
                  step2 = sym (combineCasesEval (P +ₕ Q) (r +ₕ s) x xs)
  ... | false | p = byBoolAbsurdity p

  compute+ₕEvalNotBothZero :
    (n : ℕ) (P Q : IteratedHornerForms νR (ℕ.suc n))
    (r s : IteratedHornerForms νR n)
    (x : (fst R)) (xs : Vec (fst R) n)
    → (isZero νR (P +ₕ Q) and isZero νR (r +ₕ s)) ≡ false
    → eval ((P ·X+ r) +ₕ (Q ·X+ s)) (x ∷ xs) ≡ eval ((P +ₕ Q) ·X+ (r +ₕ s)) (x ∷ xs)
  compute+ₕEvalNotBothZero n P Q r s _ _ notBothZero
    with isZero νR (P +ₕ Q) and isZero νR (r +ₕ s) | notBothZero
  ... | true | p = byBoolAbsurdity (sym p)
  ... | false | p = refl


-- Andreas, 2021-04-22, issue #5339
-- Allow constructors of the same name in `constructor` block.

module _ where

module Works where

  interleaved mutual
    data Nat : Set
    data Fin : Nat → Set
    data _ where
      zero : Nat
    data _ where
      suc  : Nat → Nat
      zero : ∀ {n} → Fin (suc n)
    data _ where
      suc : ∀ {n} (i : Fin n) → Fin (suc n)

interleaved mutual
  data Nat : Set
  data Fin : Nat → Set
  data _ where
    zero : Nat
    suc  : Nat → Nat
    zero : ∀ {n} → Fin (suc n)
    suc  : ∀ {n} (i : Fin n) → Fin (suc n)

-- `data _ where` block should be accepted despite duplicate constructor names.

wkFin : ∀{n} → Fin n → Fin (suc n)
wkFin zero    = zero
wkFin (suc i) = suc (wkFin i)