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

open import lib.Basics

module lib.types.Sigma where

-- Cartesian product
_×_ : ∀ {i j} (A : Type i) (B : Type j) → Type (lmax i j)
A × B = Σ A (λ _ → B)

module _ {i j} {A : Type i} {B : A → Type j} where

  pair : (a : A) (b : B a) → Σ A B
  pair a b = (a , b)

  -- pair= has already been defined

  fst= : {ab a'b' : Σ A B} (p : ab == a'b') → (fst ab == fst a'b')
  fst= = ap fst

  snd= : {ab a'b' : Σ A B} (p : ab == a'b')
    → (snd ab == snd a'b' [ B ↓ fst= p ])
  snd= {._} {_} idp = idp

  fst=-β : {a a' : A} (p : a == a')
    {b : B a} {b' : B a'} (q : b == b' [ B ↓ p ])
    → fst= (pair= p q) == p
  fst=-β idp idp = idp

  snd=-β : {a a' : A} (p : a == a')
    {b : B a} {b' : B a'} (q : b == b' [ B ↓ p ])
    → snd= (pair= p q) == q [ (λ v → b == b' [ B ↓ v ]) ↓ fst=-β p q ]
  snd=-β idp idp = idp

  pair=-η : {ab a'b' : Σ A B} (p : ab == a'b')
    → p == pair= (fst= p) (snd= p)
  pair=-η {._} {_} idp = idp

  pair== : {a a' : A} {p p' : a == a'} (α : p == p')
           {b : B a} {b' : B a'} {q : b == b' [ B ↓ p ]} {q' : b == b' [ B ↓ p' ]}
           (β : q == q' [ (λ u → b == b' [ B ↓ u ]) ↓ α ])
    → pair= p q == pair= p' q'
  pair== idp idp = idp

module _ {i j} {A : Type i} {B : Type j} where

  fst×= : {ab a'b' : A × B} (p : ab == a'b') → (fst ab == fst a'b')
  fst×= = ap fst

  snd×= : {ab a'b' : A × B} (p : ab == a'b')
    → (snd ab == snd a'b')
  snd×= = ap snd

  fst×=-β : {a a' : A} (p : a == a')
    {b b' : B} (q : b == b')
    → fst×= (pair×= p q) == p
  fst×=-β idp idp = idp

  snd×=-β : {a a' : A} (p : a == a')
    {b b' : B} (q : b == b')
    → snd×= (pair×= p q) == q
  snd×=-β idp idp = idp

module _ {i j} {A : Type i} {B : A → Type j} where

  =Σ : (x y : Σ A B) → Type (lmax i j)
  =Σ (a , b) (a' , b') = Σ (a == a') (λ p → b == b' [ B ↓ p ])

  =Σ-eqv : (x y : Σ A B) →  (=Σ x y) ≃ (x == y)
  =Σ-eqv x y =
    equiv (λ pq → pair= (fst pq) (snd pq)) (λ p → fst= p , snd= p)
          (λ p → ! (pair=-η p))
          (λ pq → pair= (fst=-β (fst pq) (snd pq)) (snd=-β (fst pq) (snd pq)))

  =Σ-path : (x y : Σ A B) → (=Σ x y) == (x == y)
  =Σ-path x y = ua (=Σ-eqv x y)

Σ= : ∀ {i j} {A A' : Type i} (p : A == A') {B : A → Type j} {B' : A' → Type j}
  (q : B == B' [ (λ X → (X → Type j)) ↓ p ]) → Σ A B == Σ A' B'
Σ= idp idp = idp

abstract

  Σ-level : ∀ {i j} {n : ℕ₋₂} {A : Type i} {P : A → Type j}
    → (has-level n A → ((x : A) → has-level n (P x))
      → has-level n (Σ A P))
  Σ-level {n = ⟨-2⟩} p q =
    ((fst p , (fst (q (fst p)))) ,
      (λ y → pair= (snd p _) (from-transp! _ _ (snd (q _) _))))
  Σ-level {n = S n} p q = λ x y → equiv-preserves-level (=Σ-eqv x y)
    (Σ-level (p _ _)
      (λ _ → equiv-preserves-level ((to-transp-equiv _ _)⁻¹) (q _ _ _)))

  ×-level : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j}
    → (has-level n A → has-level n B → has-level n (A × B))
  ×-level pA pB = Σ-level pA (λ x → pB)

-- Equivalences in a Σ-type

equiv-Σ-fst : ∀ {i j k} {A : Type i} {B : Type j} (P : B → Type k) {h : A → B}
                  → is-equiv h → (Σ A (P ∘ h)) ≃ (Σ B P)
equiv-Σ-fst {A = A} {B = B} P {h = h} e = equiv f g f-g g-f
  where f : Σ A (P ∘ h) → Σ B P
        f (a , r) = (h a , r)

        g : Σ B P → Σ A (P ∘ h)
        g (b , s) = (is-equiv.g e b , transport P (! (is-equiv.f-g e b)) s)

        f-g : ∀ y → f (g y) == y
        f-g (b , s) = pair= (is-equiv.f-g e b) (trans-↓ P (is-equiv.f-g e b) s)

        g-f : ∀ x → g (f x) == x
        g-f (a , r) =
          pair= (is-equiv.g-f e a)
                (transport (λ q → transport P (! q) r == r [ P ∘ h ↓ is-equiv.g-f e a ])
                           (is-equiv.adj e a)
                           (trans-ap-↓ P h (is-equiv.g-f e a) r) )

equiv-Σ-snd : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  → (∀ x → B x ≃ C x) → Σ A B ≃ Σ A C
equiv-Σ-snd {A = A} {B = B} {C = C} k = equiv f g f-g g-f
  where f : Σ A B → Σ A C
        f (a , b) = (a , fst (k a) b)

        g : Σ A C → Σ A B
        g (a , c) = (a , is-equiv.g (snd (k a)) c)

        f-g : ∀ p → f (g p) == p
        f-g (a , c) = pair= idp (is-equiv.f-g (snd (k a)) c)

        g-f : ∀ p → g (f p) == p
        g-f (a , b) = pair= idp (is-equiv.g-f (snd (k a)) b)

-- Two ways of simultaneously applying equivalences in each component.
module _ {i₀ i₁ j₀ j₁} {A₀ : Type i₀} {A₁ : Type i₁}
         {B₀ : A₀ → Type j₀} {B₁ : A₁ → Type j₁} where
  equiv-Σ : (u : A₀ ≃ A₁) (v : ∀ a → B₀ (<– u a) ≃ B₁ a) → Σ A₀ B₀ ≃ Σ A₁ B₁
  equiv-Σ u v = Σ A₀ B₀           ≃⟨ equiv-Σ-fst _ (snd (u ⁻¹)) ⁻¹ ⟩
                Σ A₁ (B₀ ∘ <– u)  ≃⟨ equiv-Σ-snd v ⟩
                Σ A₁ B₁           ≃∎

  equiv-Σ' : (u : A₀ ≃ A₁) (v : ∀ a → B₀ a ≃ B₁ (–> u a)) → Σ A₀ B₀ ≃ Σ A₁ B₁
  equiv-Σ' u v = Σ A₀ B₀           ≃⟨ equiv-Σ-snd v ⟩
                 Σ A₀ (B₁ ∘ –> u)  ≃⟨ equiv-Σ-fst _ (snd u) ⟩
                 Σ A₁ B₁           ≃∎

-- Implementation of [_∙'_] on Σ
Σ-∙' : ∀ {i j} {A : Type i} {B : A → Type j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
  → (pair= p q ∙' pair= p' r) == pair= (p ∙' p') (q ∙'ᵈ r)
Σ-∙' {p = idp} {p' = idp} q idp = idp

-- Implementation of [_∙_] on Σ
Σ-∙ : ∀ {i j} {A : Type i} {B : A → Type j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
  → (pair= p q ∙ pair= p' r) == pair= (p ∙ p') (q ∙ᵈ r)
Σ-∙ {p = idp} {p' = idp} idp r = idp

-- Implementation of [_∙'_] on ×
×-∙' : ∀ {i j} {A : Type i} {B : Type j}
  {x y z : A} (p : x == y) (p' : y == z)
  {u v w : B} (q : u == v) (q' : v == w)
  → (pair×= p q ∙' pair×= p' q') == pair×= (p ∙' p') (q ∙' q')
×-∙' idp idp q idp = idp

-- Implementation of [_∙_] on ×
×-∙ : ∀ {i j} {A : Type i} {B : Type j}
  {x y z : A} (p : x == y) (p' : y == z)
  {u v w : B} (q : u == v) (q' : v == w)
  → (pair×= p q ∙ pair×= p' q') == pair×= (p ∙ p') (q ∙ q')
×-∙ idp idp idp r = idp

-- Special case of [ap-,]
ap-cst,id : ∀ {i j} {A : Type i} (B : A → Type j)
  {a : A} {x y : B a} (p : x == y)
  → ap (λ x → _,_ {B = B} a x) p == pair= idp p
ap-cst,id B idp = idp


{-# OPTIONS --without-K --safe #-}
open import Relation.Binary.PropositionalEquality using
  ( _≡_ ; refl ; sym ; trans ; subst ; cong )

module Cats.Category.Discrete {li} {I : Set li}
  (I-set : ∀ {i j : I} (p q : i ≡ j) → p ≡ q)
  where

open import Data.Product using (Σ-syntax ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤)
open import Level

open import Cats.Category.Base
open import Cats.Functor using (Functor)

Obj : Set li
Obj = I

data _⇒_ : Obj → Obj → Set li where
  id : ∀ {A} → A ⇒ A

⇒-contr : ∀ {A B} (f : A ⇒ B)
  → Σ[ p ∈ A ≡ B ] (subst (_⇒ B) p f ≡ id)
⇒-contr id = refl , refl

⇒-contr′ : ∀ {A} (f : A ⇒ A)
  → f ≡ id
⇒-contr′ f with ⇒-contr f
... | A≡A , f≡id rewrite I-set A≡A refl = f≡id

⇒-prop : ∀ {A B} (f g : A ⇒ B) → f ≡ g
⇒-prop {A} {B} id g = sym (⇒-contr′ g)

_∘_ : ∀ {A B C} → B ⇒ C → A ⇒ B → A ⇒ C
id ∘ id = id

Discrete : Category li li zero
Discrete = record
    { Obj = Obj
    ; _⇒_ = _⇒_
    ; _≈_ = λ _ _ → ⊤
    ; id = id
    ; _∘_ = _∘_
    ; equiv = _
    ; ∘-resp = _
    ; id-r = _
    ; id-l = _
    ; assoc = _
    }

functor : ∀ {lo la l≈} {C : Category lo la l≈}
  → (I → Category.Obj C)
  → Functor Discrete C
functor {C = C} f = record
    { fobj = f
    ; fmap = fmap
    ; fmap-resp = λ {A} {B} {g} {h} _ → C.≈.reflexive (cong fmap (⇒-prop g h))
    ; fmap-id = C.≈.refl
    ; fmap-∘ = λ { {f = id} {id} → C.id-l }
    }
  where
    module C = Category C

    fmap : ∀ {A B} (g : A ⇒ B) → f A C.⇒ f B
    fmap id = C.id


{-# OPTIONS --instance-search-depth=10 #-}

module _ where

module _
  {A : Set}
  (B₁ : A → Set)
  (B₂ : A → Set)
  (f : A → A)
  where
  type = ∀ {x : A} → B₁ x → B₂ (f x)
  record Class : Set where field method : type
  method : {{_ : Class}} → type
  method {{I}} = Class.method I

id : ∀ {A : Set} → A → A
id x = x

Ext : {A : Set} (B : A → Set) → A → Set
Ext B x = B x → B x

postulate

  Foo : Set

  instance

    _ : {A : Set}
        {B : A → Set}
        {{_ : Class (Ext B) (Ext B) id}}
        → Class (Ext B) (Ext (λ _ → Foo)) id

module _
  {A : Set}
  (B : A → Set)
  {{_ : Class (Ext B) (Ext B) id}}
  {y}
  (R : B y → Set)
  where

  postulate

    _ : let Point = λ (f : B y → B y) → ∀ x → R (f x) in
        Class Point Point (method (Ext _) (Ext _) id)


module Point where

open import Nat
open import Bool

-- A record can be seen as a one constructor datatype. In this case:
data Point' : Set where
  mkPoint : (x : Nat)(y : Nat) -> Point'

getX : Point' -> Nat
getX (mkPoint x y) = x

getY : Point' -> Nat
getY (mkPoint x y) = y


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

open import HoTT
open import homotopy.EilenbergMacLane
open import cohomology.Theory
open import cohomology.SpectrumModel
open import cohomology.WithCoefficients

module cohomology.EMModel where

module _ {i} (G : Group i) (G-abelian : is-abelian G) where

  open EMExplicit G G-abelian using (⊙EM; EM-level; EM-conn; spectrum)

  private
    E : (n : ℤ) → Ptd i
    E O = ⊙EM O
    E (pos m) = ⊙EM (S m)
    E (neg m) = ⊙Lift ⊙Unit

    E-spectrum : (n : ℤ) → ⊙Ω (E (succ n)) == E n
    E-spectrum O = spectrum O
    E-spectrum (pos n) = spectrum (S n)
    E-spectrum (neg O) =
      ⊙ua (equiv (λ _ → _) (λ _ → idp)
            (λ _ → idp) (prop-has-all-paths (EM-level _ _ _) _))
          idp
    E-spectrum (neg (S n)) =
      ⊙ua (equiv (λ _ → _) (λ _ → idp)
            (λ _ → idp) (prop-has-all-paths (Lift-level Unit-is-set _ _) _))
          idp

  EM-Cohomology : CohomologyTheory i
  EM-Cohomology = spectrum-cohomology E E-spectrum

  open CohomologyTheory EM-Cohomology

  EM-dimension : (n : ℤ) → n ≠ O → C n (⊙Sphere O) == 0ᴳ
  EM-dimension O neq = ⊥-rec (neq idp)
  EM-dimension (pos n) _ =
    contr-is-0ᴳ _ $ connected-at-level-is-contr
      (Trunc-level {n = ⟨0⟩})
      (Trunc-preserves-conn ⟨0⟩
        (transport (λ B → is-connected ⟨0⟩ B)
          (! (Bool⊙→-path _))
          (path-conn (connected-≤T (⟨⟩-monotone-≤ (≤-ap-S (O≤ n)))
                                   (EM-conn (S n))))))
  EM-dimension (neg O) _ =
    contr-is-0ᴳ _ $ Trunc-preserves-level ⟨0⟩ $ ⊙→-level $
      inhab-prop-is-contr idp (EM-level O _ _)
  EM-dimension (neg (S n)) _ =
    contr-is-0ᴳ _ $ Trunc-preserves-level ⟨0⟩ $ ⊙→-level $
      Lift-level Unit-is-prop _ _

  EM-Ordinary : OrdinaryTheory i
  EM-Ordinary = ordinary-theory EM-Cohomology EM-dimension


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

open import Base
open import Homotopy.PushoutDef

-- Suspension is defined as a particular case of pushout

module Spaces.Suspension {i} (A : Set i) where

suspension-diag : pushout-diag i
suspension-diag = diag unit , unit , A , (λ _ → tt) , (λ _ → tt)

suspension : Set i
suspension = pushout suspension-diag

north : suspension
north = left tt

south : suspension
south = right tt

paths : A → north ≡ south
paths x = glue x

suspension-rec : ∀ {j} (P : suspension → Set j) (n : P north) (s : P south)
  (p : (x : A) → transport P (paths x) n ≡ s) → ((x : suspension) → P x)
suspension-rec P n s p = pushout-rec P (λ _ → n) (λ _ → s) p

suspension-β-paths : ∀ {j} (P : suspension → Set j) (n : P north) (s : P south)
  (p : (x : A) → transport P (paths x) n ≡ s)
  → ((x : A) → apd (suspension-rec P n s p) (paths x) ≡ p x)
suspension-β-paths P n s p =
  pushout-β-glue P (λ _ → n) (λ _ → s) p

suspension-rec-nondep : ∀ {j} (C : Set j) (n s : C) (p : A → n ≡ s)
  → (suspension → C)
suspension-rec-nondep C n s p =
  pushout-rec-nondep C (λ _ → n) (λ _ → s) p

suspension-β-paths-nondep : ∀ {j} (C : Set j) (n s : C) (p : A → n ≡ s)
  → ((x : A) → ap (suspension-rec-nondep C n s p) (paths x) ≡ p x)
suspension-β-paths-nondep C n s p =
  pushout-β-glue-nondep C (λ _ → n) (λ _ → s) p


{-# OPTIONS --safe #-}
module Cubical.Categories.Abelian.Instances.Terminal where

open import Cubical.Foundations.Prelude

open import Cubical.Categories.Abelian.Base
open import Cubical.Categories.Additive.Instances.Terminal

open import Cubical.Data.Unit

private
  variable
    ℓ : Level

private
  open PreAbCategory
  open PreAbCategoryStr

  terminalPreAbCategory : PreAbCategory ℓ ℓ
  PreAbCategory.additive terminalPreAbCategory = terminalAdditiveCategory

  Kernel.k (hasKernels (preAbStr terminalPreAbCategory) f) = tt*
  Kernel.ker (hasKernels (preAbStr terminalPreAbCategory) f) = refl
  IsKernel.ker⋆f (Kernel.isKer (hasKernels (preAbStr terminalPreAbCategory) f)) = refl
  IsKernel.univ (Kernel.isKer (hasKernels (preAbStr terminalPreAbCategory) f)) = λ _ _ _ → (refl , refl) , λ _ → refl

  Cokernel.c (hasCokernels (preAbStr terminalPreAbCategory) f) = tt*
  Cokernel.coker (hasCokernels (preAbStr terminalPreAbCategory) f) = refl
  IsCokernel.f⋆coker (Cokernel.isCoker (hasCokernels (preAbStr terminalPreAbCategory) f)) = refl
  IsCokernel.univ (Cokernel.isCoker (hasCokernels (preAbStr terminalPreAbCategory) f)) = λ _ _ _ → (refl , refl) , λ _ → refl

open AbelianCategory
open AbelianCategoryStr

terminalAbelianCategory : AbelianCategory ℓ ℓ
preAb terminalAbelianCategory = terminalPreAbCategory

fst (monNormal (abelianStr terminalAbelianCategory) m _) = tt*
fst (snd (monNormal (abelianStr terminalAbelianCategory) m _)) = m
IsKernel.ker⋆f (snd (snd (monNormal (abelianStr terminalAbelianCategory) m _))) = refl
IsKernel.univ (snd (snd (monNormal (abelianStr terminalAbelianCategory) m _))) = λ _ _ _ → (refl , refl) , (λ _ → refl)

fst (epiNormal (abelianStr terminalAbelianCategory) e _) = tt*
fst (snd (epiNormal (abelianStr terminalAbelianCategory) e _)) = e
IsCokernel.f⋆coker (snd (snd (epiNormal (abelianStr terminalAbelianCategory) e _))) = refl
IsCokernel.univ (snd (snd (epiNormal (abelianStr terminalAbelianCategory) e _))) = λ _ _ _ → (refl , refl) , (λ _ → refl)


module Tactic.Nat.Subtract.Lemmas where

open import Prelude
open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Container.Bag
open import Tactic.Nat.Simpl
open import Prelude.Nat.Properties
open import Prelude.List.Properties
open import Tactic.Nat.Auto.Lemmas
open import Tactic.Nat.Simpl.Lemmas
open import Tactic.Nat.Auto
open import Tactic.Nat.Simpl

open import Tactic.Nat.Subtract.Exp

sub-cancel : (a : Nat) → a - a ≡ 0
sub-cancel zero = refl
sub-cancel (suc a) = sub-cancel a

sub-add-r : (a b c : Nat) → a - (b + c) ≡ a - b - c
sub-add-r  a       zero    c      = refl
sub-add-r zero    (suc b)  zero   = refl
sub-add-r zero    (suc b) (suc c) = refl
sub-add-r (suc a) (suc b)  c      = sub-add-r a b c

lem-sub-zero : (a b c : Nat) → b + c ≡ a → c ≡ a - b
lem-sub-zero ._  zero   c refl = refl
lem-sub-zero ._ (suc b) c refl = lem-sub-zero _ b c refl

lem-zero-sub : (a b c : Nat) → b ≡ a + c → 0 ≡ a - b
lem-zero-sub  zero   ._  zero   refl = refl
lem-zero-sub  zero   ._ (suc c) refl = refl
lem-zero-sub (suc a) ._  c      refl = lem-zero-sub a _ c refl

lem-sub : (a b u v : Nat) → b + u ≡ a + v → u - v ≡ a - b
lem-sub  zero    zero   u ._ refl = sub-cancel u
lem-sub  zero   (suc b) u ._ refl = sym $ lem-zero-sub u (suc b + u) (suc b) auto
lem-sub (suc a)  zero  ._  v refl = sym $ lem-sub-zero (suc a + v) v (suc a) auto
lem-sub (suc a) (suc b) u  v eq   = lem-sub a b u v (suc-inj eq)

sub-mul-distr-l : (a b c : Nat) → (a - b) * c ≡ a * c - b * c
sub-mul-distr-l zero b c = (_* c) $≡ lem-zero-sub 0 b b refl ʳ⟨≡⟩ lem-zero-sub 0 (b * c) (b * c) refl
sub-mul-distr-l (suc a) zero c = refl
sub-mul-distr-l (suc a) (suc b) c =
  sub-mul-distr-l a b c ⟨≡⟩
  lem-sub (suc a * c) (suc b * c) (a * c) (b * c) auto

sub-mul-distr-r : (a b c : Nat) → a * (b - c) ≡ a * b - a * c
sub-mul-distr-r a b c =
  auto ⟨≡⟩ sub-mul-distr-l b c a
       ⟨≡⟩ cong₂ _-_ (mul-commute b a) (mul-commute c a)

-- The evaluator that doesn't generate x * 1 + 0 is the same as the
-- one that does.

lem-eval-sns-sn : ∀ n ρ → ⟦ n ⟧sns ρ ≡ ⟦ n ⟧sn ρ

private
  lem-eval-sns-sn-t : ∀ t ρ → ⟦ t ⟧sts ρ ≡ ⟦ t ⟧st ρ
  lem-eval-sns-sn-a : ∀ a ρ → ⟦ a ⟧sas ρ ≡ ⟦ a ⟧sa ρ

  lem-eval-sns-sn-a (var x) ρ = refl
  lem-eval-sns-sn-a (a ⟨-⟩ b) ρ = _-_ $≡ lem-eval-sns-sn a ρ *≡ lem-eval-sns-sn b ρ

  lem-eval-sns-sn-t []          ρ = refl
  lem-eval-sns-sn-t (x ∷ [])    ρ = lem-eval-sns-sn-a x ρ ⟨≡⟩ auto
  lem-eval-sns-sn-t (x ∷ y ∷ t) ρ = _*_ $≡ lem-eval-sns-sn-a x ρ *≡ lem-eval-sns-sn-t (y ∷ t) ρ

lem-eval-sns-sn []                 ρ = refl
lem-eval-sns-sn ((k , t) ∷ [])     ρ = _*_ k $≡ lem-eval-sns-sn-t t ρ ⟨≡⟩ auto
lem-eval-sns-sn ((k , t) ∷ t₁ ∷ n) ρ = _+_ $≡ (_*_ k $≡ lem-eval-sns-sn-t t ρ)
                                         *≡ lem-eval-sns-sn (t₁ ∷ n) ρ

-- The evaluation that the termination checker lets us write is the
-- same as the one we want to write.

private
  lem-eval-sn-n-t : ∀ t ρ → ⟦ t ⟧st ρ ≡ productR (map (atomEnv ρ) t)
  lem-eval-sn-n-t [] ρ = refl
  lem-eval-sn-n-t (x ∷ t) ρ = (⟦ x ⟧sa ρ *_) $≡ lem-eval-sn-n-t t ρ

lem-eval-sn-n   : ∀ n ρ → ⟦ n ⟧sn ρ ≡ ⟦ n ⟧n (atomEnv ρ)
lem-eval-sn-n []            ρ = refl
lem-eval-sn-n ((k , t) ∷ n) ρ = _+_ $≡ (_*_ k $≡ lem-eval-sn-n-t t ρ) *≡ lem-eval-sn-n n ρ

private
  lem-env : ∀ ρ x → atomEnvS ρ x ≡ atomEnv ρ x
  lem-env ρ (var x) = refl
  lem-env ρ (a ⟨-⟩ b) = _-_ $≡ lem-eval-sns-sn a ρ *≡ lem-eval-sns-sn b ρ

-- Combining the above equalities.

lem-eval-sn-nS : ∀ n ρ → ⟦ n ⟧sn ρ ≡ ⟦ n ⟧n (atomEnvS ρ)
lem-eval-sn-nS n ρ = lem-eval-sn-n n ρ ⟨≡⟩ʳ lem-eval-env (atomEnvS ρ) (atomEnv ρ) (lem-env ρ) n

lem-eval-sns-nS : ∀ n ρ → ⟦ n ⟧sns ρ ≡ ⟦ n ⟧n (atomEnvS ρ)
lem-eval-sns-nS n ρ = lem-eval-sns-sn n ρ ⟨≡⟩ lem-eval-sn-nS n ρ

lem-eval-sns-ns : ∀ n ρ → ⟦ n ⟧sns ρ ≡ ⟦ n ⟧ns (atomEnvS ρ)
lem-eval-sns-ns n ρ = lem-eval-sns-nS n ρ ⟨≡⟩ʳ ns-sound n (atomEnvS ρ)

⟨-⟩-sound′ : ∀ a b ρ → ⟦ a -nf′ b ⟧n (atomEnv ρ) ≡ ⟦ a ⟧n (atomEnv ρ) - ⟦ b ⟧n (atomEnv ρ)
⟨-⟩-sound′ a b ρ with cancel a b | λ i j → cancel-complete′ i j a b (atomEnv ρ)
⟨-⟩-sound′ a b ρ | d      , []     | complete =
  let u = ⟦ a ⟧n (atomEnv ρ)
      v = ⟦ b ⟧n (atomEnv ρ)
      k = ⟦ d ⟧n (atomEnv ρ) in
  lem-sub-zero u v k (complete v u auto ⟨≡⟩ auto)
⟨-⟩-sound′ a b ρ | []     , d ∷ ds | complete =
  let u = ⟦ a      ⟧n (atomEnv ρ)
      v = ⟦ b      ⟧n (atomEnv ρ)
      k = ⟦ d ∷ ds ⟧n (atomEnv ρ) in
  lem-zero-sub u v k (auto ⟨≡⟩ complete v u auto)
⟨-⟩-sound′ a b ρ | u ∷ us , v ∷ vs | complete =
  let eval = λ x → ⟦ x ⟧n (atomEnv ρ) in
  (⟦ u ∷ us ⟧sn ρ - ⟦ v ∷ vs ⟧sn ρ) * 1 + 0 + 0
    ≡⟨ auto ⟩
  ⟦ u ∷ us ⟧sn ρ - ⟦ v ∷ vs ⟧sn ρ
    ≡⟨ cong₂ _-_ (lem-eval-sn-n (u ∷ us) ρ) (lem-eval-sn-n (v ∷ vs) ρ) ⟩
  eval (u ∷ us) - eval (v ∷ vs)
    ≡⟨ lem-sub (eval a) (eval b) (eval (u ∷ us)) (eval (v ∷ vs)) (complete (eval b) (eval a) auto) ⟩
  eval a - eval b ∎

⟨-⟩-sound : ∀ a b ρ → ⟦ a -nf b ⟧n (atomEnv ρ) ≡ ⟦ a ⟧n (atomEnv ρ) - ⟦ b ⟧n (atomEnv ρ)
⟨-⟩-sound a b ρ with is-subtraction a
⟨-⟩-sound a b ρ  | no     = ⟨-⟩-sound′ a b ρ
⟨-⟩-sound ._ c ρ | a ⟨-⟩ b =
  let eval = λ x → ⟦ x ⟧n (atomEnv ρ) in
  ⟨-⟩-sound′ a (b +nf c) ρ ⟨≡⟩
  (eval a -_) $≡ ⟨+⟩-sound b c (atomEnv ρ) ⟨≡⟩
  sub-add-r (eval a) (eval b) (eval c) ⟨≡⟩
  (_- eval c) $≡ (_-_ $≡ lem-eval-sn-n a ρ *≡ lem-eval-sn-n b ρ) ʳ⟨≡⟩
  (_- eval c) $≡ auto

⟨*⟩-sound₁ : ∀ a b ρ → ⟦ a *nf₁ b ⟧n (atomEnv ρ) ≡ ⟦ a ⟧n (atomEnv ρ) * ⟦ b ⟧n (atomEnv ρ)

private
  sound-mul-ktm′ : ∀ t a ρ → ⟦ t *ktm′ a ⟧n (atomEnv ρ) ≡ ⟦ t ⟧t (atomEnv ρ) * ⟦ a ⟧n (atomEnv ρ)

  sound-mul-tm : ∀ s t ρ → ⟦ s *tm t ⟧n (atomEnv ρ) ≡ ⟦ s ⟧t (atomEnv ρ) * ⟦ t ⟧t (atomEnv ρ)
  sound-mul-tm s t ρ with is-subtraction-tm t
  sound-mul-tm (x , a) (y , b) ρ | no =
    follows-from (x * y *_ $≡ map-merge a b (atomEnv ρ))
  sound-mul-tm s ._ ρ | a ⟨-⟩ b =
    let eval  x = ⟦ x ⟧n (atomEnv ρ)
        evalt x = ⟦ x ⟧t (atomEnv ρ) in
    ⟨-⟩-sound (s *ktm′ a) (s *ktm′ b) ρ ⟨≡⟩
    _-_ $≡ sound-mul-ktm′ s a ρ *≡ sound-mul-ktm′ s b ρ ⟨≡⟩
    sub-mul-distr-r (evalt s) (eval a) (eval b) ʳ⟨≡⟩
    (evalt s *_) $≡ (_-_ $≡ lem-eval-sn-n a ρ *≡ lem-eval-sn-n b ρ) ʳ⟨≡⟩
    auto

  sound-mul-ktm′ t [] ρ = auto
  sound-mul-ktm′ t (x ∷ a) ρ =
    let eval  x = ⟦ x ⟧n (atomEnv ρ)
        evalt x = ⟦ x ⟧t (atomEnv ρ) in
    ⟨+⟩-sound (t *tm x) (t *ktm′ a) (atomEnv ρ) ⟨≡⟩
    _+_ $≡ sound-mul-tm t x ρ *≡ sound-mul-ktm′ t a ρ ⟨≡⟩ʳ
    mul-distr-l (evalt t) (evalt x) (eval a)

  sound-mul-ktm : ∀ t a ρ → ⟦ t *ktm a ⟧n (atomEnv ρ) ≡ ⟦ t ⟧t (atomEnv ρ) * ⟦ a ⟧n (atomEnv ρ)
  sound-mul-ktm t a ρ with is-subtraction-tm t
  sound-mul-ktm t  a ρ | no = sound-mul-ktm′ t a ρ
  sound-mul-ktm ._ c ρ | a ⟨-⟩ b =
    let eval x = ⟦ x ⟧n (atomEnv ρ) in
    ⟨-⟩-sound (a *nf₁ c) (b *nf₁ c) ρ ⟨≡⟩
    _-_ $≡ ⟨*⟩-sound₁ a c ρ *≡ ⟨*⟩-sound₁ b c ρ ⟨≡⟩
    sub-mul-distr-l (eval a) (eval b) (eval c) ʳ⟨≡⟩
    (_* eval c) $≡ (_-_ $≡ lem-eval-sn-n a ρ *≡ lem-eval-sn-n b ρ) ʳ⟨≡⟩
    auto

⟨*⟩-sound₁ [] b ρ = refl
⟨*⟩-sound₁ (t ∷ a) b ρ =
  let eval x = ⟦ x ⟧n (atomEnv ρ)
      evalt x = ⟦ x ⟧t (atomEnv ρ) in
  ⟨+⟩-sound (t *ktm b) (a *nf₁ b) (atomEnv ρ) ⟨≡⟩
  _+_ $≡ sound-mul-ktm t b ρ *≡ ⟨*⟩-sound₁ a b ρ ⟨≡⟩ʳ
  mul-distr-r (evalt t) (eval a) (eval b)

sound-sub : ∀ e ρ → ⟦ e ⟧se ρ ≡ ⟦ normSub e ⟧sn ρ
sound-sub (var x) ρ = auto
sound-sub (lit 0) ρ = refl
sound-sub (lit (suc n)) ρ = auto
sound-sub (e ⟨+⟩ e₁) ρ =
  cong₂ _+_ (sound-sub e  ρ ⟨≡⟩ lem-eval-sn-n (normSub e)  ρ)
            (sound-sub e₁ ρ ⟨≡⟩ lem-eval-sn-n (normSub e₁) ρ) ⟨≡⟩
  ⟨+⟩-sound (normSub e) (normSub e₁) (atomEnv ρ) ʳ⟨≡⟩ʳ
  lem-eval-sn-n (normSub (e ⟨+⟩ e₁)) ρ
sound-sub (e ⟨*⟩ e₁) ρ =
  cong₂ _*_ (sound-sub e  ρ ⟨≡⟩ lem-eval-sn-n (normSub e)  ρ)
            (sound-sub e₁ ρ ⟨≡⟩ lem-eval-sn-n (normSub e₁) ρ) ⟨≡⟩
  ⟨*⟩-sound₁ (normSub e) (normSub e₁) ρ ʳ⟨≡⟩ʳ
  lem-eval-sn-n (normSub (e ⟨*⟩ e₁)) ρ
sound-sub (e ⟨-⟩ e₁) ρ =
  cong₂ _-_ (sound-sub e  ρ ⟨≡⟩ lem-eval-sn-n (normSub e)  ρ)
            (sound-sub e₁ ρ ⟨≡⟩ lem-eval-sn-n (normSub e₁) ρ) ⟨≡⟩
  ⟨-⟩-sound (normSub e) (normSub e₁) ρ ʳ⟨≡⟩ʳ
  lem-eval-sn-n (normSub (e ⟨-⟩ e₁)) ρ

liftNFSubEq : ∀ e₁ e₂ ρ → ⟦ normSub e₁ ⟧sn ρ ≡ ⟦ normSub e₂ ⟧sn ρ → ⟦ e₁ ⟧se ρ ≡ ⟦ e₂ ⟧se ρ
liftNFSubEq e₁ e₂ ρ eq = eraseEquality $ sound-sub e₁ ρ ⟨≡⟩ eq ⟨≡⟩ʳ sound-sub e₂ ρ

unliftNFSubEq : ∀ e₁ e₂ ρ → ⟦ e₁ ⟧se ρ ≡ ⟦ e₂ ⟧se ρ → ⟦ normSub e₁ ⟧sn ρ ≡ ⟦ normSub e₂ ⟧sn ρ
unliftNFSubEq e₁ e₂ ρ eq = eraseEquality $ sound-sub e₁ ρ ʳ⟨≡⟩ eq ⟨≡⟩ sound-sub e₂ ρ

SubExpEq : SubExp → SubExp → Env Var → Set
SubExpEq e₁ e₂ ρ = ⟦ e₁ ⟧se ρ ≡ ⟦ e₂ ⟧se ρ

CancelSubEq : SubExp → SubExp → Env Var → Set
CancelSubEq e₁ e₂ ρ = NFEqS (cancel (normSub e₁) (normSub e₂)) (atomEnvS ρ)

simplifySubEq : ∀ e₁ e₂ (ρ : Env Var) → CancelSubEq e₁ e₂ ρ → SubExpEq e₁ e₂ ρ
simplifySubEq e₁ e₂ ρ H = liftNFSubEq e₁ e₂ ρ $
  lem-eval-sn-nS (normSub e₁) ρ ⟨≡⟩
  cancel-sound (normSub e₁) (normSub e₂) (atomEnvS ρ) H ⟨≡⟩ʳ
  lem-eval-sn-nS (normSub e₂) ρ

complicateSubEq : ∀ e₁ e₂ ρ → SubExpEq e₁ e₂ ρ → CancelSubEq e₁ e₂ ρ
complicateSubEq e₁ e₂ ρ H =
  cancel-complete (normSub e₁) (normSub e₂) (atomEnvS ρ) $
  lem-eval-sn-nS (normSub e₁) ρ ʳ⟨≡⟩
  unliftNFSubEq e₁ e₂ ρ H ⟨≡⟩
  lem-eval-sn-nS (normSub e₂) ρ


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.RingSolver.EvaluationHomomorphism where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.FinData
open import Cubical.Data.Vec

open import Cubical.Algebra.RingSolver.RawRing
open import Cubical.Algebra.RingSolver.AlmostRing renaming (⟨_⟩ to ⟨_⟩ᵣ)
open import Cubical.Algebra.RingSolver.HornerForms

private
  variable
    ℓ : Level

module HomomorphismProperties (R : AlmostRing {ℓ}) where
  private
    νR = AlmostRing→RawRing R
  open AlmostRing R
  open Theory R
  open IteratedHornerOperations νR

  evalHom+0 : (n : ℕ) (P : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
      → eval n (0ₕ +ₕ P) xs ≡ eval n P xs
  evalHom+0 ℕ.zero (const x) [] = +Lid _
  evalHom+0 (ℕ.suc n) P xs = refl

  eval0H : (n : ℕ) (xs : Vec ⟨ νR ⟩ n)
         → eval {R = νR} n 0ₕ xs ≡ 0r
  eval0H .ℕ.zero [] = refl
  eval0H .(ℕ.suc _) (x ∷ xs) = refl

  eval1ₕ : (n : ℕ) (xs : Vec ⟨ νR ⟩ n)
         → eval {R = νR} n 1ₕ xs ≡ 1r
  eval1ₕ .ℕ.zero [] = refl
  eval1ₕ (ℕ.suc n) (x ∷ xs) =
    eval (ℕ.suc n) 1ₕ (x ∷ xs)                             ≡⟨ refl ⟩
    eval (ℕ.suc n) (0H ·X+ 1ₕ) (x ∷ xs)                    ≡⟨ refl ⟩
    eval {R = νR} (ℕ.suc n) 0H (x ∷ xs) · x + eval n 1ₕ xs ≡⟨ cong (λ u → u · x + eval n 1ₕ xs)
                                                                   (eval0H _ (x ∷ xs)) ⟩
    0r · x + eval n 1ₕ xs                                   ≡⟨ cong (λ u → 0r · x + u)
                                                                    (eval1ₕ _ xs) ⟩
    0r · x + 1r                                            ≡⟨ cong (λ u → u + 1r)
                                                                   (0LeftAnnihilates _) ⟩
    0r + 1r                                                ≡⟨ +Lid _ ⟩
    1r ∎

  -evalDist :
    (n : ℕ) (P : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval n (-ₕ P) xs ≡ - eval n P xs
  -evalDist .ℕ.zero (const x) []   = refl
  -evalDist          n       0H  xs =
    eval n (-ₕ 0H) xs  ≡⟨ eval0H n xs ⟩
    0r                        ≡⟨ sym 0IsSelfinverse ⟩
    - 0r                      ≡⟨ cong -_ (sym (eval0H n xs)) ⟩
    - eval n 0H xs     ∎
  -evalDist .(ℕ.suc _) (P ·X+ Q) (x ∷ xs) =
      eval (ℕ.suc _) (-ₕ (P ·X+ Q)) (x ∷ xs)
    ≡⟨ refl ⟩
      eval (ℕ.suc _) ((-ₕ P) ·X+ (-ₕ Q)) (x ∷ xs)
    ≡⟨ refl ⟩
      (eval (ℕ.suc _) (-ₕ P) (x ∷ xs)) · x + eval _ (-ₕ Q) xs
    ≡⟨ cong (λ u → u · x + eval _ (-ₕ Q) xs) (-evalDist _ P _) ⟩
      (- eval (ℕ.suc _) P (x ∷ xs)) · x + eval _ (-ₕ Q) xs
    ≡⟨ cong (λ u → (- eval (ℕ.suc _) P (x ∷ xs)) · x + u) (-evalDist _ Q _) ⟩
      (- eval (ℕ.suc _) P (x ∷ xs)) · x + - eval _ Q xs
    ≡⟨ cong (λ u → u + - eval _ Q xs) (sym (-Comm· _ _)) ⟩
      - (eval (ℕ.suc _) P (x ∷ xs)) · x + - eval _ Q xs
    ≡⟨ sym (-Dist+ _ _) ⟩
      - ((eval (ℕ.suc _) P (x ∷ xs)) · x + eval _ Q xs)
    ≡⟨ refl ⟩
      - eval (ℕ.suc _) (P ·X+ Q) (x ∷ xs) ∎

  +Homeval :
    (n : ℕ) (P Q : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval n (P +ₕ Q) xs ≡ (eval n P xs) + (eval n Q xs)
  +Homeval .ℕ.zero (const x) (const y) [] = refl
  +Homeval n 0H Q xs =
    eval n (0H +ₕ Q) xs            ≡⟨ refl ⟩
    eval n Q xs                    ≡⟨ sym (+Lid _) ⟩
    0r + eval n Q xs               ≡⟨ cong (λ u → u + eval n Q xs) (sym (eval0H n xs)) ⟩
    eval n 0H xs + eval n Q xs ∎
  +Homeval .(ℕ.suc _) (P ·X+ Q) 0H xs =
    eval (ℕ.suc _) ((P ·X+ Q) +ₕ 0H) xs                    ≡⟨ refl ⟩
    eval (ℕ.suc _) (P ·X+ Q) xs                            ≡⟨ sym (+Rid _) ⟩
    eval (ℕ.suc _) (P ·X+ Q) xs + 0r
   ≡⟨ cong (λ u → eval (ℕ.suc _) (P ·X+ Q) xs + u) (sym (eval0H _ xs)) ⟩
    eval (ℕ.suc _) (P ·X+ Q) xs + eval (ℕ.suc _) 0H xs ∎
  +Homeval .(ℕ.suc _) (P ·X+ Q) (S ·X+ T) (x ∷ xs) =
    eval (ℕ.suc _) ((P ·X+ Q) +ₕ (S ·X+ T)) (x ∷ xs)
   ≡⟨ refl ⟩
    eval (ℕ.suc _) ((P +ₕ S) ·X+ (Q +ₕ T)) (x ∷ xs)
   ≡⟨ refl ⟩
    (eval (ℕ.suc _) (P +ₕ S) (x ∷ xs)) · x + eval _ (Q +ₕ T) xs
   ≡⟨ cong (λ u → (eval (ℕ.suc _) (P +ₕ S) (x ∷ xs)) · x + u) (+Homeval _ Q T xs) ⟩
    (eval (ℕ.suc _) (P +ₕ S) (x ∷ xs)) · x + (eval _ Q xs + eval _ T xs)
   ≡⟨ cong (λ u → u · x + (eval _ Q xs + eval _ T xs)) (+Homeval (ℕ.suc _) P S (x ∷ xs)) ⟩
    (eval (ℕ.suc _) P (x ∷ xs) + eval (ℕ.suc _) S (x ∷ xs)) · x
    + (eval _ Q xs + eval _ T xs)
   ≡⟨ cong (λ u → u + (eval _ Q xs + eval _ T xs)) (·DistL+ _ _ _) ⟩
    (eval (ℕ.suc _) P (x ∷ xs)) · x + (eval (ℕ.suc _) S (x ∷ xs)) · x
    + (eval _ Q xs + eval _ T xs)
   ≡⟨ +ShufflePairs _ _ _ _ ⟩
    ((eval (ℕ.suc _) P (x ∷ xs)) · x + eval _ Q xs)
    + ((eval (ℕ.suc _) S (x ∷ xs)) · x + eval _ T xs)
   ≡⟨ refl ⟩
    eval (ℕ.suc _) (P ·X+ Q) (x ∷ xs)
    + eval (ℕ.suc _) (S ·X+ T) (x ∷ xs) ∎

  ⋆Homeval : (n : ℕ)
             (r : IteratedHornerForms νR n)
             (P : IteratedHornerForms νR (ℕ.suc n)) (x : ⟨ νR ⟩) (xs : Vec ⟨ νR ⟩ n)
           → eval (ℕ.suc n) (r ⋆ P) (x ∷ xs) ≡ eval n r xs · eval (ℕ.suc n) P (x ∷ xs)

  ⋆0LeftAnnihilates :
    (n : ℕ) (P : IteratedHornerForms νR (ℕ.suc n)) (xs : Vec ⟨ νR ⟩ (ℕ.suc n))
    → eval (ℕ.suc n) (0ₕ ⋆ P) xs ≡ 0r

  ·Homeval : (n : ℕ) (P Q : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval n (P ·ₕ Q) xs ≡ (eval n P xs) · (eval n Q xs)

  ⋆0LeftAnnihilates n 0H xs = eval0H (ℕ.suc n) xs
  ⋆0LeftAnnihilates n (P ·X+ Q) (x ∷ xs) =
      eval (ℕ.suc n) (0ₕ ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
      eval (ℕ.suc n) ((0ₕ ⋆ P) ·X+ (0ₕ ·ₕ Q)) (x ∷ xs)             ≡⟨ refl ⟩
      (eval (ℕ.suc n) (0ₕ ⋆ P) (x ∷ xs)) · x + eval n (0ₕ ·ₕ Q) xs
    ≡⟨ cong (λ u → (u · x) + eval _ (0ₕ ·ₕ Q) _) (⋆0LeftAnnihilates n P (x ∷ xs)) ⟩
      0r · x + eval n (0ₕ ·ₕ Q) xs
    ≡⟨ cong (λ u → u + eval _ (0ₕ ·ₕ Q) _) (0LeftAnnihilates _) ⟩
      0r + eval n (0ₕ ·ₕ Q) xs
    ≡⟨ +Lid _ ⟩
      eval n (0ₕ ·ₕ Q) xs
    ≡⟨ ·Homeval n 0ₕ Q _ ⟩
      eval n 0ₕ xs · eval n Q xs
    ≡⟨ cong (λ u → u · eval n Q xs) (eval0H _ xs) ⟩
      0r · eval n Q xs
    ≡⟨ 0LeftAnnihilates _ ⟩
      0r ∎

  ⋆Homeval n r 0H x xs =
    eval (ℕ.suc n) (r ⋆ 0H) (x ∷ xs)         ≡⟨ refl ⟩
    0r                                       ≡⟨ sym (0RightAnnihilates _) ⟩
    eval n r xs · 0r                         ≡⟨ refl ⟩
    eval n r xs · eval {R = νR} (ℕ.suc n) 0H (x ∷ xs) ∎
  ⋆Homeval n r (P ·X+ Q) x xs =
      eval (ℕ.suc n) (r ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
      eval (ℕ.suc n) ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs)              ≡⟨ refl ⟩
      (eval (ℕ.suc n) (r ⋆ P) (x ∷ xs)) · x + eval n (r ·ₕ Q) xs
    ≡⟨ cong (λ u → u · x + eval n (r ·ₕ Q) xs) (⋆Homeval n r P x xs) ⟩
      (eval n r xs · eval (ℕ.suc n) P (x ∷ xs)) · x + eval n (r ·ₕ Q) xs
    ≡⟨ cong (λ u → (eval n r xs · eval (ℕ.suc n) P (x ∷ xs)) · x + u) (·Homeval n r Q xs) ⟩
      (eval n r xs · eval (ℕ.suc n) P (x ∷ xs)) · x + eval n r xs · eval n Q xs
    ≡⟨ cong (λ u → u  + eval n r xs · eval n Q xs) (sym (·Assoc _ _ _)) ⟩
      eval n r xs · (eval (ℕ.suc n) P (x ∷ xs) · x) + eval n r xs · eval n Q xs
    ≡⟨ sym (·DistR+ _ _ _) ⟩
      eval n r xs · ((eval (ℕ.suc n) P (x ∷ xs) · x) + eval n Q xs)
    ≡⟨ refl ⟩
      eval n r xs · eval (ℕ.suc n) (P ·X+ Q) (x ∷ xs) ∎

  combineCases :
    (n : ℕ) (Q : IteratedHornerForms νR n) (P S : IteratedHornerForms νR (ℕ.suc n))
    (xs : Vec ⟨ νR ⟩ (ℕ.suc n))
    → eval (ℕ.suc n) ((P ·X+ Q) ·ₕ S) xs ≡ eval (ℕ.suc n) (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) xs
  combineCases n Q P S (x ∷ xs) with (P ·ₕ S)
  ... | 0H =
    eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)                ≡⟨ sym (+Lid _) ⟩
    0r + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)           ≡⟨ cong (λ u → u + eval _ (Q ⋆ S) (x ∷ xs)) lemma ⟩
    eval (ℕ.suc n) (0H ·X+ 0ₕ) (x ∷ xs)
    + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)              ≡⟨ sym (+Homeval (ℕ.suc n)
                                                      (0H ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs)) ⟩
    eval (ℕ.suc n) ((0H ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs) ∎
    where lemma : 0r ≡ eval (ℕ.suc n) (0H ·X+ 0ₕ) (x ∷ xs)
          lemma = 0r
                ≡⟨ sym (+Rid _) ⟩
                  0r + 0r
                ≡⟨ cong (λ u → u + 0r) (sym (0LeftAnnihilates _)) ⟩
                  0r · x + 0r
                ≡⟨ cong (λ u → 0r · x + u) (sym (eval0H _ xs)) ⟩
                  0r · x + eval n 0ₕ xs
                ≡⟨ cong (λ u → u · x + eval n 0ₕ xs) (sym (eval0H _ (x ∷ xs))) ⟩
                  eval {R = νR} (ℕ.suc n) 0H (x ∷ xs) · x + eval n 0ₕ xs
                ≡⟨ refl ⟩
                  eval (ℕ.suc n) (0H ·X+ 0ₕ) (x ∷ xs) ∎
  ... | (_ ·X+ _) = refl

  ·Homeval .ℕ.zero (const x) (const y) [] = refl
  ·Homeval (ℕ.suc n) 0H Q xs =
    eval (ℕ.suc n) (0H ·ₕ Q) xs        ≡⟨ eval0H _ xs ⟩
    0r                                 ≡⟨ sym (0LeftAnnihilates _) ⟩
    0r · eval (ℕ.suc n) Q xs          ≡⟨ cong (λ u → u · eval _ Q xs) (sym (eval0H _ xs)) ⟩
    eval (ℕ.suc n) 0H xs · eval (ℕ.suc n) Q xs ∎
  ·Homeval (ℕ.suc n) (P ·X+ Q) S (x ∷ xs) =
      eval (ℕ.suc n) ((P ·X+ Q) ·ₕ S) (x ∷ xs)
    ≡⟨ combineCases n Q P S (x ∷ xs) ⟩
      eval (ℕ.suc n) (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs)
    ≡⟨ +Homeval (ℕ.suc n) ((P ·ₕ S) ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs) ⟩
      eval (ℕ.suc n) ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs) + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)
    ≡⟨ refl ⟩
      (eval (ℕ.suc n) (P ·ₕ S) (x ∷ xs) · x + eval n 0ₕ xs)
      + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → u + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs))
          ((eval (ℕ.suc n) (P ·ₕ S) (x ∷ xs) · x + eval n 0ₕ xs)
         ≡⟨ cong (λ u → eval (ℕ.suc n) (P ·ₕ S) (x ∷ xs) · x + u) (eval0H _ xs) ⟩
           (eval (ℕ.suc n) (P ·ₕ S) (x ∷ xs) · x + 0r)
         ≡⟨ +Rid _ ⟩
           (eval (ℕ.suc n) (P ·ₕ S) (x ∷ xs) · x)
         ≡⟨ cong (λ u → u · x) (·Homeval (ℕ.suc n) P S (x ∷ xs)) ⟩
           ((eval (ℕ.suc n) P (x ∷ xs) · eval (ℕ.suc n) S (x ∷ xs)) · x)
         ≡⟨ sym (·Assoc _ _ _) ⟩
           (eval (ℕ.suc n) P (x ∷ xs) · (eval (ℕ.suc n) S (x ∷ xs) · x))
         ≡⟨ cong (λ u → eval (ℕ.suc n) P (x ∷ xs) · u) (·Comm _ _) ⟩
           (eval (ℕ.suc n) P (x ∷ xs) · (x · eval (ℕ.suc n) S (x ∷ xs)))
         ≡⟨ ·Assoc _ _ _ ⟩
           (eval (ℕ.suc n) P (x ∷ xs) · x) · eval (ℕ.suc n) S (x ∷ xs)
          ∎) ⟩
      (eval (ℕ.suc n) P (x ∷ xs) · x) · eval (ℕ.suc n) S (x ∷ xs)
      + eval (ℕ.suc n) (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → (eval (ℕ.suc n) P (x ∷ xs) · x) · eval (ℕ.suc n) S (x ∷ xs) + u)
            (⋆Homeval n Q S x xs) ⟩
      (eval (ℕ.suc n) P (x ∷ xs) · x) · eval (ℕ.suc n) S (x ∷ xs)
      + eval n Q xs · eval (ℕ.suc n) S (x ∷ xs)
    ≡⟨ sym (·DistL+ _ _ _) ⟩
      ((eval (ℕ.suc n) P (x ∷ xs) · x) + eval n Q xs) · eval (ℕ.suc n) S (x ∷ xs)
    ≡⟨ refl ⟩
      eval (ℕ.suc n) (P ·X+ Q) (x ∷ xs) · eval (ℕ.suc n) S (x ∷ xs) ∎


module Type.Size where

import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function.Domain
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level

_≍_ : (A : Type{ℓ₁}) → ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≍ B = ∃{Obj = A → B}(Bijective)

_≼_ : (A : Type{ℓ₁}) → ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≼ B = ∃{Obj = A → B}(Injective)

_≽_ : (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≽ B = ∃{Obj = A → B}(Surjective)

_≭_ : (A : Type{ℓ₁}) → ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≭ B = ¬(A ≍ B)

_≺_ : (A : Type{ℓ₁}) → ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≺ B = (A ≼ B) ∧ (A ≭ B)

_≻_ : (A : Type{ℓ₁}) → ⦃ _ : Equiv{ℓₑ₁}(A) ⦄ → (B : Type{ℓ₂}) → ⦃ _ : Equiv{ℓₑ₂}(B) ⦄ → Stmt
A ≻ B = (A ≽ B) ∧ (A ≭ B)


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

module GPerm where

-- Definition of a general permutation, and some combinators.
-- This is the 'abstract' view, in terms of functions.  Contrast with the
-- concrete view in term of vectors (and restricted to Enumerable sets)

-- In some sense, even better would be to consider 'weak' permutations
-- as exactly _≃_.  Having both side be syntactically equal is weird, as we
-- are exactly trying to liberate ourselves from that!

-- In other words, we won't actually use GPerm anywhere.

open import Level using (_⊔_)
open import Data.Sum using (_⊎_)
open import Data.Product using (_×_)

open import Equiv
open import TypeEquiv

GPerm : Set → Set
GPerm A = A ≃ A

-- composition.  Stick to Set₀.
_⊙_ : {A : Set} → GPerm A → GPerm A → GPerm A
_⊙_ = trans≃

-- parallel composition.
_⊕_ : {A C : Set} → GPerm A → GPerm C → GPerm (A ⊎ C)
_⊕_ = path⊎

-- tensor product
_⊗_ :  {A B : Set} → GPerm A → GPerm B → GPerm (A × B)
_⊗_ = path×


module halt where

open import Level renaming ( zero to Zero ; suc to Suc )
open import Data.Nat
open import Data.Maybe
open import Data.List hiding ([_])
open import Data.Nat.Properties
open import Relation.Nullary
open import Data.Empty
open import Data.Unit
open import  Relation.Binary.Core hiding (_⇔_)
open import  Relation.Binary.Definitions
open import Relation.Binary.PropositionalEquality

open import logic

record HBijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m)  where
   field
       fun←  :  S → R
       fun→  :  R → S
       fiso← : (x : R)  → fun← ( fun→ x )  ≡ x
--  normal bijection required below, but we don't need this to show the inconsistency
--     fiso→ : (x : S ) → fun→ ( fun← x )  ≡ x

injection' :  {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m)
injection' R S f = (x y : R) → f x ≡ f y → x ≡ y

open HBijection

diag : {S : Set }  (b : HBijection  ( S → Bool ) S) → S → Bool
diag b n = not (fun← b n n)

diagonal : { S : Set } → ¬ HBijection  ( S → Bool ) S
diagonal {S} b = diagn1 (fun→ b (diag b) ) refl where
    diagn1 : (n : S ) → ¬ (fun→ b (diag b) ≡ n )
    diagn1 n dn = ¬t=f (diag b n ) ( begin
           not (diag b n)
        ≡⟨⟩
           not (not fun← b n n)
        ≡⟨ cong (λ k → not (k  n) ) (sym (fiso← b _)) ⟩
           not (fun← b (fun→ b (diag b))  n)
        ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩
           not (fun← b n n)
        ≡⟨⟩
           diag b n
        ∎ ) where open ≡-Reasoning

record TM : Set where
   field
      tm : List Bool → Maybe Bool

open TM

record UTM : Set where
   field
      utm : TM
      encode : TM → List Bool
      is-tm : (t : TM) → (x : List Bool) → tm utm (encode t ++ x ) ≡ tm t x

open UTM

open _∧_

open import Axiom.Extensionality.Propositional
postulate f-extensionality : { n : Level}  → Axiom.Extensionality.Propositional.Extensionality n n

record Halt : Set where
   field
      halt :  (t : TM ) → (x : List Bool ) → Bool
      is-halt :     (t : TM ) → (x : List Bool ) → (halt t x ≡ true )  ⇔ ( (just true ≡ tm t x ) ∨ (just false ≡ tm t x ) )
      is-not-halt : (t : TM ) → (x : List Bool ) → (halt t x ≡ false ) ⇔ ( nothing ≡ tm t x )

open Halt

TNL : (halt : Halt ) → (utm : UTM) → HBijection (List Bool → Bool) (List Bool)
TNL halt utm = record {
       fun←  = λ tm x → Halt.halt halt (UTM.utm utm) (tm ++ x)
     ; fun→  = λ h  → encode utm record { tm = h1 h }
     ; fiso← = λ h →  f-extensionality (λ y → TN1 h y )
  } where
     open ≡-Reasoning
     h1 : (h : List Bool → Bool) → (x : List Bool ) → Maybe Bool
     h1 h x with h x
     ... | true =  just true
     ... | false = nothing
     tenc : (h : List Bool → Bool) → (y : List Bool) → List Bool
     tenc h y = encode utm (record { tm = λ x → h1 h x }) ++ y
     h-nothing : (h : List Bool → Bool) → (y : List Bool) → h y ≡ false → h1 h y ≡ nothing
     h-nothing h y eq with h y
     h-nothing h y refl | false = refl
     h-just : (h : List Bool → Bool) → (y : List Bool) → h y ≡ true → h1 h y ≡ just true
     h-just h y eq with h y
     h-just h y refl | true = refl
     TN1 :  (h : List Bool → Bool) → (y : List Bool ) → Halt.halt halt (UTM.utm utm) (tenc h y) ≡ h y
     TN1 h y with h y | inspect h y
     ... | true  | record { eq = eq1 } = begin
        Halt.halt halt (UTM.utm utm)  (tenc h y) ≡⟨ proj2 (is-halt halt (UTM.utm utm) (tenc h y) ) (case1 (sym tm-tenc)) ⟩
        true ∎  where
          tm-tenc :  tm (UTM.utm utm) (tenc h y) ≡ just true
          tm-tenc = begin
              tm (UTM.utm utm) (tenc h y)  ≡⟨  is-tm utm _ y ⟩
              h1 h y ≡⟨ h-just h y eq1  ⟩
              just true  ∎
     ... | false | record { eq = eq1 } = begin
        Halt.halt halt (UTM.utm utm)  (tenc h y) ≡⟨ proj2 (is-not-halt halt (UTM.utm utm) (tenc h y) ) (sym tm-tenc) ⟩
        false ∎  where
          tm-tenc :  tm (UTM.utm utm) (tenc h y) ≡ nothing
          tm-tenc = begin
              tm (UTM.utm utm) (tenc h y)  ≡⟨  is-tm utm _ y ⟩
              h1 h y ≡⟨  h-nothing h y eq1 ⟩
              nothing  ∎
     -- the rest of bijection means encoding is unique
     -- fiso→ :  (y : List Bool ) → encode utm record { tm = λ x →  h1 (λ tm → Halt.halt halt (UTM.utm utm) tm  ) x } ≡ y

TNL1 : UTM → ¬ Halt
TNL1 utm halt = diagonal ( TNL halt utm )


module Terms where

import Level
open import Data.Unit as Unit
open import Data.List as List
open import Data.Product as Product
open import Categories.Category using (Category)

data Type : Set where
  Nat : Type
  _ˢ : Type → Type
  _⇒_ : Type → Type → Type

infixr 5 _⇒_

open import Common.Context Type
  using (Ctx; Var; zero; ctx-cat; ctx-bin-coproducts)
  renaming (succ to succ)
open Categories.Category.Category ctx-cat
  renaming ( _⇒_ to _▹_
           ; _≡_ to _≈_
           ; _∘_ to _●_
           ; id  to ctx-id
           )
open import Categories.Object.BinaryCoproducts ctx-cat
open BinaryCoproducts ctx-bin-coproducts

data Term (Γ : Ctx) : (σ : Type) → Set where
  var  : ∀{σ : Type}       (x : Var Γ σ)          → Term Γ σ
  abs  : ∀{σ τ : Type}     (t : Term (σ ∷ Γ) τ)   → Term Γ (σ ⇒ τ)
  app  : ∀{σ τ : Type}     (t : Term Γ (σ ⇒ τ))
                           (s : Term Γ σ)         → Term Γ τ
  -- Constants for recursion over ℕ
  𝟘    : Term Γ Nat
  s⁺   : Term Γ (Nat ⇒ Nat)
  R    : ∀{σ : Type} → Term Γ (σ ⇒ (Nat ⇒ σ ⇒ σ) ⇒ Nat ⇒ σ)
  -- Constants for corecursion over streams
  hd   : ∀{σ : Type} → Term Γ (σ ˢ ⇒ σ)
  tl   : ∀{σ : Type} → Term Γ (σ ˢ ⇒ σ ˢ)
  C    : ∀{σ τ : Type} → Term Γ ((σ ⇒ τ) ⇒ (σ ⇒ σ) ⇒ σ ⇒ τ ˢ)

-- Improve readability
_⟨$⟩_ : ∀{Γ σ τ} (t : Term Γ (σ ⇒ τ)) (s : Term Γ σ) → Term Γ τ
t ⟨$⟩ s = app t s

infixl 0 _⟨$⟩_

hd′ : ∀{Γ σ} → Term Γ (σ ˢ) → Term Γ σ
hd′ s = hd ⟨$⟩ s

tl′ : ∀{Γ σ} → Term Γ (σ ˢ) → Term Γ (σ ˢ)
tl′ s = tl ⟨$⟩ s

C′ : ∀{Γ σ τ} → Term Γ (σ ⇒ τ) → Term Γ (σ ⇒ σ) → Term Γ (σ ⇒ τ ˢ)
C′ h t = (C ⟨$⟩ h) ⟨$⟩ t

R′ : ∀{Γ σ} → Term Γ σ → Term Γ (Nat ⇒ σ ⇒ σ) → Term Γ (Nat ⇒ σ)
R′ x f = R ⟨$⟩ x ⟨$⟩ f

ƛ : ∀{Γ σ τ} → (Var (σ ∷ Γ) σ → Term (σ ∷ Γ) τ) → Term Γ (σ ⇒ τ)
ƛ f = abs (f zero)

abs₁ : ∀{Γ τ σ} →
       (Term (τ ∷ Γ) τ → Term (τ ∷ Γ) σ)
       → Term Γ (τ ⇒ σ)
abs₁ f = abs (f (var zero))

abs₂ : ∀{Γ τ₁ τ₂ σ} →
       (Term (τ₂ ∷ τ₁ ∷ Γ) τ₁ →
         Term (τ₂ ∷ τ₁ ∷ Γ) τ₂ →
         Term (τ₂ ∷ τ₁ ∷ Γ) σ) →
       Term Γ (τ₁ ⇒ τ₂ ⇒ σ)
abs₂ {Γ} {τ₁} f = abs (abs (f x₁ x₂))
  where
    x₁ = var (succ τ₁ zero)
    x₂ = var zero

abs₃ : ∀{Γ τ₁ τ₂ τ₃ σ} →
       (Term (τ₃ ∷ τ₂ ∷ τ₁ ∷ Γ) τ₁ →
         Term (τ₃ ∷ τ₂ ∷ τ₁ ∷ Γ) τ₂ →
         Term (τ₃ ∷ τ₂ ∷ τ₁ ∷ Γ) τ₃ →
         Term (τ₃ ∷ τ₂ ∷ τ₁ ∷ Γ) σ) →
       Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ σ)
abs₃ {Γ} {τ₁} {τ₂} f = abs (abs (abs (f x₁ x₂ x₃)))
  where
    x₁ = var (succ τ₁ (succ τ₁ zero))
    x₂ = var (succ τ₂ zero)
    x₃ = var zero

--------------------------------------
---- Examples ---

π₁ :  ∀{Γ σ τ} → Term Γ (σ ⇒ τ ⇒ σ)
π₁ = abs₂ (λ x₁ x₂ → x₁)

π₂ :  ∀{Γ σ τ} → Term Γ (σ ⇒ τ ⇒ τ)
π₂ = abs₂ (λ x₁ x₂ → x₂)

-- | Prepend element to a stream
-- hd (cons x s) = x
-- tl (cons x s) = s
-- This needs to use continuations.
conc : ∀{Γ σ} → Term Γ (σ ⇒ σ ˢ ⇒ σ ˢ)
conc {Γ} {σ} = abs (abs (C′ f g ⟨$⟩ i))
  where
    -- | State space
    S = (σ ⇒ σ ˢ ⇒ σ) ⇒ σ
    -- | local context
    Γ′ = σ ˢ ∷ σ ∷ Γ

    f : Term Γ′ (S ⇒ σ)
    f = abs₁ (λ v → v ⟨$⟩ π₁)

    g : Term Γ′ (S ⇒ S)
    g = abs₂ (λ v _h →
             v ⟨$⟩ (abs₂ (λ _ s →
               h ⟨$⟩ (hd′ s) ⟨$⟩ (tl′ s))
             )
        )
      where
        Γ′′ = σ ˢ ∷ σ ∷ (σ ⇒ σ ˢ ⇒ σ) ∷ S ∷ Γ′
        h : Term Γ′′ (σ ⇒ σ ˢ ⇒ σ)
        h = var (succ (σ ⇒ σ ˢ ⇒ σ) (succ (σ ⇒ σ ˢ ⇒ σ) zero))

    i : Term Γ′ S
    i = abs₁ (λ h → h ⟨$⟩ x ⟨$⟩ s)
      where
        s : Term ((σ ⇒ σ ˢ ⇒ σ) ∷ Γ′) (σ ˢ)
        s = var (succ (σ ˢ) zero)
        x : Term ((σ ⇒ σ ˢ ⇒ σ) ∷ Γ′) σ
        x = var (succ σ (succ σ zero))

_∺_ : ∀{Γ σ} → Term Γ σ → Term Γ (σ ˢ) → Term Γ (σ ˢ)
x ∺ s = conc ⟨$⟩ x ⟨$⟩ s

id′ : ∀{Γ σ} → Term Γ (σ ⇒ σ)
id′ = abs₁ (λ x → x)

repeat : ∀{Γ σ} → Term Γ (σ ⇒ σ ˢ)
repeat = C′ id′ id′

-- | Extend a stream that is defined up to n by an element on the right, i.e.,
--     ext x 0     s  = repeat x
-- hd (ext x (n+1) s) = hd s
-- tl (ext x (n+1) s) = ext x n (tl s)
-- Thus ext is given by a recursion, followed by a corecursion:
-- ext x = R (λ_. repeat x) f
-- f _ h s = hd s ∷ (h (tl s))
ext : ∀{Γ σ} → Term Γ (σ ⇒ Nat ⇒ σ ˢ ⇒ σ ˢ)
ext {Γ} {σ} = abs (R′ (abs (repeat ⟨$⟩ x)) f)
  where
    Γ′ = σ ∷ Γ
    x : Term (σ ˢ ∷ Γ′) σ
    x = var (succ σ zero)

    f : Term Γ′ (Nat ⇒ (σ ˢ ⇒ σ ˢ) ⇒ σ ˢ ⇒ σ ˢ)
    f = abs₃ (λ _ h s → (hd′ s) ∺ (h ⟨$⟩ (tl′ s)))


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

open import Groups.Definition
open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Setoids.Subset
open import Setoids.Setoids
open import Setoids.Orders.Partial.Definition
open import Fields.Fields
open import Rings.Orders.Total.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Definition
open import Fields.Orders.LeastUpperBounds.Definition
open import Fields.Orders.Total.Definition
open import Sets.EquivalenceRelations

module Numbers.ClassicalReals.RealField.Lemmas {a b c : _} {A : Set a} {S : Setoid {_} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (F : Field R) {_<_ : Rel {_} {c} A} {pOrder : SetoidPartialOrder S _<_} (pOrderedRing : PartiallyOrderedRing R pOrder) {orderNontrivialX orderNontrivialY : A} (orderNontrivial : orderNontrivialX < orderNontrivialY) where

open Ring R
open Group additiveGroup
open Setoid S
open Equivalence eq
open SetoidPartialOrder pOrder
open import Rings.Orders.Partial.Lemmas pOrderedRing
open PartiallyOrderedRing pOrderedRing

IsInterval : {d : _} {pred : A → Set d} (subset : subset S pred) → Set (a ⊔ c ⊔ d)
IsInterval {pred = pred} subset = (x y : A) → (x<y : x < y) → pred x → pred y → (c : A) → (x < c) → (c < y) → pred c

-- Example: (a, b) is an interval
openBallPred : A → A → A → Set c
openBallPred a b x = (a < x) && (x < b)
openBallSubset : (a b : A) → subset S (openBallPred a b)
openBallSubset a b {x} {y} x=y (a<x ,, x<y) = <WellDefined reflexive x=y a<x ,, <WellDefined x=y reflexive x<y
openBallInterval : (a b : A) → IsInterval (openBallSubset a b)
openBallInterval a b x y x<y (a<x ,, x<b) (a<y ,, y<b) c x<c c<y = <Transitive a<x x<c ,, <Transitive c<y y<b

nonemptyBoundedIntervalHasLubImpliesAllLub : ({d : _} {pred : A → Set d} {subset : subset S pred} (interval : IsInterval subset) → (nonempty : Sg A pred) → (boundedAbove : Sg A (UpperBound pOrder subset)) → Sg A (LeastUpperBound pOrder subset)) → {d : _} → {pred : A → Set d} → (sub : subset S pred) → (nonempty : Sg A pred) → (boundedAbove : Sg A (UpperBound pOrder sub)) → Sg A (LeastUpperBound pOrder sub)
nonemptyBoundedIntervalHasLubImpliesAllLub axiom {d} {pred} sub (member , predMember) (bound , isBound) = lub , lubIsLub
  where
    intervalPredicate : A → Set (a ⊔ b ⊔ c ⊔ d)
    intervalPredicate a = Sg A (λ k → ((a < k) || (a ∼ k)) && pred k)
    intervalIsSubset : subset S intervalPredicate
    intervalIsSubset {x} {y} x=y (bigger , (inl x<bigger ,, biggerWorks)) = (bigger , (inl (<WellDefined x=y reflexive x<bigger) ,, biggerWorks))
    intervalIsSubset {x} {y} x=y (bigger , (inr x=bigger ,, biggerWorks)) = (bigger , (inr (transitive (symmetric x=y) x=bigger) ,, biggerWorks))
    intervalIsInterval : IsInterval intervalIsSubset
    intervalIsInterval x y x<y (dominateX , (x<dominateX ,, predDominateX)) (dominateY , (inl y<dominateY ,, predDominateY)) c x<c c<y = dominateY , (inl (<Transitive c<y y<dominateY) ,, predDominateY)
    intervalIsInterval x y x<y (dominateX , (x<dominateX ,, predDominateX)) (dominateY , (inr y=dominateY ,, predDominateY)) c x<c c<y = dominateY , (inl (<WellDefined reflexive y=dominateY c<y) ,, predDominateY)
    intervalNonempty : Sg A intervalPredicate
    intervalNonempty = ((member + orderNontrivialX) + inverse orderNontrivialY) , (member , (inl (<WellDefined (transitive groupIsAbelian +Associative) identLeft (orderRespectsAddition (moveInequality' orderNontrivial) member)) ,, predMember))
    intervalBounded : Sg A (UpperBound pOrder intervalIsSubset)
    intervalBounded = bound , ans
      where
        ans : (y : A) → intervalPredicate y → (y < bound) || (y ∼ bound)
        ans y (boundY , (y<boundY ,, predY)) with isBound boundY predY
        ans y (boundY , (inl y<boundY ,, predY)) | inl boundY<Bound = inl (<Transitive y<boundY boundY<Bound)
        ans y (boundY , (inr y=boundY ,, predY)) | inl boundY<Bound = inl (<WellDefined (symmetric y=boundY) reflexive boundY<Bound)
        ans y (boundY , (inl y<boundY ,, predY)) | inr boundY=Bound = inl (<WellDefined reflexive boundY=Bound y<boundY)
        ans y (boundY , (inr y=boundY ,, predY)) | inr boundY=Bound = inr (transitive y=boundY boundY=Bound)
    intervalLub : Sg A (LeastUpperBound pOrder intervalIsSubset)
    intervalLub = axiom intervalIsInterval intervalNonempty intervalBounded
    lub : A
    lub with intervalLub
    ... | b , _ = b
    lubProof : LeastUpperBound pOrder intervalIsSubset lub
    lubProof with intervalLub
    ... | b , pr = pr
    ubImpliesUbSub : {x : A} → UpperBound pOrder sub x → UpperBound pOrder intervalIsSubset x
    ubImpliesUbSub {x} ub y (bound , (y<bound ,, predBound)) with ub bound predBound
    ubImpliesUbSub {x} ub y (bound , (inl y<bound ,, predBound)) | inl bound<x = inl (<Transitive y<bound bound<x)
    ubImpliesUbSub {x} ub y (bound , (inr y=bound ,, predBound)) | inl bound<x = inl (<WellDefined (symmetric y=bound) reflexive bound<x)
    ubImpliesUbSub {x} ub y (bound , (inl y<bound ,, predBound)) | inr bound=x = inl (<WellDefined reflexive bound=x y<bound)
    ubImpliesUbSub {x} ub y (bound , (inr y=bound ,, predBound)) | inr bound=x = inr (transitive y=bound bound=x)
    ubSubImpliesUb : {x : A} → UpperBound pOrder intervalIsSubset x → UpperBound pOrder sub x
    ubSubImpliesUb {x} ub y predY with ub y (y , (inr reflexive ,, predY))
    ubSubImpliesUb {x} ub y predY | inl t<x = inl t<x
    ubSubImpliesUb {x} ub y predY | inr t=x = inr t=x
    lubIsLub : LeastUpperBound pOrder sub lub
    LeastUpperBound.upperBound lubIsLub = ubSubImpliesUb (LeastUpperBound.upperBound lubProof)
    LeastUpperBound.leastUpperBound lubIsLub y yIsUpperBound = LeastUpperBound.leastUpperBound lubProof y (ubImpliesUbSub yIsUpperBound)


module Implicits.Everything where

-- common agda stdlib imports
open import Prelude

--
-- Oliveira's calculi in Agda
--

-- We give a well-scoped version of Oliveira's ambiguous and deterministic
-- resolution rules
open import Implicits.Resolution.Ambiguous.Resolution
open import Implicits.Resolution.Deterministic.Resolution

-- and prove soundness of det. resolution w.r.t the ambiguous one
open import Implicits.Resolution.Deterministic.Expressiveness

-- we show that Oliveira's deterministic rules are incomplete w.r.t.
-- the ambiguous resolution
open import Implicits.Resolution.Deterministic.Incomplete

-- and prove ambiguous resolution undecidable
open import Implicits.Resolution.Ambiguous.SystemFEquiv
open import Implicits.Resolution.Ambiguous.Undecidable

--
-- Partial resolution
--

-- We maintain the syntax-directedness of the rules and strenghten the hypothesis of r-simp
-- to circumvent the weakness of Oliveira's deterministic rules.
-- In order to maintain strict-positiveness of the rules, we drop determinacy.
-- We will regain determinacy in the algorithmic description of resolution.
open import Implicits.Resolution.Infinite.Resolution

-- We first show that the rules are isomorphic to EBNF System F expressions
-- and use it to prove that infinite resolution is complete w.r.t. ambiguous resolution.
open import Implicits.Resolution.Infinite.NormalFormEquiv
open import Implicits.Resolution.Infinite.Expressiveness

-- Furthermore we give a partial algorithm for infinite resolution.
-- We have soundness and develop partial completeness for this algorithm.
open import Implicits.Resolution.Infinite.Algorithm
open import Implicits.Resolution.Infinite.Algorithm.Soundness
-- open import Implicits.Resolution.Infinite.Algorithm.Completeness

-- We'd love to show that the existence of a finite resolution Δ ⊢ᵣ r guarantees
-- termination of the partial resolution algorithm on input r;
-- but this clearly isn't a theorem: it's easy to imagine an implicit context that both has
-- a diverging 'trap' for the deterministic algorithm but also allows a finite 'shortcut'
-- derivation (hiding behind the trap).
-- In fact, the fact that infinite resolution is complete w.r.t. Ambiguous resolution,
-- indirectly proves that it's undecidable.

-- Instead we define a version of infinite resolution with a generic termination condition
open import Implicits.Resolution.GenericFinite.TerminationCondition
open import Implicits.Resolution.GenericFinite.Resolution
open import Implicits.Resolution.GenericFinite.Expressiveness

-- We give a total algorithm and prove it sound
open import Implicits.Resolution.GenericFinite.Algorithm
open import Implicits.Resolution.GenericFinite.Algorithm.Soundness
-- and develop completeness; finished modulo 2 lemmas
-- open import Implicits.Resolution.GenericFinite.Algorithm.Completeness

-- We provide two examples of termination conditions
-- A simple "maximum depth" condition like Coq's auto tactic has:
open import Implicits.Resolution.GenericFinite.Examples.MaximumDepth
-- And basically a termination condition inspired by Haskell's conditions on
-- typeclasses, developed by Oliveira et al.
-- Importantly we prove that the resulting calculus is more expressive than
-- Oliveira's deterministic resolution
open import Implicits.Resolution.GenericFinite.Examples.Haskell

-- We define a denotation semantics for the entire calculus -- into System F.
-- To this end we develop System F:
open import SystemF.Syntax
open import SystemF.WellTyped
open import SystemF.SmallStep
open import SystemF.NormalForm

-- The actual semantics is implemented aa module that depends on
-- the semantics for your favorite flavor of resolution.
-- It includes a proof that the translation preserves the typing relation.
open import Implicits.Semantics.Preservation
open import Implicits.Semantics


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

module Issue333 where

open import Common.Level

data Σ a b (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  _,_ : (x : A) → B x → Σ a b A B

P : ∀ a b (A : Set a) (B : Set b) → Set (a ⊔ b)
P a b A B = Σ a b A (λ _ → B)

postulate
  A B : Set
  foo : Σ lzero lzero A λ (y : A) → P lzero lzero A B

bar : Set₁
bar = helper foo
  where
  helper : (Σ _ _ A λ (y : A) → P _ _ _ _) → Set₁
  helper (y , (x⇓ , fy⇑)) = Set


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

-- this is mostly reference for an unused intermediate step.
module Cauchy2 where

open import Data.Nat
open import Data.Vec renaming (map to mapV; _++_ to _++V_; concat to concatV)
open import Data.Fin using (Fin; inject+; raise; inject≤; fromℕ; toℕ)
open import Function using (id)
open import Relation.Binary.PropositionalEquality using (_≡_; subst)

open import VectorLemmas
open import LeqLemmas
open import Cauchy using (id+)

Cauchy : ℕ → ℕ → Set
Cauchy n₁ n₂ = Vec (Fin n₁) n₂

------------------------------------------------------------------------------
-- Elementary permutations in the Cauchy representation

emptycauchy : Cauchy 0 0
emptycauchy = []

idcauchy : (n : ℕ) → Cauchy n n
idcauchy = allFin

-- Sequential composition

scompcauchy : ∀ {n₀ n₁ n₂} → Cauchy n₁ n₀ → Cauchy n₂ n₁ → Cauchy n₂ n₀
scompcauchy {n} perm₁ perm₂ =
 tabulate (λ i → lookup (lookup i perm₁) perm₂)

-- swap the first m elements with the last n elements
-- [ v₀ , v₁   , v₂   , ... , vm-1 ,     vm , vm₊₁ , ... , vm+n-1 ]
-- ==>
-- [ vm , vm₊₁ , ... , vm+n-1 ,     v₀ , v₁   , v₂   , ... , vm-1 ]

swap+cauchy : (m n : ℕ) → Cauchy (m + n) (n + m)
swap+cauchy m n = {!!} -- tabulate swapper

-- Parallel additive composition
-- append both permutations but adjust the indices in the second
-- permutation by the size of the first type so that it acts on the
-- second part of the vector

pcompcauchy : ∀ {m₁ n₁ m₂ n₂} → Cauchy m₁ m₂ → Cauchy n₁ n₂ → Cauchy (m₁ + n₁) (m₂ + n₂)
pcompcauchy {m} {n} α β = mapV (inject+ n) α ++V mapV (raise m) β

-- Tensor multiplicative composition
-- Transpositions in α correspond to swapping entire rows
-- Transpositions in β correspond to swapping entire columns
tcompcauchy : ∀ {m₁ n₁ m₂ n₂} → Cauchy m₁ m₂ → Cauchy n₁ n₂ → Cauchy (m₁ * n₁) (m₂ * n₂)
tcompcauchy {m} {n} α β =
 concatV
   (mapV
     (λ b →
        mapV (λ d → inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d)) β)
     α)

-- swap⋆
--
-- This is essentially the classical problem of in-place matrix transpose:
-- "http://en.wikipedia.org/wiki/In-place_matrix_transposition"
-- Given m and n, the desired permutation in Cauchy representation is:
-- P(i) = m*n-1 if i=m*n-1
--      = m*i mod m*n-1 otherwise

transposeIndex : (m n : ℕ) →
      (b : Fin m) → (d : Fin n) → Fin (n * m)
transposeIndex m n b d =
   inject≤ (fromℕ (toℕ d * m + toℕ b))
     (i*n+k≤m*n d b)
 {- inject≤
   (fromℕ (toℕ d * m + toℕ b))
   (trans≤ (i*n+k≤m*n d b) (refl′ (*-comm n m))) -}

swap⋆cauchy : (m₁ n₁ m₂ n₂ : ℕ) → (meq : m₂ ≡ m₁) → (neq : n₂ ≡ n₁) → Cauchy (n₁ * m₁) (n₂ * m₂)
swap⋆cauchy m₁ n₁ m₂ n₂ meq neq =
 concatV (mapV
           (λ d → mapV (λ b → transposeIndex m₁ n₁ (subst Fin meq b) (subst Fin neq d)) (allFin m₂))
           (allFin n₂))


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

open import LogicalFormulae
open import Semirings.Definition
open import Numbers.Naturals.Order
open import Numbers.Naturals.Semiring

module Numbers.Naturals.Order.Lemmas where
open Semiring ℕSemiring

inequalityShrinkRight : {a b c : ℕ} → a +N b <N c → b <N c
inequalityShrinkRight {a} {b} {c} (le x proof) = le (x +N a) (transitivity (applyEquality succ (equalityCommutative (Semiring.+Associative ℕSemiring x a b))) proof)

inequalityShrinkLeft : {a b c : ℕ} → a +N b <N c → a <N c
inequalityShrinkLeft {a} {b} {c} (le x proof) = le (x +N b) (transitivity (applyEquality succ (transitivity (equalityCommutative (Semiring.+Associative ℕSemiring x b a)) (applyEquality (x +N_) (Semiring.commutative ℕSemiring b a)))) proof)

productCancelsRight : (a b c : ℕ) → (zero <N a) → (b *N a ≡ c *N a) → (b ≡ c)
productCancelsRight a zero zero aPos eq = refl
productCancelsRight zero zero (succ c) (le x ()) eq
productCancelsRight (succ a) zero (succ c) aPos eq = contr
  where
    h : zero ≡ succ c *N succ a
    h = eq
    contr : zero ≡ succ c
    contr = exFalso (naughtE h)
productCancelsRight zero (succ b) zero (le x ()) eq
productCancelsRight (succ a) (succ b) zero aPos eq = contr
  where
    h : succ b *N succ a ≡ zero
    h = eq
    contr : succ b ≡ zero
    contr = exFalso (naughtE (equalityCommutative h))
productCancelsRight zero (succ b) (succ c) (le x ()) eq
productCancelsRight (succ a) (succ b) (succ c) aPos eq = applyEquality succ (productCancelsRight (succ a) b c aPos l)
    where
      i : succ a +N b *N succ a ≡ succ c *N succ a
      i = eq
      j : succ c *N succ a ≡ succ a +N c *N succ a
      j = refl
      k : succ a +N b *N succ a ≡ succ a +N c *N succ a
      k = transitivity i j
      l : b *N succ a ≡ c *N succ a
      l = canSubtractFromEqualityLeft {succ a} {b *N succ a} {c *N succ a} k

productCancelsLeft : (a b c : ℕ) → (zero <N a) → (a *N b ≡ a *N c) → (b ≡ c)
productCancelsLeft a b c aPos pr = productCancelsRight a b c aPos j
  where
    i : b *N a ≡ a *N c
    i = identityOfIndiscernablesLeft _≡_ pr (multiplicationNIsCommutative a b)
    j : b *N a ≡ c *N a
    j = identityOfIndiscernablesRight _≡_ i (multiplicationNIsCommutative a c)

productCancelsRight' : (a b c : ℕ) → (b *N a ≡ c *N a) → (a ≡ zero) || (b ≡ c)
productCancelsRight' zero b c pr = inl refl
productCancelsRight' (succ a) b c pr = inr (productCancelsRight (succ a) b c (succIsPositive a) pr)

productCancelsLeft' : (a b c : ℕ) → (a *N b ≡ a *N c) → (a ≡ zero) || (b ≡ c)
productCancelsLeft' zero b c pr = inl refl
productCancelsLeft' (succ a) b c pr = inr (productCancelsLeft (succ a) b c (succIsPositive a) pr)

subtractionPreservesInequality : {a b : ℕ} → (c : ℕ) → a +N c <N b +N c → a <N b
subtractionPreservesInequality {a} {b} zero prABC rewrite commutative a 0 | commutative b 0 = prABC
subtractionPreservesInequality {a} {b} (succ c) (le x proof) = le x (canSubtractFromEqualityRight {b = succ c} (transitivity (equalityCommutative (+Associative (succ x) a (succ c))) proof))

cancelInequalityLeft : {a b c : ℕ} → a *N b <N a *N c → b <N c
cancelInequalityLeft {a} {zero} {zero} (le x proof) rewrite (productZeroRight a) = exFalso (naughtE (equalityCommutative proof))
cancelInequalityLeft {a} {zero} {succ c} pr = succIsPositive c
cancelInequalityLeft {a} {succ b} {zero} (le x proof) rewrite (productZeroRight a) = exFalso (naughtE (equalityCommutative proof))
cancelInequalityLeft {a} {succ b} {succ c} pr = succPreservesInequality q'
  where
    p' : succ b *N a <N succ c *N a
    p' = canFlipMultiplicationsInIneq {a} {succ b} {a} {succ c} pr
    p'' : b *N a +N a <N succ c *N a
    p'' = identityOfIndiscernablesLeft _<N_ p' (commutative a (b *N a))
    p''' : b *N a +N a <N c *N a +N a
    p''' = identityOfIndiscernablesRight _<N_ p'' (commutative a (c *N a))
    p : b *N a <N c *N a
    p = subtractionPreservesInequality a p'''
    q : a *N b <N a *N c
    q = canFlipMultiplicationsInIneq {b} {a} {c} {a} p
    q' : b <N c
    q' = cancelInequalityLeft {a} {b} {c} q

<NProp : {a b : ℕ} → .(a <N b) → a <N b
<NProp {zero} {succ b} a<b = succIsPositive _
<NProp {succ a} {succ b} a<b = succPreservesInequality (<NProp (canRemoveSuccFrom<N a<b))

zeroLeast : {m n : ℕ} → m <N n → 0 <N n
zeroLeast {zero} m<n = m<n
zeroLeast {succ m} {succ n} m<n = le n (applyEquality succ (Semiring.sumZeroRight ℕSemiring n))


------------------------------------------------------------------------
-- Lists parameterised on things in Set₁
------------------------------------------------------------------------

-- I want universe polymorphism.

module Data.List1 where

open import Data.List as List using (List; []; _∷_)
open import Data.Nat

infixr 5 _∷_ _++_

data List₁ (a : Set₁) : Set₁ where
  []  : List₁ a
  _∷_ : (x : a) (xs : List₁ a) → List₁ a

_++_ : ∀ {a} → List₁ a → List₁ a → List₁ a
[]       ++ bs = bs
(a ∷ as) ++ bs = a ∷ (as ++ bs)

map₀₁ : ∀ {a b} → (a → b) → List a → List₁ b
map₀₁ f []       = []
map₀₁ f (x ∷ xs) = f x ∷ map₀₁ f xs

map₁₁ : ∀ {a b} → (a → b) → List₁ a → List₁ b
map₁₁ f []       = []
map₁₁ f (x ∷ xs) = f x ∷ map₁₁ f xs

replicate : ∀ {a} → (n : ℕ) → a → List₁ a
replicate zero    x = []
replicate (suc n) x = x ∷ replicate n x

foldr₁₀ : {a : Set₁} {b : Set} → (a → b → b) → b → List₁ a → b
foldr₁₀ c n []       = n
foldr₁₀ c n (x ∷ xs) = c x (foldr₁₀ c n xs)

foldr₁₁ : {a b : Set₁} → (a → b → b) → b → List₁ a → b
foldr₁₁ c n []       = n
foldr₁₁ c n (x ∷ xs) = c x (foldr₁₁ c n xs)

length : ∀ {A} → List₁ A → ℕ
length []       = zero
length (x ∷ xs) = suc (length xs)


module L.Base.Sigma.Properties where

open import L.Base.Sigma.Core

choice : ∀{a b c} {A : Set a} {B : Set b} → {C : A → B → Set c}
         → ((x : A) → Σ B (λ y → C x y)) → Σ (A → B) (λ f → (a : A) → C a (f a))
choice = λ F → ((λ x → fst (F x)) , λ a → snd (F a))


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

module Function.Surjective where

open import Function.Surjective.Base public


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing where

open import Cubical.Algebra.CommRing.Base public
open import Cubical.Algebra.CommRing.Properties public


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.EquivCarac.An[X]X-A where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.Sigma
open import Cubical.Data.FinData
open import Cubical.Data.Empty as ⊥

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-Quotient

open import Cubical.Relation.Nullary

open import Cubical.HITs.SetQuotients as SQ
open import Cubical.HITs.PropositionalTruncation as PT

private variable
  ℓ : Level

-----------------------------------------------------------------------------
-- Functions

module Properties-Equiv-QuotientXn-A
  (Ar@(A , Astr) : CommRing ℓ)
  (n : ℕ)
  where

  open CommRingStr Astr using ()
    renaming
    ( 0r        to 0A
    ; 1r        to 1A
    ; _+_       to _+A_
    ; -_        to -A_
    ; _·_       to _·A_
    ; +Assoc    to +AAssoc
    ; +Identity to +AIdentity
    ; +Lid      to +ALid
    ; +Rid      to +ARid
    ; +Inv      to +AInv
    ; +Linv     to +ALinv
    ; +Rinv     to +ARinv
    ; +Comm     to +AComm
    ; ·Assoc    to ·AAssoc
    ; ·Identity to ·AIdentity
    ; ·Lid      to ·ALid
    ; ·Rid      to ·ARid
    ; ·Rdist+   to ·ARdist+
    ; ·Ldist+   to ·ALdist+
    ; is-set    to isSetA     )

  open CommRingStr (snd (A[X1,···,Xn] Ar n) ) using ()
    renaming
    ( 0r        to 0PA
    ; 1r        to 1PA
    ; _+_       to _+PA_
    ; -_        to -PA_
    ; _·_       to _·PA_
    ; +Assoc    to +PAAssoc
    ; +Identity to +PAIdentity
    ; +Lid      to +PALid
    ; +Rid      to +PARid
    ; +Inv      to +PAInv
    ; +Linv     to +PALinv
    ; +Rinv     to +PARinv
    ; +Comm     to +PAComm
    ; ·Assoc    to ·PAAssoc
    ; ·Identity to ·PAIdentity
    ; ·Lid      to ·PALid
    ; ·Rid      to ·PARid
    ; ·Comm     to ·PAComm
    ; ·Rdist+   to ·PARdist+
    ; ·Ldist+   to ·PALdist+
    ; is-set    to isSetPA     )

  open CommRingStr (snd (A[X1,···,Xn]/<X1,···,Xn> Ar n)) using ()
    renaming
    ( 0r        to 0PAI
    ; 1r        to 1PAI
    ; _+_       to _+PAI_
    ; -_        to -PAI_
    ; _·_       to _·PAI_
    ; +Assoc    to +PAIAssoc
    ; +Identity to +PAIIdentity
    ; +Lid      to +PAILid
    ; +Rid      to +PAIRid
    ; +Inv      to +PAIInv
    ; +Linv     to +PAILinv
    ; +Rinv     to +PAIRinv
    ; +Comm     to +PAIComm
    ; ·Assoc    to ·PAIAssoc
    ; ·Identity to ·PAIIdentity
    ; ·Lid      to ·PAILid
    ; ·Rid      to ·PAIRid
    ; ·Rdist+   to ·PAIRdist+
    ; ·Ldist+   to ·PAILdist+
    ; is-set    to isSetPAI     )

  open RingTheory

  discreteVecℕn = VecPath.discreteA→discreteVecA discreteℕ n

-----------------------------------------------------------------------------
-- Direct sens

  PA→A : A[x1,···,xn] Ar n → A
  PA→A = Poly-Rec-Set.f Ar n _ isSetA
          0A
          base-trad
          _+A_
          +AAssoc
          +ARid
          +AComm
          base-0P-eq
          base-Poly+-eq
        where
        base-trad : (v : Vec ℕ n) → (a : A) → A
        base-trad v a with (discreteVecℕn v (replicate 0))
        ... | yes p = a
        ... | no ¬p = 0A

        base-0P-eq : (v : Vec ℕ n) → base-trad v 0A ≡ 0A
        base-0P-eq v with (discreteVecℕn v (replicate 0))
        ... | yes p = refl
        ... | no ¬p = refl

        base-Poly+-eq : (v : Vec ℕ n) → (a b : A) → base-trad v a +A base-trad v b ≡ base-trad v (a +A b)
        base-Poly+-eq v a b with (discreteVecℕn v (replicate 0))
        ... | yes p = refl
        ... | no ¬p = +ARid _

  PA→A-pres1 :  PA→A 1PA ≡ 1A
  PA→A-pres1 with (discreteVecℕn (replicate 0) (replicate 0))
  ... | yes p = refl
  ... | no ¬p = ⊥.rec (¬p refl)

  PA→A-pres+ : (P Q : A[x1,···,xn] Ar n) → PA→A (P +PA Q) ≡ PA→A P +A PA→A Q
  PA→A-pres+ P Q = refl

  PA→A-pres· : (P Q : A[x1,···,xn] Ar n) → PA→A (P ·PA Q) ≡ PA→A P ·A PA→A Q
  PA→A-pres· = Poly-Ind-Prop.f _ _ _
               (λ P u v i Q → isSetA _ _ (u Q) (v Q) i)
               (λ Q → sym (0LeftAnnihilates (CommRing→Ring Ar) _))
               (λ v a → Poly-Ind-Prop.f _ _ _ (λ Q → isSetA _ _)
                         (sym (0RightAnnihilates (CommRing→Ring Ar) _))
                         (λ v' a' → base-base-eq a a' v v')
                         λ {U V} ind-U ind-V → cong₂ _+A_ ind-U ind-V ∙ sym (·ARdist+ _ _ _))
               λ {U V} ind-U ind-V Q → cong₂ _+A_ (ind-U Q) (ind-V Q) ∙ sym (·ALdist+ _ _ _)
               where
               base-base-eq : (a a' : A) → (v v' : Vec ℕ n) →
                              PA→A (base v a ·PA base v' a') ≡ PA→A (base v a) ·A PA→A (base v' a')
               base-base-eq a a' v v' with (discreteVecℕn (v +n-vec v') (replicate 0))
                                           | (discreteVecℕn v (replicate 0))
                                           | (discreteVecℕn v' (replicate 0))
               ... | yes r | yes p | yes e = refl
               ... | yes r | yes p | no ¬q = ⊥.rec (¬q (snd (+n-vecSplitReplicate0 v v' r)))
               ... | yes r | no ¬p | q     = ⊥.rec (¬p (fst (+n-vecSplitReplicate0 v v' r)))
               ... | no ¬r | yes p | yes q = ⊥.rec (¬r (cong₂ _+n-vec_ p q ∙ +n-vec-rid _))
               ... | no ¬r | yes p | no ¬q = sym (0RightAnnihilates (CommRing→Ring Ar) _)
               ... | no ¬r | no ¬p | yes q = sym (0LeftAnnihilates (CommRing→Ring Ar) _)
               ... | no ¬r | no ¬p | no ¬q = sym (0RightAnnihilates (CommRing→Ring Ar) _)

  PA→A-cancel : (k : Fin n) → PA→A (<X1,···,Xn> Ar n k) ≡ 0A
  PA→A-cancel k with (discreteVecℕn (δℕ-Vec n (toℕ k)) (replicate 0))
  ... | yes p = ⊥.rec (δℕ-Vec-k<n→≢ n (toℕ k) (toℕ<n k) p)
  ... | no ¬p = refl

  PAr→Ar : CommRingHom (A[X1,···,Xn] Ar n) Ar
  fst PAr→Ar = PA→A
  snd PAr→Ar = makeIsRingHom PA→A-pres1 PA→A-pres+ PA→A-pres·

  PAIr→Ar : CommRingHom (A[X1,···,Xn]/<X1,···,Xn> Ar n) Ar
  PAIr→Ar = Quotient-FGideal-CommRing-CommRing.f (A[X1,···,Xn] Ar n) Ar PAr→Ar (<X1,···,Xn> Ar n) PA→A-cancel

  PAI→A : A[x1,···,xn]/<x1,···,xn> Ar n → A
  PAI→A = fst PAIr→Ar

-----------------------------------------------------------------------------
-- Converse sens

  A→PA : A → A[x1,···,xn] Ar n
  A→PA a = (base (replicate 0) a)

  A→PA-pres1 : A→PA 1A ≡ 1PA
  A→PA-pres1 = refl

  A→PA-pres+ : (a a' : A) → A→PA (a +A a') ≡ (A→PA a) +PA (A→PA a')
  A→PA-pres+ a a' = sym (base-poly+ _ _ _)

  A→PA-pres· : (a a' : A) → A→PA (a ·A a') ≡ (A→PA a) ·PA (A→PA a')
  A→PA-pres· a a' = cong (λ X → base X (a ·A a')) (sym (+n-vec-rid _))

  A→PAI : A → (A[x1,···,xn]/<x1,···,xn> Ar n)
  A→PAI = [_] ∘ A→PA

-----------------------------------------------------------------------------
-- Section

  e-sect : (a : A) → PAI→A (A→PAI a) ≡ a
  e-sect a with (discreteVecℕn (replicate 0) (replicate 0))
  ... | yes p = refl
  ... | no ¬p = ⊥.rec (¬p refl)

-----------------------------------------------------------------------------
-- Retraction

  open RingStr
  open IsRing

  e-retr : (x : A[x1,···,xn]/<x1,···,xn> Ar n) → A→PAI (PAI→A x) ≡ x
  e-retr = SQ.elimProp (λ _ → isSetPAI _ _)
           (Poly-Ind-Prop.f _ _ _ (λ _ → isSetPAI _ _)
           base0-eq
           base-eq
           λ {U V} ind-U ind-V → cong [_] (A→PA-pres+ _ _) ∙ cong₂ _+PAI_ ind-U ind-V)
           where
           base0-eq : A→PAI (PAI→A [ 0P ]) ≡ [ 0P ]
           base0-eq = cong [_] (base-0P (replicate 0))

           base-eq : (v : Vec ℕ n) → (a : A ) → [ A→PA (PA→A (base v a)) ] ≡ [ base v a ]
           base-eq v a with (discreteVecℕn v (replicate 0))
           ... | yes p = cong [_] (cong (λ X → base X a) (sym p))
           ... | no ¬p with (pred-vec-≢0 v ¬p)
           ... | k , v' , infkn , eqvv' = eq/ (base (replicate 0) 0A)
                                             (base v a) ∣ ((genδ-FinVec n k (base v' (-A a)) 0PA) , helper) ∣₁
               where
               helper : _
               helper = cong (λ X → X poly+ base v (-A a)) (base-0P (replicate 0))
                        ∙ +PALid (base v (-A a))
                        ∙ sym (
                          genδ-FinVec-ℕLinearCombi ((A[X1,···,Xn] Ar n)) n k infkn (base v' (-A a)) (<X1,···,Xn> Ar n)
                          ∙ cong₂ base (cong (λ X → v' +n-vec δℕ-Vec n X) (toFromId' n k infkn)) (·ARid _)
                          ∙ cong (λ X → base X (-A a)) (sym eqvv'))

-----------------------------------------------------------------------------
-- Equiv

module _
  (Ar@(A , Astr) : CommRing ℓ)
  (n : ℕ)
  where

  open Iso
  open Properties-Equiv-QuotientXn-A Ar n

  Equiv-QuotientX-A : CommRingEquiv (A[X1,···,Xn]/<X1,···,Xn> Ar n) Ar
  fst Equiv-QuotientX-A = isoToEquiv is
    where
    is : Iso (A[x1,···,xn]/<x1,···,xn> Ar n) A
    fun is = PAI→A
    inv is = A→PAI
    rightInv is = e-sect
    leftInv is = e-retr
  snd Equiv-QuotientX-A = snd PAIr→Ar

-- Warning this doesn't prove Z[X]/X ≅ ℤ because you get two definition,
-- see notation Multivariate-Quotient-notationZ for more details


{-# OPTIONS --cubical --no-import-sorts --safe --postfix-projections #-}

open import Cubical.Core.Everything

open import Cubical.Functions.Embedding
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport

-- A helper module for deriving univalence for a higher inductive-recursive
-- universe.
--
--  U is the type of codes
--  El is the decoding
--  un is a higher constructor that requires paths between codes to exist
--    for equivalences of decodings
--  comp is intended to be the computational behavior of El on un, although
--    it seems that being a path is sufficient.
--
-- Given a universe defined as above, it's possible to show that the path
-- space of the code type is equivalent to the path space of the actual
-- decodings, which are themselves determined by equivalences.
--
-- The levels are left independent, but of course it will generally be
-- impossible to define this sort of universe unless ℓ' < ℓ, because El will
-- be too big to go in a constructor of U. The exception would be if U could
-- be defined independently of El, though it might be tricky to get the right
-- higher structure in such a case.
module Cubical.Foundations.Univalence.Universe {ℓ ℓ'}
    (U : Type ℓ)
    (El : U → Type ℓ')
    (un : ∀ s t → El s ≃ El t → s ≡ t)
    (comp : ∀{s t} (e : El s ≃ El t) → cong El (un s t e) ≡ ua e)
  where
private
  variable
    A : Type ℓ'

module UU-Lemmas where
  reg : transport (λ _ → A) ≡ idfun A
  reg {A} i z = transp (λ _ → A) i z

  nu : ∀ x y → x ≡ y → El x ≃ El y
  nu x y p = transportEquiv (cong El p)

  cong-un-te
    : ∀ x y (p : El x ≡ El y)
    → cong El (un x y (transportEquiv p)) ≡ p
  cong-un-te x y p
    = comp (transportEquiv p) ∙ uaTransportη p

  nu-un : ∀ x y (e : El x ≃ El y) → nu x y (un x y e) ≡ e
  nu-un x y e
    = equivEq {e = nu x y (un x y e)} {f = e} λ i z
        → (cong (λ p → transport p z) (comp e) ∙ uaβ e z) i

  El-un-equiv : ∀ x i → El (un x x (idEquiv _) i) ≃ El x
  El-un-equiv x i = λ where
      .fst → transp (λ j → p j) (i ∨ ~ i)
      .snd → transp (λ j → isEquiv (transp (λ k → p (j ∧ k)) (~ j ∨ i ∨ ~ i)))
                (i ∨ ~ i) (idIsEquiv T)
    where
    T = El (un x x (idEquiv _) i)
    p : T ≡ El x
    p j = (comp (idEquiv _) ∙ uaIdEquiv {A = El x}) j i

  un-refl : ∀ x → un x x (idEquiv (El x)) ≡ refl
  un-refl x i j
    = hcomp (λ k → λ where
          (i = i0) → un x x (idEquiv (El x)) j
          (i = i1) → un x x (idEquiv (El x)) (j ∨ k)
          (j = i0) → un x x (idEquiv (El x)) (~ i ∨ k)
          (j = i1) → x)
        (un (un x x (idEquiv (El x)) (~ i)) x (El-un-equiv x (~ i)) j)

  nu-refl : ∀ x → nu x x refl ≡ idEquiv (El x)
  nu-refl x = equivEq {e = nu x x refl} {f = idEquiv (El x)} reg

  un-nu : ∀ x y (p : x ≡ y) → un x y (nu x y p) ≡ p
  un-nu x y p
    = J (λ z q → un x z (nu x z q) ≡ q) (cong (un x x) (nu-refl x) ∙ un-refl x) p

open UU-Lemmas
open Iso

equivIso : ∀ s t → Iso (s ≡ t) (El s ≃ El t)
equivIso s t .fun = nu s t
equivIso s t .inv = un s t
equivIso s t .rightInv = nu-un s t
equivIso s t .leftInv = un-nu s t

pathIso : ∀ s t → Iso (s ≡ t) (El s ≡ El t)
pathIso s t .fun = cong El
pathIso s t .inv = un s t ∘ transportEquiv
pathIso s t .rightInv = cong-un-te s t
pathIso s t .leftInv = un-nu s t

minivalence : ∀{s t} → (s ≡ t) ≃ (El s ≃ El t)
minivalence {s} {t} = isoToEquiv (equivIso s t)

path-reflection : ∀{s t} → (s ≡ t) ≃ (El s ≡ El t)
path-reflection {s} {t} = isoToEquiv (pathIso s t)

isEmbeddingEl : isEmbedding El
isEmbeddingEl s t = snd path-reflection


module Empty where

  record ⊤ : Set where
    constructor tt

  data ⊥ : Set where

  {-# IMPORT Data.FFI #-}
  {-# COMPILED_DATA ⊥ Data.FFI.AgdaEmpty #-}

  absurd : ∀ { A : Set } → ⊥ → A
  absurd ()


-- {-# OPTIONS -v tc.meta:100 #-}
-- Andreas, 2011-09-21 (fix by Ulf)
module Issue458b where

data _≡_ {A : Set}(a : A) : A -> Set where
  refl : a ≡ a

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data Pair (A B : Set) : Set where
  pair : A -> B -> Pair A B

fst : {A B : Set} -> Pair A B -> A
fst (pair a b) = a

overzeal : let X : Nat -> Nat -> Nat
               X = _
               Y : Pair Nat Nat -> Nat
               Y = _
           in {C : Set} ->
              (({x y : Nat}        -> X x x ≡ Y (pair x y)) ->
               ({z : Pair Nat Nat} -> Y z ≡ fst z)          ->
               ({x y : Nat}        -> X x y ≡ x)            -> C) -> C
overzeal k = k refl refl refl
-- This should succeed.
-- However, before Ulf's fix the first constraint would lead to
-- a pruning of y from Y, since X does not depend on y
-- This lost the solution Y = fst.
{- ERROR was:
Cannot instantiate the metavariable _59 to (fst .z) since it
contains the variable .z which is not in scope of the metavariable
when checking that the expression refl has type (_59 ≡ fst .z)
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lexicographic ordering of lists
------------------------------------------------------------------------

-- The definition of lexicographic ordering used here is suitable if
-- the argument order is a strict partial order. The lexicographic
-- ordering itself can be either strict or non-strict, depending on
-- the value of a parameter.

module Relation.Binary.List.StrictLex where

open import Data.Empty
open import Data.Unit using (⊤; tt)
open import Function
open import Data.Product
open import Data.Sum
open import Data.List
open import Level
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.List.Pointwise as Pointwise
   using ([]; _∷_; head; tail)

module _ {A : Set} where

  data Lex (P : Set) (_≈_ _<_ : Rel A zero) : Rel (List A) zero where
    base : P                             → Lex P _≈_ _<_ []       []
    halt : ∀ {y ys}                      → Lex P _≈_ _<_ []       (y ∷ ys)
    this : ∀ {x xs y ys} (x<y : x < y)   → Lex P _≈_ _<_ (x ∷ xs) (y ∷ ys)
    next : ∀ {x xs y ys} (x≈y : x ≈ y)
           (xs⊴ys : Lex P _≈_ _<_ xs ys) → Lex P _≈_ _<_ (x ∷ xs) (y ∷ ys)

  -- Strict lexicographic ordering.

  Lex-< : (_≈_ _<_ : Rel A zero) → Rel (List A) zero
  Lex-< = Lex ⊥

  ¬[]<[] : ∀ {_≈_ _<_} → ¬ Lex-< _≈_ _<_ [] []
  ¬[]<[] (base ())

  -- Non-strict lexicographic ordering.

  Lex-≤ : (_≈_ _<_ : Rel A zero) → Rel (List A) zero
  Lex-≤ = Lex ⊤

  -- Utilities.

  ¬≤-this : ∀ {P _≈_ _<_ x y xs ys} → ¬ (x ≈ y) → ¬ (x < y) →
            ¬ Lex P _≈_ _<_ (x ∷ xs) (y ∷ ys)
  ¬≤-this ¬x≈y ¬x<y (this x<y)       = ¬x<y x<y
  ¬≤-this ¬x≈y ¬x<y (next x≈y xs⊴ys) = ¬x≈y x≈y

  ¬≤-next : ∀ {P _≈_ _<_ x y xs ys} →
            ¬ (x < y) → ¬ Lex P _≈_ _<_ xs ys →
            ¬ Lex P _≈_ _<_ (x ∷ xs) (y ∷ ys)
  ¬≤-next ¬x<y ¬xs⊴ys (this x<y)       = ¬x<y x<y
  ¬≤-next ¬x<y ¬xs⊴ys (next x≈y xs⊴ys) = ¬xs⊴ys xs⊴ys

  ----------------------------------------------------------------------
  -- Properties

  ≤-reflexive : ∀ _≈_ _<_ → Pointwise.Rel _≈_ ⇒ Lex-≤ _≈_ _<_
  ≤-reflexive _≈_ _<_ []            = base tt
  ≤-reflexive _≈_ _<_ (x≈y ∷ xs≈ys) =
    next x≈y (≤-reflexive _≈_ _<_ xs≈ys)

  <-irreflexive : ∀ {_≈_ _<_} → Irreflexive _≈_ _<_ →
                  Irreflexive (Pointwise.Rel _≈_) (Lex-< _≈_ _<_)
  <-irreflexive irr []            (base ())
  <-irreflexive irr (x≈y ∷ xs≈ys) (this x<y)       = irr x≈y x<y
  <-irreflexive irr (x≈y ∷ xs≈ys) (next x≊y xs⊴ys) =
    <-irreflexive irr xs≈ys xs⊴ys

  transitive : ∀ {P _≈_ _<_} →
               IsEquivalence _≈_ → _<_ Respects₂ _≈_ → Transitive _<_ →
               Transitive (Lex P _≈_ _<_)
  transitive {P} {_≈_} {_<_} eq resp tr = trans
    where
    trans : Transitive (Lex P _≈_ _<_)
    trans (base p)         (base _)         = base p
    trans (base y)         halt             = halt
    trans halt             (this y<z)       = halt
    trans halt             (next y≈z ys⊴zs) = halt
    trans (this x<y)       (this y<z)       = this (tr x<y y<z)
    trans (this x<y)       (next y≈z ys⊴zs) = this (proj₁ resp y≈z x<y)
    trans (next x≈y xs⊴ys) (this y<z)       =
       this (proj₂ resp (IsEquivalence.sym eq x≈y) y<z)
    trans (next x≈y xs⊴ys) (next y≈z ys⊴zs) =
       next (IsEquivalence.trans eq x≈y y≈z) (trans xs⊴ys ys⊴zs)

  antisymmetric :
    ∀ {P _≈_ _<_} →
    Symmetric _≈_ → Irreflexive _≈_ _<_ →  Asymmetric _<_ →
    Antisymmetric (Pointwise.Rel _≈_) (Lex P _≈_ _<_)
  antisymmetric {P} {_≈_} {_<_} sym ir asym = as
    where
    as : Antisymmetric (Pointwise.Rel _≈_) (Lex P _≈_ _<_)
    as (base _)         (base _)         = []
    as halt             ()
    as (this x<y)       (this y<x)       = ⊥-elim (asym x<y y<x)
    as (this x<y)       (next y≈x ys⊴xs) = ⊥-elim (ir (sym y≈x) x<y)
    as (next x≈y xs⊴ys) (this y<x)       = ⊥-elim (ir (sym x≈y) y<x)
    as (next x≈y xs⊴ys) (next y≈x ys⊴xs) = x≈y ∷ as xs⊴ys ys⊴xs

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

    asym : Asymmetric (Lex-< _≈_ _<_)
    asym (base bot)       _                = bot
    asym halt             ()
    asym (this x<y)       (this y<x)       = as x<y y<x
    asym (this x<y)       (next y≈x ys⊴xs) = irrefl (sym y≈x) x<y
    asym (next x≈y xs⊴ys) (this y<x)       = irrefl (sym x≈y) y<x
    asym (next x≈y xs⊴ys) (next y≈x ys⊴xs) = asym xs⊴ys ys⊴xs

  respects₂ : ∀ {P _≈_ _<_} →
              IsEquivalence _≈_ → _<_ Respects₂ _≈_ →
              Lex P _≈_ _<_ Respects₂ Pointwise.Rel _≈_
  respects₂ {P} {_≈_} {_<_} eq resp =
    (λ {xs} {ys} {zs} → resp¹ {xs} {ys} {zs}) ,
    (λ {xs} {ys} {zs} → resp² {xs} {ys} {zs})
    where
    resp¹ : ∀ {xs} → Lex P _≈_ _<_ xs Respects Pointwise.Rel _≈_
    resp¹ []            xs⊴[]            = xs⊴[]
    resp¹ (x≈y ∷ xs≈ys) halt             = halt
    resp¹ (x≈y ∷ xs≈ys) (this z<x)       = this (proj₁ resp x≈y z<x)
    resp¹ (x≈y ∷ xs≈ys) (next z≈x zs⊴xs) =
      next (Eq.trans z≈x x≈y) (resp¹ xs≈ys zs⊴xs)
      where module Eq = IsEquivalence eq

    resp² : ∀ {ys} → flip (Lex P _≈_ _<_) ys Respects Pointwise.Rel _≈_
    resp² []            []⊴ys            = []⊴ys
    resp² (x≈z ∷ xs≈zs) (this x<y)       = this (proj₂ resp x≈z x<y)
    resp² (x≈z ∷ xs≈zs) (next x≈y xs⊴ys) =
      next (Eq.trans (Eq.sym x≈z) x≈y) (resp² xs≈zs xs⊴ys)
      where module Eq = IsEquivalence eq

  decidable : ∀ {P _≈_ _<_} →
              Dec P → Decidable _≈_ → Decidable _<_ →
              Decidable (Lex P _≈_ _<_)
  decidable (yes p) dec-≈ dec-< []       []       = yes (base p)
  decidable (no ¬p) dec-≈ dec-< []       []       = no λ{(base p) → ¬p p}
  decidable dec-P   dec-≈ dec-< []       (y ∷ ys) = yes halt
  decidable dec-P   dec-≈ dec-< (x ∷ xs) []       = no (λ ())
  decidable dec-P   dec-≈ dec-< (x ∷ xs) (y ∷ ys) with dec-< x y
  ... | yes x<y = yes (this x<y)
  ... | no ¬x<y with dec-≈ x y
  ...           | no ¬x≈y = no (¬≤-this ¬x≈y ¬x<y)
  ...           | yes x≈y with decidable dec-P dec-≈ dec-< xs ys
  ...                     | yes xs⊴ys = yes (next x≈y xs⊴ys)
  ...                     | no ¬xs⊴ys = no (¬≤-next ¬x<y ¬xs⊴ys)

  <-decidable :
    ∀ {_≈_ _<_} →
    Decidable _≈_ → Decidable _<_ → Decidable (Lex-< _≈_ _<_)
  <-decidable = decidable (no id)

  ≤-decidable :
    ∀ {_≈_ _<_} →
    Decidable _≈_ → Decidable _<_ → Decidable (Lex-≤ _≈_ _<_)
  ≤-decidable = decidable (yes tt)

  -- Note that trichotomy is an unnecessarily strong precondition for
  -- the following lemma.

  ≤-total :
    ∀ {_≈_ _<_} →
    Symmetric _≈_ → Trichotomous _≈_ _<_ → Total (Lex-≤ _≈_ _<_)
  ≤-total {_≈_} {_<_} sym tri = total
    where
    total : Total (Lex-≤ _≈_ _<_)
    total []       []       = inj₁ (base tt)
    total []       (x ∷ xs) = inj₁ halt
    total (x ∷ xs) []       = inj₂ halt
    total (x ∷ xs) (y ∷ ys) with tri x y
    ... | tri< x<y _ _ = inj₁ (this x<y)
    ... | tri> _ _ y<x = inj₂ (this y<x)
    ... | tri≈ _ x≈y _ with total xs ys
    ...                | inj₁ xs≲ys = inj₁ (next      x≈y  xs≲ys)
    ...                | inj₂ ys≲xs = inj₂ (next (sym x≈y) ys≲xs)

  <-compare : ∀ {_≈_ _<_} →
              Symmetric _≈_ → Trichotomous _≈_ _<_ →
              Trichotomous (Pointwise.Rel _≈_) (Lex-< _≈_ _<_)
  <-compare {_≈_} {_<_} sym tri = cmp
   where
   cmp : Trichotomous (Pointwise.Rel _≈_) (Lex-< _≈_ _<_)
   cmp []       []       = tri≈ ¬[]<[] [] ¬[]<[]
   cmp []       (y ∷ ys) = tri< halt (λ ()) (λ ())
   cmp (x ∷ xs) []       = tri> (λ ()) (λ ()) halt
   cmp (x ∷ xs) (y ∷ ys) with tri x y
   ... | tri< x<y ¬x≈y ¬y<x =
         tri< (this x<y) (¬x≈y ∘ head) (¬≤-this (¬x≈y ∘ sym) ¬y<x)
   ... | tri> ¬x<y ¬x≈y y<x =
         tri> (¬≤-this ¬x≈y ¬x<y) (¬x≈y ∘ head) (this y<x)
   ... | tri≈ ¬x<y x≈y ¬y<x with cmp xs ys
   ...    | tri< xs<ys ¬xs≈ys ¬ys<xs =
            tri< (next x≈y xs<ys) (¬xs≈ys ∘ tail) (¬≤-next ¬y<x ¬ys<xs)
   ...    | tri≈ ¬xs<ys xs≈ys ¬ys<xs =
            tri≈ (¬≤-next ¬x<y ¬xs<ys) (x≈y ∷ xs≈ys) (¬≤-next ¬y<x ¬ys<xs)
   ...    | tri> ¬xs<ys ¬xs≈ys ys<xs =
            tri> (¬≤-next ¬x<y ¬xs<ys) (¬xs≈ys ∘ tail) (next (sym x≈y) ys<xs)

  -- Some collections of properties which are preserved by Lex-≤ or
  -- Lex-<.

  ≤-isPreorder : ∀ {_≈_ _<_} →
                 IsEquivalence _≈_ → Transitive _<_ → _<_ Respects₂ _≈_ →
                 IsPreorder (Pointwise.Rel _≈_) (Lex-≤ _≈_ _<_)
  ≤-isPreorder {_≈_} {_<_} eq tr resp = record
    { isEquivalence = Pointwise.isEquivalence eq
    ; reflexive     = ≤-reflexive _≈_ _<_
    ; trans         = transitive eq resp tr
    }

  ≤-isPartialOrder : ∀ {_≈_ _<_} →
                     IsStrictPartialOrder _≈_ _<_ →
                     IsPartialOrder (Pointwise.Rel _≈_) (Lex-≤ _≈_ _<_)
  ≤-isPartialOrder {_≈_} {_<_} spo = record
    { isPreorder = ≤-isPreorder isEquivalence trans <-resp-≈
    ; antisym    = antisymmetric Eq.sym irrefl
                     (trans∧irr⟶asym {_≈_ = _≈_} {_<_ = _<_}
                                     Eq.refl trans irrefl)
    } where open IsStrictPartialOrder spo

  ≤-isTotalOrder : ∀ {_≈_ _<_} →
                   IsStrictTotalOrder _≈_ _<_ →
                   IsTotalOrder (Pointwise.Rel _≈_) (Lex-≤ _≈_ _<_)
  ≤-isTotalOrder sto = record
    { isPartialOrder =
        ≤-isPartialOrder (record
          { isEquivalence = isEquivalence
          ; irrefl        = tri⟶irr <-resp-≈ Eq.sym compare
          ; trans         = trans
          ; <-resp-≈      = <-resp-≈
          })
    ; total          = ≤-total Eq.sym compare
    } where open IsStrictTotalOrder sto

  ≤-isDecTotalOrder : ∀ {_≈_ _<_} →
                      IsStrictTotalOrder _≈_ _<_ →
                      IsDecTotalOrder (Pointwise.Rel _≈_) (Lex-≤ _≈_ _<_)
  ≤-isDecTotalOrder sto = record
    { isTotalOrder = ≤-isTotalOrder sto
    ; _≟_          = Pointwise.decidable _≟_
    ; _≤?_         = ≤-decidable _≟_ (tri⟶dec< compare)
    } where open IsStrictTotalOrder sto

  <-isStrictPartialOrder
    : ∀ {_≈_ _<_} → IsStrictPartialOrder _≈_ _<_ →
      IsStrictPartialOrder (Pointwise.Rel _≈_) (Lex-< _≈_ _<_)
  <-isStrictPartialOrder spo = record
    { isEquivalence = Pointwise.isEquivalence isEquivalence
    ; irrefl        = <-irreflexive irrefl
    ; trans         = transitive isEquivalence <-resp-≈ trans
    ; <-resp-≈      = respects₂ isEquivalence <-resp-≈
    } where open IsStrictPartialOrder spo

  <-isStrictTotalOrder
    : ∀ {_≈_ _<_} → IsStrictTotalOrder _≈_ _<_ →
      IsStrictTotalOrder (Pointwise.Rel _≈_) (Lex-< _≈_ _<_)
  <-isStrictTotalOrder sto = record
    { isEquivalence = Pointwise.isEquivalence isEquivalence
    ; trans         = transitive isEquivalence <-resp-≈ trans
    ; compare       = <-compare Eq.sym compare
    ; <-resp-≈      = respects₂ isEquivalence <-resp-≈
    } where open IsStrictTotalOrder sto

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

≤-preorder : Preorder _ _ _ → Preorder _ _ _
≤-preorder pre = record
  { isPreorder = ≤-isPreorder isEquivalence trans ∼-resp-≈
  } where open Preorder pre

≤-partialOrder : StrictPartialOrder _ _ _ → Poset _ _ _
≤-partialOrder spo = record
  { isPartialOrder = ≤-isPartialOrder isStrictPartialOrder
  } where open StrictPartialOrder spo

≤-decTotalOrder : StrictTotalOrder _ _ _ → DecTotalOrder _ _ _
≤-decTotalOrder sto = record
  { isDecTotalOrder = ≤-isDecTotalOrder isStrictTotalOrder
  } where open StrictTotalOrder sto

<-strictPartialOrder :
  StrictPartialOrder _ _ _ → StrictPartialOrder _ _ _
<-strictPartialOrder spo = record
  { isStrictPartialOrder = <-isStrictPartialOrder isStrictPartialOrder
  } where open StrictPartialOrder spo

<-strictTotalOrder : StrictTotalOrder _ _ _ → StrictTotalOrder _ _ _
<-strictTotalOrder sto = record
  { isStrictTotalOrder = <-isStrictTotalOrder isStrictTotalOrder
  } where open StrictTotalOrder sto


------------------------------------------------------------------------
-- The Agda standard library
--
-- Implications of nullary relations
------------------------------------------------------------------------

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

module Relation.Nullary.Implication where

open import Relation.Nullary
open import Data.Empty

-- Some properties which are preserved by _→_.

infixr 2 _→-dec_

_→-dec_ : ∀ {p q} {P : Set p} {Q : Set q} →
          Dec P → Dec Q → Dec (P → Q)
yes p →-dec no ¬q = no  (λ f → ¬q (f p))
yes p →-dec yes q = yes (λ _ → q)
no ¬p →-dec _     = yes (λ p → ⊥-elim (¬p p))


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Library where

module Literals where open import Light.Literals public

module Data where
      module Empty where open import Light.Library.Data.Empty public
      module Either where open import Light.Library.Data.Either public
      module Natural where open import Light.Library.Data.Natural public
      module Unit where open import Light.Library.Data.Unit public
      module Integer where open import Light.Library.Data.Integer public
      module Boolean where open import Light.Library.Data.Boolean public
      module Both where open import Light.Library.Data.Both public
      module Product where open import Light.Library.Data.Product public
      module These where open import Light.Library.Data.These public

module Relation where
      module Binary where
            open import Light.Library.Relation.Binary public
            module Equality where
                  open import Light.Library.Relation.Binary.Equality public
                  module Decidable where open import Light.Library.Relation.Binary.Equality.Decidable public
            module Decidable where open import Light.Library.Relation.Binary.Decidable public
      open import Light.Library.Relation public
      module Decidable where open import Light.Library.Relation.Decidable public

module Action where open import Light.Library.Action public

module Arithmetic where open import Light.Library.Arithmetic public
module Level where open import Light.Level public
module Subtyping where open import Light.Subtyping public

module Variable where
      module Levels where open import Light.Variable.Levels public
      module Sets where open import Light.Variable.Sets public
      module Other {ℓ} (𝕒 : Set ℓ) where open import Light.Variable.Other 𝕒 public

module Package where open import Light.Package public
open Package using (Package) hiding (module Package) public

-- module Indexed where open import Light.Indexed


-- 2018-09-05, reported by Andreas Abel
-- The new type-directed rewriting was using the wrong type for
-- constructors of parametrized datatypes.

{-# OPTIONS --rewriting #-}

module _ where

module _ (Form : Set) where

  open import Agda.Builtin.Equality
  {-# BUILTIN REWRITE _≡_ #-}

  data Cxt : Set where
    _∙_ : (Γ : Cxt) (A : Form) → Cxt

  data _≤_ : (Γ Δ : Cxt) → Set where
    id≤ : ∀{Γ} → Γ ≤ Γ
    lift : ∀{A Γ Δ} (τ : Γ ≤ Δ) → (Γ ∙ A) ≤ (Δ ∙ A)

  postulate
    lift-id≤ : ∀{Γ A} → lift id≤ ≡ id≤ {Γ ∙ A}

{-# REWRITE lift-id≤ #-}


-- Andreas, 2020-03-26, issue #4481, reported by gallais

-- #952 unintentionally added named lambdas; tests here.

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.term.expr.top:15 #-}
-- {-# OPTIONS -v tc.term.lambda:30 #-}

open import Agda.Primitive

-- Named lambdas:

postulate f : ({A : Set} → Set) → Set
_ = f λ {A = A} → A

postulate
  A : Set
  g : ({{a : A}} → A) → A
_ = g λ {{a = a}} → a

data ⊥ : Set where
record ⊤ : Set where

proj2 : ∀ a {A B : Set a} → Set a
proj2 = λ _ {B = B} → B

agdaIsConsistent : proj2 lzero {⊥} {⊤}
agdaIsConsistent = _


module RandomAccessList.Redundant.Core where

open import BuildingBlock.BinaryLeafTree using (BinaryLeafTree; Node; Leaf)

open import Data.Num.Redundant
open import Data.Nat using (ℕ; zero; suc)
open import Data.Nat.Etc

infixr 2 0∷ _1∷_ _,_2∷_

data 0-2-RAL (A : Set) : ℕ → Set where
    []     : ∀ {n}                                                               → 0-2-RAL A n
    0∷     : ∀ {n}                                           → 0-2-RAL A (suc n) → 0-2-RAL A n
    _1∷_   : ∀ {n} → BinaryLeafTree A n                      → 0-2-RAL A (suc n) → 0-2-RAL A n
    _,_2∷_ : ∀ {n} → BinaryLeafTree A n → BinaryLeafTree A n → 0-2-RAL A (suc n) → 0-2-RAL A n

--------------------------------------------------------------------------------
-- to Redundant Binary Numeral System
--------------------------------------------------------------------------------

⟦_⟧ₙ : ∀ {n A} → 0-2-RAL A n → Redundant
⟦          [] ⟧ₙ = []
⟦       0∷ xs ⟧ₙ = zero ∷ ⟦ xs ⟧ₙ
⟦ x     1∷ xs ⟧ₙ = one  ∷ ⟦ xs ⟧ₙ
⟦ x , y 2∷ xs ⟧ₙ = two  ∷ ⟦ xs ⟧ₙ

⟦_⟧ : ∀ {n A} → 0-2-RAL A n → Redundant
⟦_⟧ {n} xs = n <<< ⟦ xs ⟧ₙ

--------------------------------------------------------------------------------
-- to ℕ
--------------------------------------------------------------------------------

{-
[_]ₙ : ∀ {A n} → 0-2-RAL A n → ℕ
[          [] ]ₙ = 0
[       0∷ xs ]ₙ = 0 + 2 * [ xs ]ₙ
[ x     1∷ xs ]ₙ = 1 + 2 * [ xs ]ₙ
[ x , y 2∷ xs ]ₙ = 2 + 2 * [ xs ]ₙ

[_] : ∀ {n A} → 0-2-RAL A n → ℕ
[_] {n} xs = 2 ^ n * [ xs ]ₙ
-}


postulate
  F : (Set → Set) → Set

syntax F (λ x → y) = [ x ] y

X : Set
X = [ ? ] x


module UniDB.Subst.Star where

open import UniDB.Subst.Core
open import UniDB.Morph.Star

module _
  {T : STX} {{vrT : Vr T}} {{apTT : Ap T T}}
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
  where

  instance
    iLkStar : Lk T (Star Ξ)
    lk {{iLkStar}} ε        i = vr i
    lk {{iLkStar}} (ξs ▻ ξ) i = ap {T} ξ (lk ξs i)

    iLkIdmStar : LkIdm T (Star Ξ)
    lk-idm {{iLkIdmStar}} i = refl

    -- iLkCompApStar : {{apIdmT : ApIdm T T}} → LkCompAp T (Star Ξ)
    -- lk-⊙-ap {{iLkCompApStar}} ξs ε        i = sym (ap-idm T T (Star Ξ) (lk T (Star Ξ) ξs i))
    -- lk-⊙-ap {{iLkCompApStar}} ξs (ζs ▻ ζ) i =
    --   begin
    --     ap T T Ξ ζ (lk T (Star Ξ) (ξs ⊙ ζs) i)
    --   ≡⟨ cong (ap T T Ξ ζ) (lk-⊙-ap T (Star Ξ) ξs ζs i) ⟩
    --     ap T T Ξ ζ (ap T T (Star Ξ) ζs (lk T (Star Ξ) ξs i))
    --   ≡⟨ {!!} ⟩
    --     ap T T (Star Ξ) (ζs ▻ ζ) (lk T (Star Ξ) ξs i)
    --   ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- A categorical view of Stream
------------------------------------------------------------------------

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

module Codata.Stream.Categorical where

open import Data.Product using (<_,_>)
open import Codata.Stream
open import Function
open import Category.Functor
open import Category.Applicative
open import Category.Comonad

functor : ∀ {ℓ i} → RawFunctor {ℓ} (λ A → Stream A i)
functor = record { _<$>_ = λ f → map f }

applicative : ∀ {ℓ i} → RawApplicative {ℓ} (λ A → Stream A i)
applicative = record
  { pure = repeat
  ; _⊛_  = ap
  }

comonad : ∀ {ℓ} → RawComonad {ℓ} (λ A → Stream A _)
comonad = record
  { extract = head
  ; extend  = unfold ∘′ < tail ,_>
  }


module BasicIS4.Metatheory.Hilbert-TarskiGluedHilbert where

open import BasicIS4.Syntax.Hilbert public
open import BasicIS4.Semantics.TarskiGluedHilbert public

-- Internalisation of syntax as syntax representation in a particular model.

module _ {{_ : Model}} where
  [_] : ∀ {A Γ} → Γ ⊢ A → Γ [⊢] A
  [ var i ]   = [var] i
  [ app t u ] = [app] [ t ] [ u ]
  [ ci ]      = [ci]
  [ ck ]      = [ck]
  [ cs ]      = [cs]
  [ box t ]   = [box] [ t ]
  [ cdist ]   = [cdist]
  [ cup ]     = [cup]
  [ cdown ]   = [cdown]
  [ cpair ]   = [cpair]
  [ cfst ]    = [cfst]
  [ csnd ]    = [csnd]
  [ unit ]    = [unit]

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)           γ = lookup i γ
eval (app {A} {B} t u) γ = _⟪$⟫_ {A} {B} (eval t γ) (eval u γ)
eval ci                γ = K I
eval (ck {A} {B})      γ = K (⟪K⟫ {A} {B})
eval (cs {A} {B} {C})  γ = K (⟪S⟫′ {A} {B} {C})
eval (box t)           γ = K ([ box t ] ⅋ eval t ∙)
eval cdist             γ = K _⟪D⟫′_
eval cup               γ = K ⟪↑⟫
eval cdown             γ = K ⟪↓⟫
eval (cpair {A} {B})   γ = K (_⟪,⟫′_ {A} {B})
eval cfst              γ = K π₁
eval csnd              γ = K π₂
eval unit              γ = ∙

-- TODO: Correctness of evaluation with respect to conversion.

-- The canonical model.

private
  instance
    canon : Model
    canon = record
      { _⊩ᵅ_    = λ Γ P → Γ ⊢ α P
      ; mono⊩ᵅ  = mono⊢
      ; _[⊢]_   = _⊢_
      ; mono[⊢] = mono⊢
      ; [var]    = var
      ; [app]    = app
      ; [ci]     = ci
      ; [ck]     = ck
      ; [cs]     = cs
      ; [box]    = box
      ; [cdist]  = cdist
      ; [cup]    = cup
      ; [cdown]  = cdown
      ; [cpair]  = cpair
      ; [cfst]   = cfst
      ; [csnd]   = csnd
      ; [unit]   = unit
      }

-- Soundness and completeness with respect to the canonical model.

mutual
  reflectᶜ : ∀ {A Γ} → Γ ⊢ A → Γ ⊩ A
  reflectᶜ {α P}   t = t
  reflectᶜ {A ▻ B} t = λ η → let t′ = mono⊢ η t
                              in  λ a → reflectᶜ (app t′ (reifyᶜ a))
  reflectᶜ {□ A}   t = λ η → let t′ = mono⊢ η t
                              in  t′ ⅋ reflectᶜ (down t′)
  reflectᶜ {A ∧ B} t = reflectᶜ (fst t) , reflectᶜ (snd t)
  reflectᶜ {⊤}    t = ∙

  reifyᶜ : ∀ {A Γ} → Γ ⊩ A → Γ ⊢ A
  reifyᶜ {α P}   s = s
  reifyᶜ {A ▻ B} s = lam (reifyᶜ (s weak⊆ (reflectᶜ {A} v₀)))
  reifyᶜ {□ A}   s = syn (s refl⊆)
  reifyᶜ {A ∧ B} s = pair (reifyᶜ (π₁ s)) (reifyᶜ (π₂ s))
  reifyᶜ {⊤}    s = unit

reflectᶜ⋆ : ∀ {Ξ Γ} → Γ ⊢⋆ Ξ → Γ ⊩⋆ Ξ
reflectᶜ⋆ {∅}     ∙        = ∙
reflectᶜ⋆ {Ξ , A} (ts , t) = reflectᶜ⋆ ts , reflectᶜ t

reifyᶜ⋆ : ∀ {Ξ Γ} → Γ ⊩⋆ Ξ → Γ ⊢⋆ Ξ
reifyᶜ⋆ {∅}     ∙        = ∙
reifyᶜ⋆ {Ξ , A} (ts , t) = reifyᶜ⋆ ts , reifyᶜ t

-- Reflexivity and transitivity.

refl⊩⋆ : ∀ {Γ} → Γ ⊩⋆ Γ
refl⊩⋆ = reflectᶜ⋆ refl⊢⋆

trans⊩⋆ : ∀ {Γ Γ′ Γ″} → Γ ⊩⋆ Γ′ → Γ′ ⊩⋆ Γ″ → Γ ⊩⋆ Γ″
trans⊩⋆ ts us = reflectᶜ⋆ (trans⊢⋆ (reifyᶜ⋆ ts) (reifyᶜ⋆ us))

-- Completeness with respect to all models, or quotation.

quot : ∀ {A Γ} → Γ ⊨ A → Γ ⊢ A
quot s = reifyᶜ (s refl⊩⋆)

-- Normalisation by evaluation.

norm : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ A
norm = quot ∘ eval

-- TODO: Correctness of normalisation with respect to conversion.