{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Binary.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients.Base
open import Cubical.HITs.PropositionalTruncation.Base
open import Cubical.Foundations.Equiv.Fiberwise
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

private
  variable
    ℓA ℓA' ℓ ℓ' ℓ≅A ℓ≅A' ℓB : Level

-- Rel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
-- Rel A B ℓ' = A → B → Type ℓ'

Rel : (A : Type ℓA) (B : Type ℓB) (ℓ : Level) → Type (ℓ-max (ℓ-suc ℓ) (ℓ-max ℓA ℓB))
Rel A B ℓ = A → B → Type ℓ

PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b)

idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ
idPropRel A .fst a a' = ∥ a ≡ a' ∥
idPropRel A .snd _ _ = squash

invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ}
  → PropRel A B ℓ' → PropRel B A ℓ'
invPropRel R .fst b a = R .fst a b
invPropRel R .snd b a = R .snd a b

compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ}
  → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ''))
compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥
compPropRel R S .snd _ _ = squash

graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ
graphRel f a b = f a ≡ b

module _ {ℓ ℓ' : Level} {A : Type ℓ} (_R_ : Rel A A ℓ') where
  -- R is reflexive
  isRefl : Type (ℓ-max ℓ ℓ')
  isRefl = (a : A) → a R a

  -- R is symmetric
  isSym : Type (ℓ-max ℓ ℓ')
  isSym = (a b : A) → a R b → b R a

  -- R is transitive
  isTrans : Type (ℓ-max ℓ ℓ')
  isTrans = (a b c : A)  → a R b → b R c → a R c

  record isEquivRel : Type (ℓ-max ℓ ℓ') where
    constructor equivRel
    field
      reflexive : isRefl
      symmetric : isSym
      transitive : isTrans

  isPropValued : Type (ℓ-max ℓ ℓ')
  isPropValued = (a b : A) → isProp (a R b)

  isEffective : Type (ℓ-max ℓ ℓ')
  isEffective =
    (a b : A) → isEquiv (eq/ {R = _R_} a b)

  -- the total space corresponding to the binary relation w.r.t. a
  relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ')
  relSinglAt a = Σ[ a' ∈ A ] (a R a')

  -- the statement that the total space is contractible at any a
  contrRelSingl : Type (ℓ-max ℓ ℓ')
  contrRelSingl = (a : A) → isContr (relSinglAt a)

  -- assume a reflexive binary relation
  module _ (ρ : isRefl) where
    -- identity is the least reflexive relation
    ≡→R : {a a' : A} → a ≡ a' → a R a'
    -- ≡→R {a} {a'} p = subst (λ z → a R z) p (ρ a)
    ≡→R {a} {a'} p = J (λ z q → a R z) (ρ a) p

    -- what it means for a reflexive binary relation to be univalent
    isUnivalent : Type (ℓ-max ℓ ℓ')
    isUnivalent = (a a' : A) → isEquiv (≡→R {a} {a'})

    -- helpers for contrRelSingl→isUnivalent
    private
      module _ (a : A) where
        -- wrapper for ≡→R
        f = λ (a' : A) (p : a ≡ a') → ≡→R {a} {a'} p

        -- the corresponding total map that univalence
        -- of R will be reduced to
        totf : singl a → Σ[ a' ∈ A ] (a R a')
        totf (a' , p) = (a' , f a' p)

    -- if the total space corresponding to R is contractible
    -- then R is univalent
    -- because the singleton at a is also contractible
    contrRelSingl→isUnivalent : contrRelSingl → isUnivalent
    contrRelSingl→isUnivalent c a = q
      where
        abstract
          q = fiberEquiv (λ a' → a ≡ a')
                   (λ a' → a R a')
                   (f a)
                   (snd (propBiimpl→Equiv (isContr→isProp (isContrSingl a))
                                           (isContr→isProp (c a))
                                           (totf a)
                                           (λ _ → fst (isContrSingl a))))

    -- converse map. proof idea:
    -- equivalences preserve contractability,
    -- singletons are contractible
    -- and by the univalence assumption the total map is an equivalence
    isUnivalent→contrRelSingl : isUnivalent → contrRelSingl
    isUnivalent→contrRelSingl u a = q
      where
        abstract
          q = isContrRespectEquiv
                               (totf a , totalEquiv (a ≡_)
                                                    (a R_)
                                                    (f a)
                                                    λ a' → u a a')
                               (isContrSingl a)

    isUnivalent' : Type (ℓ-max ℓ ℓ')
    isUnivalent' = (a a' : A) → (a ≡ a') ≃ a R a'

    private
      module _ (e : isUnivalent') (a : A) where
        -- wrapper for ≡→R
        g = λ (a' : A) (p : a ≡ a') → e a a' .fst p

        -- the corresponding total map that univalence
        -- of R will be reduced to
        totg : singl a → Σ[ a' ∈ A ] (a R a')
        totg (a' , p) = (a' , g a' p)

      isUnivalent'→contrRelSingl : isUnivalent' → contrRelSingl
      isUnivalent'→contrRelSingl u a = q
        where
          abstract
            q = isContrRespectEquiv
                                 (totg u a , totalEquiv (a ≡_) (a R_) (g u a) λ a' → u a a' .snd)
                                 (isContrSingl a)

    isUnivalent'→isUnivalent : isUnivalent' → isUnivalent
    isUnivalent'→isUnivalent u = contrRelSingl→isUnivalent (isUnivalent'→contrRelSingl u)

    isUnivalent→isUnivalent' : isUnivalent → isUnivalent'
    isUnivalent→isUnivalent' u a a' = ≡→R {a} {a'} , u a a'

record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A)
              {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where
  constructor reliso
  field
    fun : A → A'
    inv : A' → A
    rightInv : (a' : A') → fun (inv a') ≅' a'
    leftInv : (a : A) → inv (fun a) ≅ a

RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'}
             (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A')
             {ρ : isRefl _≅_} {ρ' : isRefl _≅'_}
             (uni : isUnivalent _≅_ ρ) (uni' : isUnivalent _≅'_ ρ')
             (f : RelIso _≅_ _≅'_)
             → Iso A A'
Iso.fun (RelIso→Iso _ _ _ _ f) = RelIso.fun f
Iso.inv (RelIso→Iso _ _ _ _ f) = RelIso.inv f
Iso.rightInv (RelIso→Iso _ _≅'_ {ρ' = ρ'} _ uni' f) a'
  = invEquiv (≡→R _≅'_ ρ' , uni' (RelIso.fun f (RelIso.inv f a')) a') .fst (RelIso.rightInv f a')
Iso.leftInv (RelIso→Iso _≅_ _ {ρ = ρ} uni _ f) a
  = invEquiv (≡→R _≅_ ρ , uni (RelIso.inv f (RelIso.fun f a)) a) .fst (RelIso.leftInv f a)

EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
EquivRel A ℓ' = Σ[ R ∈ Rel A A ℓ' ] isEquivRel R

EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] isEquivRel (R .fst)


module Impure.STLCRef.Syntax where

open import Prelude hiding (subst)
open import Data.Vec
open import Data.List
open import Function

data Type : Set where
  Unit : Type
  _⇒_  : (a b : Type) → Type
  Ref  : Type → Type

infixl 10 _·_
data Exp : (n : ℕ) → Set where
  unit : ∀ {n} → Exp n
  var  : ∀ {n} → Fin n → Exp n
  loc  : ∀ {n} → ℕ → Exp n
  ƛ    : ∀ {n} → Type → Exp (suc n) → Exp n
  _·_  : ∀ {n} → (f e : Exp n) → Exp n
  ref  : ∀ {n} → (e : Exp n) → Exp n
  !_   : ∀ {n} → (e : Exp n) → Exp n
  _≔_  : ∀ {n} → (x y : Exp n) → Exp n

data Val : ∀ {n} → Exp n → Set where
  unit : ∀ {n} → Val {n} unit
  ƛ    : ∀ {n} A → (e : Exp (suc n)) → Val (ƛ A e)
  loc  : ∀ {n} i → Val {n} (loc i)

Store : ℕ → Set
Store n = List (∃ λ (e : Exp n) → Val e)

open import Data.Fin.Substitution

module ExpApp {T} (l : Lift T Exp) where
  open Lift l

  _/_ : ∀ {n n'} → Exp n → Sub T n n' → Exp n'
  var x / s = lift $ lookup x s
  ƛ A t / s = ƛ A (t / (s ↑))
  (f · e) / s = (f / s) · (e / s)
  unit / s = unit
  loc x / s = loc x
  ref e / s = ref (e / s)
  (! e) / s = ! (e / s)
  (e ≔ e₁) / s = (e / s) ≔ (e₁ / s)

  open Application (record { _/_ = _/_ }) using (_/✶_)

tmSubst : TermSubst Exp
tmSubst = record { var = var; app = ExpApp._/_ }

open TermSubst tmSubst hiding (var) public


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

open import Cubical.HITs.Ints.IsoInt.Base public


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

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

  -- This module provides a utility function to make it easy to
  -- provide the bft-lemma for implementations in which the
  -- participants can have different voting power.

  -- The module is parametrized with the number of participants -
  -- `authorsN`, and with a function - `votPower` - that assigns to
  -- each participant its voting power. The parameter `N` corresponds
  -- to the total voting power of all participants, as required by the
  -- parameter `totalVotPower` in the inner module. These
  -- implementations should assume a fixed unknown subset of malicious
  -- nodes - Byzantine - but should also assume a security threshold
  -- `bizF`, such that N > 3 * bizF, which should be provided in
  -- parameter `isBFT`.  Finally, the `bft-assumption` states that the
  -- combined voting power of Byzantine nodes must not exceed the
  -- security threshold `bizF`.

  -- The bft-lemma is the last lemma in this file and proves that in
  -- the intersection of any quorums, whose combined voting power is
  -- greater than or equal to `N - bizF`, there is an honest Member.

module LibraBFT.Abstract.BFT
  (authorsN      : ℕ)
  (votPower      : Fin authorsN → ℕ)
  (bizF          : ℕ)
  (isBFT         : f-sum votPower (allFin authorsN) ≥ suc (3 * bizF))
  (getPubKey     : Fin authorsN → PK)
 where

 -- The set of members of this epoch.
 Member : Set
 Member = Fin authorsN

 Meta-dishonest? :  ∀ (m : Member) → Dec (Meta-Dishonest-PK (getPubKey m))
 Meta-dishonest? m = Meta-DishonestPK? (getPubKey m)

 CombinedPower : List Member → ℕ
 CombinedPower = f-sum votPower

 TotalVotPower : ℕ
 TotalVotPower = f-sum votPower (allFin authorsN)

 open DecLemmas {A = Member} _≟Fin_

 -- The bft-assumption states that the combined voting power of
 -- Byzantine nodes must not exceed the security threshold
 -- `bizF`. Therefore, for any list of distinct participants, the
 -- combined power of the dishonest nodes is less than or equal to
 -- `bizF`.
 module _  (bft-assumption : ∀ (xs : List Member)
                           → allDistinct xs
                           → CombinedPower (List-filter Meta-dishonest? xs) ≤ bizF)
   where

   participants : List Member
   participants = allFin authorsN

   members⊆ : ∀ {xs : List Member} → xs ⊆List participants
   members⊆ {_} {x} _ = Any-tabulate⁺ {f = id} x refl

   union-votPower≤N : ∀ (xs ys : List Member)
                  → allDistinct xs → allDistinct ys
                  → CombinedPower (union xs ys) ≤ TotalVotPower
   union-votPower≤N xs ys dxs dys
     = sum-⊆-≤ (union xs ys) votPower (unionDistinct xs ys dxs dys) members⊆

   union-votPower≡ :  ∀ (xs ys : List Member)
                      → allDistinct xs → allDistinct ys
                      → CombinedPower (union xs ys) ≡ CombinedPower (xs ++ ys)
                                                    ∸ CombinedPower (intersect xs ys)
   union-votPower≡ xs [] dxs dys rewrite ++-identityʳ xs = refl
   union-votPower≡ xs (y ∷ ys) dxs dys
     with y ∈? xs
   ...| yes y∈xs rewrite union-votPower≡ xs ys dxs (allDistinctTail dys)
                       | sym (m+n∸n≡m (CombinedPower (xs ++ ys)) (votPower y))
                       | ∸-+-assoc (CombinedPower (xs ++ ys) + votPower y)
                                   (votPower y)
                                   (CombinedPower (intersect xs ys))
                       | map-++-commute votPower xs ys
                       | sum-++-commute (List-map votPower xs) (List-map votPower ys)
                       | +-assoc (CombinedPower xs)
                                 (CombinedPower ys)
                                 (votPower y)
                       | +-comm (CombinedPower ys) (votPower y)
                       | sym (sum-++-commute (List-map votPower xs) (List-map votPower (y ∷ ys)))
                       | sym (map-++-commute votPower xs (y ∷ ys)) = refl
   ...| no  y∉xs rewrite union-votPower≡ xs ys dxs (allDistinctTail dys)
                       | sym (+-∸-assoc (votPower y) (sumIntersect≤ xs ys votPower))
                       | map-++-commute votPower xs ys
                       | sum-++-commute (List-map votPower xs) (List-map votPower ys)
                       | sym (+-assoc (votPower y) (CombinedPower xs) (CombinedPower ys))
                       | +-comm (votPower y) (CombinedPower xs)
                       | +-assoc (CombinedPower xs) (votPower y) (CombinedPower ys)
                       | sym (sum-++-commute (List-map votPower xs) (List-map votPower (y ∷ ys)))
                       | sym (map-++-commute votPower xs (y ∷ ys)) = refl

   quorumInt>biz : ∀ (xs ys : List Member)
                 → TotalVotPower ∸ bizF ≤ CombinedPower xs
                 → TotalVotPower ∸ bizF ≤ CombinedPower ys
                 → CombinedPower (xs ++ ys) ∸ TotalVotPower ≤ CombinedPower (intersect xs ys)
                 → bizF + 1 ≤ CombinedPower (intersect xs ys)
   quorumInt>biz xs ys q≤x q≤y ≤combPower
     rewrite map-++-commute votPower xs ys
           | sum-++-commute (List-map votPower xs) (List-map votPower ys)
           = let powInt = CombinedPower (intersect xs ys)
                 p₁     = ≤-trans (∸-monoˡ-≤ TotalVotPower (+-mono-≤ q≤x q≤y)) ≤combPower
                 p₂     = subst (_≤ powInt) (simpExp₁ TotalVotPower bizF) p₁
                 p₃     = ≤-trans (∸-monoˡ-≤ (2 * bizF) isBFT) p₂
             in subst (_≤ powInt) (simpExp₂ bizF) p₃
       where  simpExp₁ : ∀ (x y : ℕ) → (x ∸ y) + (x ∸ y) ∸ x ≡ x ∸ (2 * y)
              simpExp₁ x y rewrite sym (*-identityʳ (x ∸ y))
                                 | sym (*-distribˡ-+ (x ∸ y) 1 1)
                                 | *-comm (x ∸ y) 2
                                 | *-distribˡ-∸ 2 x y
                                 | ∸-+-assoc (2 * x) (2 * y) x
                                 | +-comm (2 * y) x
                                 | sym (∸-+-assoc (2 * x) x (2 * y))
                                 | +-identityʳ x
                                 | m+n∸n≡m x x = refl

              simpExp₂ : ∀ (x : ℕ) → suc (3 * x) ∸ 2 * x ≡ x + 1
              simpExp₂ x rewrite +-∸-assoc 1 (*-monoˡ-≤ x {2} {3} (s≤s (s≤s z≤n)))
                               | sym (*-distribʳ-∸ x 3 2)
                               | sym (+-suc x 0) = refl

   partition-hon : ∀ {xs dis hon : List Member} {x : Member}
            → partition Meta-dishonest? xs ≡ (dis , x ∷ hon)
            → x ∈ xs × Meta-Honest-PK (getPubKey x)
   partition-hon {x ∷ xs} eq
     with Meta-dishonest? x | eq
   ...| no imp  | refl = here refl , imp
   ...| yes _   | eq₁
     with partition Meta-dishonest? xs | inspect (partition Meta-dishonest?) xs
   ...| _ , x₂ ∷ _ | [ eq₂ ] rewrite just-injective (cong (head ∘ proj₂) eq₁)
     = ×-map₁ there (partition-hon eq₂)

   partition-dis : ∀ {xs dis : List Member}
            → partition Meta-dishonest? xs ≡ (dis , [])
            → List-filter Meta-dishonest? xs ≡ xs
   partition-dis {[]} _ = refl
   partition-dis {x ∷ xs} eq
      with Meta-dishonest? x | eq
   ...| no ¬dis  | ()
   ...| yes _  | _
      with partition Meta-dishonest? xs | inspect (partition Meta-dishonest?) xs
   ...| _ , [] | [ eq₁ ] = cong (x ∷_) (partition-dis {xs} eq₁)

   -- TODO-1 : An alternative to prove this lemma would be:
   -- - First prove that
   --   CombinedPower (List-filter Meta-dishonest? xs) ≤ CombinedPower xs.
   -- - Then prove that:
   --   - If CombinedPower (List-filter Meta-dishonest? xs) < CombinedPower xs
   --     then ∃[ α ] (α ∈ xs × Meta-Honest-PK (getPubKey α)).
   --   - If CombinedPower (List-filter Meta-dishonest? xs ≡ CombinedPower xs we
   --   get a contradiction using the bft assumption (as we have now).
   find-honest : ∀ {xs : List Member}
               → allDistinct xs
               → bizF < CombinedPower xs
               → ∃[ α ] (α ∈ xs × Meta-Honest-PK (getPubKey α))
   find-honest {xs} sxs biz<
     with partition Meta-dishonest? xs | inspect (partition Meta-dishonest?) xs
   ...| dis , [] | [ eq ]
          = let bft     = bft-assumption xs sxs
                xsVot≤f = subst (_≤ bizF) (cong CombinedPower (partition-dis {xs} eq)) bft
            in ⊥-elim (<⇒≱ biz< xsVot≤f)
   ...| dis , x ∷ hon | [ eq ] = x , partition-hon eq

   bft-lemma : {xs ys : List Member}
             → allDistinct xs → allDistinct ys
             → TotalVotPower ∸ bizF ≤ CombinedPower xs
             → TotalVotPower ∸ bizF ≤ CombinedPower ys
             → ∃[ α ] (α ∈ xs × α ∈ ys × Meta-Honest-PK (getPubKey α))
   bft-lemma {xs} {ys} all≢xs all≢ys q≤≢xs q≤≢ys
     = let |q₁|+|q₂|   = CombinedPower (xs ++ ys)
           |q₁∩q₂|     = CombinedPower (intersect xs ys)
           |q₁∪q₂|≤n   = union-votPower≤N xs ys all≢xs all≢ys
           |q₁∪q₂|≡    = union-votPower≡ xs ys all≢xs all≢ys
           exp₁        = subst (_≤ TotalVotPower) |q₁∪q₂|≡ |q₁∪q₂|≤n
           exp₂        = m∸n≤o⇒m∸o≤n |q₁|+|q₂| |q₁∩q₂| TotalVotPower exp₁
           f+1≤|q₁∩q₂| = quorumInt>biz xs ys q≤≢xs q≤≢ys exp₂
           f<|q₁∩q₂|   = subst (_≤ |q₁∩q₂|) (+-comm bizF 1) f+1≤|q₁∩q₂|
           intDist     = intersectDistinct xs ys all≢xs all≢ys
           honInf      = find-honest {intersect xs ys} intDist f<|q₁∩q₂|
           h∈∩         = ∈-intersect xs ys ((proj₁ ∘ proj₂) honInf)
       in proj₁ honInf ,  proj₁ h∈∩ , proj₂ h∈∩ , (proj₂ ∘ proj₂) honInf


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

open import Setoids.Setoids
open import Rings.Definition
open import Rings.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Fields.Fields
open import Sets.EquivalenceRelations
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Semirings.Definition
open import Numbers.Modulo.Definition
open import Orders.Total.Definition

module Fields.CauchyCompletion.BaseExpansion {m n o : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {m} {o} A} {pOrder : SetoidPartialOrder S _<_} {R : Ring S _+_ _*_} {pRing : PartiallyOrderedRing R pOrder} (order : TotallyOrderedRing pRing) (F : Field R) where

open Setoid S
open SetoidTotalOrder (TotallyOrderedRing.total order)
open SetoidPartialOrder pOrder
open Equivalence eq
open PartiallyOrderedRing pRing
open Ring R
open Group additiveGroup
open Field F
open import Fields.Orders.Limits.Definition {F = F} (record { oRing = order })
open import Fields.Orders.Total.Lemmas {F = F} (record { oRing = order })
open import Fields.Orders.Limits.Lemmas {F = F} (record { oRing = order })

open import Fields.Lemmas F
open import Fields.Orders.Lemmas {F = F} record { oRing = order }
open import Rings.Orders.Total.Lemmas order
open import Rings.Orders.Total.AbsoluteValue order
open import Rings.Orders.Partial.Lemmas pRing
open import Fields.CauchyCompletion.Definition order F
open import Fields.CauchyCompletion.Setoid order F
open import Fields.CauchyCompletion.Addition order F
open import Fields.CauchyCompletion.Comparison order F
open import Fields.CauchyCompletion.Approximation order F
open import Rings.InitialRing R
open import Rings.Orders.Partial.Bounded pRing
open import Rings.Orders.Total.Bounded order
open import Rings.Orders.Total.Cauchy order

-- TODO this is not necessarily true :( the bounded sequence could oscillate between 1 and -1
cauchyTimesBoundedIsCauchy : {s : Sequence A} → cauchy s → {t : Sequence A} → Bounded t → cauchy (apply _*_ s t)
cauchyTimesBoundedIsCauchy {s} cau {t} (K , bounded) e 0<e with allInvertible K (boundNonzero (K , bounded))
... | 1/K , prK with cau (1/K * e) (orderRespectsMultiplication (reciprocalPositive K 1/K (boundGreaterThanZero (K , bounded)) (transitive *Commutative prK)) 0<e)
... | N , cauPr = N , ans
  where
    ans : {m n : ℕ} (N<m : N <N m) (N<n : N <N n) → (abs (index (apply _*_ s t) m + inverse (index (apply _*_ s t) n))) < e
    ans N<m N<n with cauPr N<m N<n
    ... | r = {!!}

boundedTimesCauchyIsCauchy : {s : Sequence A} → cauchy s → {t : Sequence A} → Bounded t → cauchy (apply _*_ t s)
boundedTimesCauchyIsCauchy {s} cau {t} bou = cauchyWellDefined (ans s t) (cauchyTimesBoundedIsCauchy cau bou)
  where
    ans : (s t : Sequence A) (m : ℕ) → index (apply _*_ s t) m ∼ index (apply _*_ t s) m
    ans s t m rewrite indexAndApply t s _*_ {m} | indexAndApply s t _*_ {m} = *Commutative

private
  digitExpansionSeq : {n : ℕ} → .(0<n : 0 <N n) → Sequence (ℤn n 0<n) → Sequence A
  Sequence.head (digitExpansionSeq {n} 0<n seq) = fromN (ℤn.x (Sequence.head seq))
  Sequence.tail (digitExpansionSeq {n} 0<n seq) = digitExpansionSeq 0<n (Sequence.tail seq)

  powerSeq : (i : A) → (start : A) → Sequence A
  Sequence.head (powerSeq i start) = start
  Sequence.tail (powerSeq i start) = powerSeq i (start * i)

  powerSeqInduction : (i : A) (start : A) → (m : ℕ) → (index (powerSeq i start) (succ m)) ∼ i * (index (powerSeq i start) m)
  powerSeqInduction i start zero = *Commutative
  powerSeqInduction i start (succ m) = powerSeqInduction i (start * i) m

  ofBaseExpansionSeq : {n : ℕ} → .(0<n : 0 <N n) → Sequence (ℤn n 0<n) → Sequence A
  ofBaseExpansionSeq {succ n} 0<n seq = apply _*_ (digitExpansionSeq 0<n seq) (powerSeq pow pow)
    where
      pow : A
      pow = underlying (allInvertible (fromN (succ n)) (charNotN n))

  powerSeqPositive : {i : A} → (0R < i) → {s : A} → (0R < s) → (m : ℕ) → 0R < index (powerSeq i s) m
  powerSeqPositive {i} 0<i {s} 0<s zero = 0<s
  powerSeqPositive {i} 0<i {s} 0<s (succ m) = <WellDefined reflexive (symmetric (powerSeqInduction i s m)) (orderRespectsMultiplication 0<i (powerSeqPositive 0<i 0<s m))

  powerSeqConvergesTo0 : (i : A) → (0R < i) → (i < 1R) → {s : A} → (0R < s) → (powerSeq i s) ~> 0G
  powerSeqConvergesTo0 i 0<i i<1 {s} 0<s e 0<e = {!!}

  powerSeqConverges : (i : A) → (0R < i) → (i < 1R) → {s : A} → (0R < s) → cauchy (powerSeq i s)
  powerSeqConverges i 0<i i<1 {s} 0<s = convergentSequenceCauchy nontrivial {r = 0R} (powerSeqConvergesTo0 i 0<i i<1 0<s)

  0<n : {n : ℕ} → 1 <N n → 0 <N n
  0<n 1<n = TotalOrder.<Transitive ℕTotalOrder (le 0 refl) 1<n

  digitExpansionBoundedLemma : {n : ℕ} → .(0<n : 0 <N n) → (seq : Sequence (ℤn n 0<n)) → (m : ℕ) → index (digitExpansionSeq _ seq) m < fromN n
  digitExpansionBoundedLemma {n} 0<n seq zero with Sequence.head seq
  ... | record { x = x ; xLess = xLess } = fromNPreservesOrder (0<1 nontrivial) {x} {n} ((squash<N xLess))
  digitExpansionBoundedLemma 0<n seq (succ m) = digitExpansionBoundedLemma 0<n (Sequence.tail seq) m

  digitExpansionBoundedLemma2 : {n : ℕ} → .(0<n : 0 <N n) → (seq : Sequence (ℤn n 0<n)) → (m : ℕ) → inverse (fromN n) < index (digitExpansionSeq 0<n seq) m
  digitExpansionBoundedLemma2 {n} 0<n seq zero = <WellDefined identLeft (transitive (symmetric +Associative) (transitive (+WellDefined reflexive invRight) identRight)) (orderRespectsAddition {_} {fromN (ℤn.x (Sequence.head seq)) + fromN n} (<WellDefined reflexive (fromNPreserves+ (ℤn.x (Sequence.head seq)) n) (fromNPreservesOrder (0<1 nontrivial) {0} {ℤn.x (Sequence.head seq) +N n} (canAddToOneSideOfInequality' _ (squash<N 0<n)))) (inverse (fromN n)))
  digitExpansionBoundedLemma2 0<n seq (succ m) = digitExpansionBoundedLemma2 0<n (Sequence.tail seq) m

  digitExpansionBounded : {n : ℕ} → .(0<n : 0 <N n) → (seq : Sequence (ℤn n 0<n)) → Bounded (digitExpansionSeq 0<n seq)
  digitExpansionBounded {n} 0<n seq = fromN n , λ m → ((digitExpansionBoundedLemma2 0<n seq m) ,, digitExpansionBoundedLemma 0<n seq m)

private
  1/nPositive : (n : ℕ) → 0R < underlying (allInvertible (fromN (succ n)) (charNotN n))
  1/nPositive n with allInvertible (fromN (succ n)) (charNotN n)
  ... | a , b = reciprocalPositive (fromN (succ n)) a (fromNPreservesOrder (0<1 nontrivial) (succIsPositive n)) (transitive *Commutative b)

  1/n<1 : (n : ℕ) → (0 <N n) → underlying (allInvertible (fromN (succ n)) (charNotN n)) < 1R
  1/n<1 n 1<n with allInvertible (fromN (succ n)) (charNotN n)
  ... | a , b = reciprocal<1 (fromN (succ n)) a (<WellDefined identRight reflexive (fromNPreservesOrder (0<1 nontrivial) {1} {succ n} (succPreservesInequality 1<n))) (transitive *Commutative b)

-- Construct the real that is the given base-n expansion between 0 and 1.
ofBaseExpansion : {n : ℕ} → .(1<n : 1 <N n) → (fromN n ∼ 0R → False) → Sequence (ℤn n (0<n 1<n)) → CauchyCompletion
ofBaseExpansion {succ n} 1<n charNotN seq = record { elts = ofBaseExpansionSeq (0<n 1<n) seq ; converges = boundedTimesCauchyIsCauchy (powerSeqConverges _ (1/nPositive n) (1/n<1 n (canRemoveSuccFrom<N (squash<N 1<n))) (1/nPositive n)) (digitExpansionBounded (0<n 1<n) seq)}

toBaseExpansion : {n : ℕ} → .(1<n : 1 <N n) → (fromN n ∼ 0R → False) → (a : CauchyCompletion) → 0R r<C a → a <Cr 1R → Sequence (ℤn n (0<n 1<n))
Sequence.head (toBaseExpansion {n} 1<n charNotN c 0<c c<1) = {!!}
 -- TOOD: approximate c to within 1/n^2, extract the first decimal of the result.
Sequence.tail (toBaseExpansion {n} 1<n charNotN c 0<c c<1) = toBaseExpansion 1<n charNotN {!!} {!!} {!!}

baseExpansionProof : {n : ℕ} → .{1<n : 1 <N n} → {charNotN : fromN n ∼ 0R → False} → (as : CauchyCompletion) → (0<a : 0R r<C as) → (a<1 : as <Cr 1R) → Setoid._∼_ cauchyCompletionSetoid (ofBaseExpansion 1<n charNotN (toBaseExpansion 1<n charNotN as 0<a a<1)) as
baseExpansionProof = {!!}


module Tests where
  open import BasicFunctions
  open import TransportLemmas
  open import EquivalenceType
  open import QuasiinverseType
  open import QuasiinverseLemmas
  open import HLevelTypes
  open import HLevelLemmas
  open import UnivalenceAxiom
  open import CoproductIdentities

  equiv-is-inj
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : Type ℓ₂}
    → (f : A → B) → isEquiv f
    → ∀ {x y : A} → (f x ≡ f y) → x ≡ y

  equiv-is-inj {A = A}{B} f f-is-equiv fx≡fy = ! cr · (ap f^-1 fx≡fy · cr)
    where
    f^-1 : B → A
    f^-1 = remap (f , f-is-equiv)

    cr : ∀ {x : A} → f^-1 (f x) ≡ x
    cr = rlmap-inverse (f , f-is-equiv)

  module _ {ℓ : Level} {A : Type ℓ} where
    equiv-induction
        : (P : (C : Type ℓ) → (A ≃ C) → Type ℓ)
        → P A idEqv
        → (C : Type ℓ)
        → (e : A ≃ C)
        -----------------------------
        → P C e

    equiv-induction P p-refl C e  = tr (P C) (ua-β e) g
      where
      open import HLevelLemmas
      P' :  (C : Type ℓ) → A ≡ C → Type ℓ
      P' C p = P C (idtoeqv p)

      b' : P A (idtoeqv idp)
      b' = tr (P A) (sameEqv idp) p-refl

      f' : (C : Type ℓ) → (p : A ≡ C) → P C (idtoeqv p)
      f' C idp = b'

      g : P C (idtoeqv (ua e))
      g = f' C (ua e)

    postcomp-is-equiv
      : (B : Type ℓ)
      → (e : A ≃ B)
      → ∀ {C : Type ℓ}
      → isEquiv {A = C → A} {B = C → B} (_:> (e ∙→))

    postcomp-is-equiv  B e
      = equiv-induction (λ C A≃C → isEquiv (_:> (A≃C ∙→) )) base-case B e
      where
      base-case : isEquiv (λ f x → π₁ idEqv (f x))
      base-case = π₂ idEqv

    postcomp-≃
      : (B : Type ℓ)
      → (e : A ≃ B)
      → (X : Type ℓ)
      → (X → A) ≃ (X → B)
    postcomp-≃ B e X  = (_:> (e ∙→)) , postcomp-is-equiv B e

    postcomp-is-inj
      : (B : Type ℓ)
      → (e : A ≃ B)
      → {C : Type ℓ}
      → (f g : C → A)
      → f :> (e ∙→) ≡ g :> (e ∙→)
      → f ≡ g

    postcomp-is-inj B e f g p =
      equiv-is-inj (_:> (e ∙→)) (postcomp-is-equiv B e) p

  --  The naive non-dependent function extensionality axiom
  funext'
    : {ℓ : Level} {A : Type ℓ}{B : Type ℓ}
    → (f g : A → B)
    → (h : ∏[ x ∶ A ] (f x ≡ g x))
    → f ≡ g

  funext' {A = A}{B} f g h = ap (_:> p₁) d≡e
    where
    d e : A → ∑[ (x , y ) ∶ (B × B) ] (x ≡ y)
    d = λ x → ((f x , f x)) , refl (f x)
    e = λ x → ((f x , g x)) , h x

    p₀ : ∑[ (x , y ) ∶ (B × B) ] (x ≡ y) → B
    p₀ ((x , y) , p) = x

    p₁ : ∑[ (x , y ) ∶ (B × B) ] (x ≡ y) → B
    p₁ ((x , y) , p) = y

    p₀-is-equiv : isEquiv p₀
    p₀-is-equiv
      = π₂ (qinv-≃ p₀ ((λ x → ((x , x) , (refl x) )) ,
          (λ {p → idp}) , (λ {((x , .x) , idp) → idp})))

    d:>p₀≡e:>p₀ : (d :> p₀) ≡ (e :> p₀)
    d:>p₀≡e:>p₀ = idp

    d≡e : d ≡ e
    d≡e = postcomp-is-inj B (p₀ , p₀-is-equiv) d e d:>p₀≡e:>p₀

  -- naive-funext implies weak extensionality:

  open import FibreType
  open import EquivalenceReasoning

  left-universal-property-of-idenity-type
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → (a x : A)
    → (∑[ p ∶ a ≡ x ] B a) ≃  (∑[ b ∶ B a ] a ≡ x)
  left-universal-property-of-idenity-type a x
    = qinv-≃ f (g , ((λ {(_ , idp) → idp}) , λ { (idp , π₄) → idp}))
    where
    f = λ {(idp , b) → (b , idp)}
    g = λ {(b , p) → (p , b)}

  universal-property-of-identity-type
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → (x : A)
    → B x ≃ (∑[ a ∶ A ] ∑[ p ∶ a ≡ x ] B a)
  universal-property-of-identity-type x = qinv-≃ f (g , (λ { (a , idp , π₄) → idp})  , λ {p → idp})
    where
    f = λ b → (x , (refl x , b))
    g = λ {(a , (idp , b)) → b}

  contr-fibers-gives-pr₁-equiv
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → ((x : A) → isContr (B x)) → (pr₁ {A = A}{B}) is-equiv
  contr-fibers-gives-pr₁-equiv {A = A}{B} Bx-is-contr
    = λ x → equiv-preserves-contr (calculation x) (Bx-is-contr x)
    where
    open import SigmaEquivalence
    open import SigmaPreserves
    open import HLevelLemmas
    calculation : (x : A) → (B x) ≃ fib (pr₁ {A = A}{B}) x
    calculation x =
      begin≃
        B x
          ≃⟨ universal-property-of-identity-type {A = A}{B} x  ⟩
       ∑[ a ∶ A ] (∑[ p ∶ a ≡ x ] B a)
          ≃⟨ sigma-preserves (λ a → left-universal-property-of-idenity-type {A = A}{B} a x) ⟩
       ∑[ a ∶ A ] (∑[ b ∶ B a ] a ≡ x)
         ≃⟨⟩
       ∑[ a ∶ A ] (∑[ b ∶ B a ] (pr₁ {A = A}{B} (a , b) ≡ x) )
         ≃⟨  ∑-assoc ⟩
       (∑[ p ∶ ∑ A B ] (pr₁ p ≡ x))
          ≃⟨⟩
       fib (pr₁ {A = A}{B}) x
        ≃∎

  happly : ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → {f g : ∏ A B}
    → (f ≡ g)
    → (x : A) →  (f x ≡ g x)
  happly idp x = idp

  weak-extensionality pi-is-contr
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    →  ((x : A) → isContr (B x)) → isContr (Π A B)
  weak-extensionality {ℓ₁}{ℓ₂}{A}{B} Bx-is-contr
   = retract-of-singleton Π-is-retract fib-α-id-is-contr
    where
    open import SectionsAndRetractions

    α≃ : ((↑ ℓ₂ A) → ∑ (↑ ℓ₂ A) λ { (Lift a) → B a}) ≃ ((↑ ℓ₂ A) → ↑ ℓ₂ A)
    α≃ = postcomp-≃ (↑ ℓ₂ A)
      (pr₁ , contr-fibers-gives-pr₁-equiv
        (λ { (Lift a) → Bx-is-contr a})) (↑ ℓ₂ A)
    α = α≃ ∙→

    fib-α-id = fib α (id-on (↑ ℓ₂ A))
    fib-α-id-is-contr : isContr (fib-α-id)
    fib-α-id-is-contr = pr₂ α≃ (id-on (↑ ℓ₂ A))

    φ : fib-α-id → Π A B
    φ (g , p) = λ x → tr (λ { (Lift a) → B a}) (happly p (Lift x)) (pr₂ (g (Lift x)))

    ψ : (f : Π A B) → fib-α-id
    ψ f = ((λ {(Lift a) → (Lift a) , f a}) , refl (id-on (↑ ℓ₂ A)))

    Π-is-retract : retract (Π A B) of fib-α-id
    Π-is-retract = (φ , (ψ , λ f → idp))
  pi-is-contr = weak-extensionality

  funext
    : {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → (f g : ∏ A B)
    → (h : ∏[ x ∶ A ] (f x ≡ g x))
    → f ≡ g

  funext {ℓ₁}{ℓ₂}{A}{B} f g h = ap (_!-inv) p
    where
    hat : (∏ A B) → (↑ ℓ₂ A) → ∑ A B
    hat f (Lift a) = (a , f a)

    hat-f≡hat-g : (hat f) ≡ (hat g)
    hat-f≡hat-g = funext' (hat f) (hat g) (λ { (Lift a) → pair= (idp , h a)})

    _! : ∏ A B → ∑[ h ∶ ((↑ ℓ₂ A) → ∑ A B) ] (∏[ x ∶ (↑ ℓ₂ A) ] (π₁ (h x) ≡ lower x) )
    f ! = ( hat f , λ { (Lift a) → refl a})

    _!-inv : ∑[ h ∶ ((↑ ℓ₂ A) → ∑ A B) ] (∏[ x ∶ (↑ ℓ₂ A) ] (π₁ (h x) ≡ (lower x)) ) → ∏ A B
    _!-inv (h , p) = λ x → tr B (p (Lift x)) (π₂ (h (Lift x)))

    -- see that, the round trip gives.
    _ : ((f !) !-inv)  ≡ f
    _ = idp

    p : (f !) ≡ (g !)
    p = pair= (hat-f≡hat-g , q)
      where
      open import HLevelLemmas
      q : PathOver (λ h₁ → ∏ (↑ ℓ₂ A) (λ x → π₁ (h₁ x) ≡ lower x))
                    (π₂ (f !)) hat-f≡hat-g (π₂ (g !))
      q = contr-is-prop  (weak-extensionality (λ {(Lift a) → idp , λ { idp → idp}}))
        (tr (λ h → ∏ (↑ ℓ₂ A) λ x → π₁ (h x) ≡ lower x) hat-f≡hat-g (π₂ (f !))) (π₂ (g !))

  fiberwise-transformation fiberwise-map-from_to_
    : ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}
    → (P Q : A → Type ℓ₂)
    → Type (ℓ₁ ⊔ ℓ₂)
  fiberwise-transformation P Q = ∏[ x ] (P x → Q x)
  fiberwise-map-from_to_ = fiberwise-transformation

  total
    : ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{P Q : A → Type ℓ₂}
    → (f : fiberwise-map-from P to Q)
    → ((∑ A P) → (∑ A Q))
  total f (a , p) = ( a , f a p)

  fib-total-≃fib-fiberwise
    : ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{P Q : A → Type ℓ₂}
    → (f : fiberwise-map-from P to Q)
    → (x : A) (v : Q x)
    → fib (total f) (( x , v)) ≃ fib (f x) v

  fib-total-≃fib-fiberwise {P = P}{Q} f x v =
    qinv-≃ f' (g' , (λ {(p , idp) → idp}) , λ { (a , idp) → idp})
    where
    private
      f' = λ { ((a , p) , idp) → (p , idp)}
      g' = λ { (p , idp) → ( (x , p) , idp)}

  fib-total-equiv-from-fiberwise-equiv
    :  ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{P Q : A → Type ℓ₂}
    → (f : fiberwise-map-from P to Q)
    → ((x : A) → (f x) is-equiv)  -- this says f is fiberwise equivalence.
    →  ((total f) is-equiv)
  fib-total-equiv-from-fiberwise-equiv f f-fiberwise-equiv
    = λ x → equiv-preserves-contr
                    (≃-sym (fib-total-≃fib-fiberwise f (π₁ x) (π₂ x)))
                    (f-fiberwise-equiv (π₁ x) (π₂ x))

  fib-total-equiv-to-fiberwise-equiv
    :  ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{P Q : A → Type ℓ₂}
    → (f : fiberwise-map-from P to Q)
    → ((total f) is-equiv)
    → ((x : A) → (f x) is-equiv)
  fib-total-equiv-to-fiberwise-equiv f total-is-equiv
    = λ x → λ p → equiv-preserves-contr (fib-total-≃fib-fiberwise f x p) (total-is-equiv ((x , p)))

  happly-is-equiv
    :  ∀ {ℓ₁ ℓ₂ : Level} {A : Type ℓ₁}{B : A → Type ℓ₂}
    → {f g : ∏ A B}
    → (happly {f = f} {g}) is-equiv

  happly-is-equiv {A = A}{B}{f = f}{g} h
    = fib-total-equiv-to-fiberwise-equiv s total-happly-is-equiv g h
    where
    open import SigmaEquivalence
    calculation
      : (∏[ x ∶ A ] (∑[ u ∶ B x ] (f x ≡ u)))
      ≃ (∑[ g ∶ ∏ A B ] (∏[ x ∶ A ] (f x ≡ g x)))
    calculation = choice

    α-codomain-is-contr : isContr ((∑[ g ∶ ∏ A B ] (∏[ x ∶ A ] (f x ≡ g x))))
    α-codomain-is-contr
     = equiv-preserves-contr
         choice
         (pi-is-contr (λ x → pathfrom-is-contr _ _))

    s : (g : (∏ A B)) → (f ≡ g) → (∏[ x ∶ A ] (f x ≡ g x))
    s g p = happly p

    α : (∑[ g ∶ (∏ A B) ] (f ≡ g)) → (∑[ g ∶  ∏ A B ] ∏[ x ∶ A ] (f x ≡ g x))
    α (g , p) = (g , happly p)

    total-happly-is-equiv : α is-equiv
    total-happly-is-equiv (g , p) =
      map-domain-and-codomain-contr-is-equiv
        α-domain-is-contr
        α-codomain-is-contr _ _
      where
      open import SectionsAndRetractions
      α-domain-is-contr : isContr (domain α)
      α-domain-is-contr = pathfrom-is-contr _ _

      map-domain-and-codomain-contr-is-equiv : ∀ {ℓ₁ ℓ₂ : Level}{X : Type ℓ₁}{Y : Type ℓ₂}
        → X is-contr
        → Y is-contr
        → (f : X → Y)
        → f is-equiv
      map-domain-and-codomain-contr-is-equiv {X = X}{Y} X-is-contr Y-is-contr f
        = λ y → ((center-of X-is-contr , contr-is-prop Y-is-contr _ _))
          , λ x → pair= (contr-is-prop X-is-contr _ _ ,
          prop-is-set (contr-is-prop Y-is-contr) _ _ _ _)


-- NB. This test fail if Agda is called with the --no-sharing option.

module Issue1351 where

open import Common.Equality
open import Common.Prelude

f1 : Nat → Nat
f1 x = x + x

f2 : Nat → Nat
f2 x = f1 (f1 x)

f4 : Nat → Nat
f4 x = f2 (f2 x)

f8 : Nat → Nat
f8 x = f4 (f4 x)

f16 : Nat → Nat
f16 x = f8 (f8 x)

f32 : Nat → Nat
f32 x = f16 (f16 x)

thm : f32 1 ≡ 4294967296
thm = refl


{-# OPTIONS --rewriting #-}

-- Normalization by Evaluation for Call-By-Push-Value

module NfCBPV where

-- Imports from the Agda standard library.

open import Library hiding (_×̇_)

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

pattern here! = here refl

-- We postulate a set of generic value types.
-- There are no operations defined on these types, thus,
-- they play the type of (universal) type variables.

postulate Base : Set

-- Variants (Σ) (and records (Π), resp.) can in principle have any number of
-- constructors (fields, resp.), including infinitely one.
-- In general, the constructor (field, resp.) names are given by a set I.
-- However, I : Set would make syntax already a big type, living in Set₁.
-- To keep it in Set₀, we only consider variants (records) with finitely
-- many constructors (fields), thus, I : ℕ.
-- Branching over I is then realized as functions out of El I, where
-- El I = { i | i < I} = Fin I.

set = ℕ
El  = Fin

-- Let I range over arities (constructor/field sets) and i over
-- constructor/field names.

variable
  I : set
  i : El I

-- The types of CBPV are classified into value types P : Ty⁺ which we
-- refer to as positive types, and computation types N : Ty⁻ which we
-- refer to as negative types.

mutual

  -- Value types

  data Ty⁺ : Set where
    base  : (o : Base) → Ty⁺                   -- Base type.
    _×̇_   : (P₁ P₂ : Ty⁺) → Ty⁺                -- Finite product (tensor).
    Σ̇     : (I : set) (Ps : El I → Ty⁺) → Ty⁺  -- Variant (sum).
    □̇     : (N : Ty⁻) → Ty⁺                    -- Thunk (U).

  -- Computation types

  data Ty⁻ : Set where
    ◇̇    : (P : Ty⁺) → Ty⁻                     -- Comp (F).
    Π̇    : (I : set) (Ns : El I → Ty⁻) → Ty⁻   -- Record (lazy product).
    _⇒̇_  : (P : Ty⁺) (N : Ty⁻) → Ty⁻           -- Function type.

-- In CBPV, a variable stands for a value.
-- Thus, environments only contain values,
-- and typing contexts only value types.

-- We use introduce syntax in an intrinsically well-typed way
-- with variables being de Bruijn indices into the typing context.
-- Thus, contexts are just lists of types.

Cxt = List Ty⁺

variable
  Γ Δ Φ            : Cxt
  P P₁ P₂ P' P′ Q  : Ty⁺
  N N₁ N₂ N' N′    : Ty⁻
  Ps               : El I → Ty⁺
  Ns               : El I → Ty⁻

-- Generic values

module _ (Var : Ty⁺ → Cxt → Set) (Comp : Ty⁻ → Cxt → Set) where

  -- Right non-invertible

  data Val' : (P : Ty⁺) (Γ : Cxt) → Set where
    var    : ∀{Γ P}      (x : Var P Γ)                      → Val' P Γ
    pair   : ∀{Γ P₁ P₂}  (v₁ : Val' P₁ Γ) (v₂ : Val' P₂ Γ)  → Val' (P₁ ×̇ P₂) Γ
    inj    : ∀{Γ I P} i  (v : Val' (P i) Γ)                 → Val' (Σ̇ I P) Γ
    thunk  : ∀{Γ N}      (t : Comp N Γ)                     → Val' (□̇ N) Γ

-- Terms

mutual

  Val = Val' _∈_ Comp

  data Comp : (N : Ty⁻) (Γ : Cxt) → Set where
    -- introductions
    ret    : ∀{Γ P}        (v : Val P Γ)             → Comp (◇̇ P) Γ
    rec    : ∀{Γ I N}      (t : ∀ i → Comp (N i) Γ)  → Comp (Π̇ I N) Γ
    abs    : ∀{Γ P N}      (t : Comp N (P ∷ Γ))      → Comp (P ⇒̇ N) Γ
    -- positive eliminations
    split  : ∀{Γ P₁ P₂ N}  (v : Val (P₁ ×̇ P₂) Γ)  (t : Comp N (P₂ ∷ P₁ ∷ Γ))     → Comp N Γ
    case   : ∀{Γ I Ps N}   (v : Val (Σ̇ I Ps) Γ)   (t : ∀ i → Comp N (Ps i ∷ Γ))  → Comp N Γ
    bind   : ∀{Γ P N}      (u : Comp (◇̇ P) Γ)     (t : Comp N (P ∷ Γ))           → Comp N Γ
    -- cut
    letv   : ∀{Γ P N}      (v : Val P Γ)          (t : Comp N (P ∷ Γ))           → Comp N Γ
    -- negative eliminations
    force  : ∀{Γ N}        (v : Val (□̇ N) Γ)                     → Comp N Γ
    prj    : ∀{Γ I Ns} i   (t : Comp (Π̇ I Ns) Γ)                 → Comp (Ns i) Γ
    app    : ∀{Γ P N}      (t : Comp (P ⇒̇ N) Γ)   (v : Val P Γ)  → Comp N Γ

-- Normal forms
------------------------------------------------------------------------

-- Normal values only reference variables of base type

NVar : (P : Ty⁺) (Γ : Cxt) → Set
NVar (base o) Γ = base o ∈ Γ
NVar _ _ = ⊥

-- Negative neutrals

module _ (Val : Ty⁺ → Cxt → Set) where

  -- Right non-invertible

  data Ne' : (N : Ty⁻) (Γ : Cxt) → Set where
    force  : ∀{Γ N}      (x : □̇ N ∈ Γ)                      → Ne' N Γ
    prj    : ∀{Γ I N} i  (t : Ne' (Π̇ I N) Γ)                → Ne' (N i) Γ
    app    : ∀{Γ P N}    (t : Ne' (P ⇒̇ N) Γ) (v : Val P Γ)  → Ne' N Γ

mutual

  NVal = Val' NVar Nf
  Ne   = Ne' NVal

  -- Cover monad

  data ◇ (J : Cxt → Set) (Γ : Cxt) : Set where
    return  : (j : J Γ)                                                  → ◇ J Γ
    bind    : ∀{P}      (u : Ne (◇̇ P) Γ)     (t :          ◇ J (P ∷ Γ))  → ◇ J Γ
    case    : ∀{I Ps}   (x : Σ̇ I Ps ∈ Γ)     (t : ∀ i → ◇ J (Ps i ∷ Γ))  → ◇ J Γ
    split   : ∀{P₁ P₂}  (x : (P₁ ×̇ P₂) ∈ Γ)  (t :    ◇ J (P₂ ∷ P₁ ∷ Γ))  → ◇ J Γ

  data NComp (Q : Ty⁺) (Γ : Cxt) : Set where
    ret    :           (v : NVal Q Γ)    → NComp Q Γ   -- Invoke RFoc
    ne     :           (n : Ne (◇̇ Q) Γ)  → NComp Q Γ   -- Finish with LFoc
      -- e.g. app (force f) x

    -- Use lemma LFoc
    bind   : ∀{P}      (u : Ne (◇̇ P) Γ)     (t : NComp Q (P ∷ Γ))           → NComp Q Γ

    -- Left invertible
    split  : ∀{P₁ P₂}  (x : (P₁ ×̇ P₂) ∈ Γ)  (t :    NComp Q (P₂ ∷ P₁ ∷ Γ))  → NComp Q Γ
    case   : ∀{I Ps}   (x : Σ̇ I Ps    ∈ Γ)  (t : ∀ i → NComp Q (Ps i ∷ Γ))  → NComp Q Γ

  -- Right invertible

  data Nf : (N : Ty⁻) (Γ : Cxt) → Set where
    ret   : ∀{Γ P}    (v : ◇ (NVal P) Γ)      → Nf (◇̇ P) Γ   -- Invoke RFoc
    ne    : ∀{Γ o}    (let N = ◇̇ (base o))
                      (n : ◇ (Ne N) Γ)        → Nf N Γ
    -- comp  : ∀{Γ P}   (t : NComp P Γ)        → Nf (◇̇ P) Γ
    rec   : ∀{Γ I N}  (t : ∀ i → Nf (N i) Γ)  → Nf (Π̇ I N) Γ
    abs   : ∀{Γ P N}  (t : Nf N (P ∷ Γ))      → Nf (P ⇒̇ N) Γ

-- Context-indexed sets
------------------------------------------------------------------------

ISet = (Γ : Cxt) → Set

variable
  A B C : ISet
  F G   : (i : El I) → ISet

-- Constructions on ISet

1̂ : ISet
1̂ Γ = ⊤

_×̂_ : (A B : ISet) → ISet
(A ×̂ B) Γ = A Γ × B Γ

Σ̂ : (I : set) (F : El I → ISet) → ISet
(Σ̂ I F) Γ = ∃ λ i → F i Γ

_⇒̂_ : (A B : ISet) → ISet
(A ⇒̂ B) Γ = A Γ → B Γ

Π̂ : (I : set) (F : El I → ISet) → ISet
(Π̂ I F) Γ = ∀ i → F i Γ

⟨_⟩ : (P : Ty⁺) (A : ISet) → ISet
⟨ P ⟩ A Γ = A (P ∷ Γ)

-- Morphisms between ISets

_→̇_ : (A B : Cxt → Set) → Set
A →̇ B = ∀{Γ} → A Γ → B Γ

⟨_⊙_⟩→̇_ : (P Q R : Cxt → Set) → Set
⟨ P ⊙ Q ⟩→̇ R = ∀{Γ} → P Γ → Q Γ → R Γ

⟨_⊙_⊙_⟩→̇_ : (P Q R S : Cxt → Set) → Set
⟨ P ⊙ Q ⊙ R ⟩→̇ S = ∀{Γ} → P Γ → Q Γ → R Γ → S Γ

Map : (F : (Cxt → Set) → Cxt → Set) → Set₁
Map F = ∀{A B : Cxt → Set} (f : A →̇ B) → F A →̇ F B

Π-map : (∀ i → F i →̇ G i) → Π̂ I F →̇ Π̂ I G
Π-map f r i = f i (r i)

-- -- Introductions and eliminations for ×̂

-- p̂air : ⟨ A ⊙ B ⟩→̇ (A ×̂ B)
-- p̂air a b = λ

-- Monotonicity
------------------------------------------------------------------------

-- Monotonization □ is a monoidal comonad

□ : (A : Cxt → Set) → Cxt → Set
□ A Γ = ∀{Δ} (τ : Γ ⊆ Δ) → A Δ

extract : □ A →̇ A
extract a = a ⊆-refl

duplicate : □ A →̇ □ (□ A)
duplicate a τ τ′ = a (⊆-trans τ τ′)

□-map : Map □
□-map f a τ = f (a τ)

extend : (□ A →̇ B) → □ A →̇ □ B
extend f = □-map f ∘ duplicate

□-weak : □ A →̇ ⟨ P ⟩ (□ A)
□-weak a τ = a (⊆-trans (_ ∷ʳ ⊆-refl) τ)

□-weak' : □ A →̇ □ (⟨ P ⟩ A)
□-weak' a τ = a (_ ∷ʳ τ)

□-sum : Σ̂ I (□ ∘ F) →̇ □ (Σ̂ I F)
□-sum (i , a) τ = i , a τ

-- Monoidality:

□-unit : 1̂ →̇ □ 1̂
□-unit = _

□-pair : ⟨ □ A ⊙ □ B ⟩→̇ □ (A ×̂ B)
□-pair a b τ = (a τ , b τ)

-- Strong functoriality

Map! : (F : (Cxt → Set) → Cxt → Set) → Set₁
Map! F = ∀{A B : Cxt → Set} → ⟨ □ (A ⇒̂ B) ⊙ F A ⟩→̇ F B

-- Monotonicity

Mon : (A : Cxt → Set) → Set
Mon A = A →̇ □ A

monVar : Mon (P ∈_)
monVar x τ = ⊆-lookup τ x

-- Positive ISets are monotone

□-mon : Mon (□ A)
□-mon = duplicate

1-mon : Mon 1̂
1-mon = □-unit

×-mon : Mon A → Mon B → Mon (A ×̂ B)
×-mon mA mB (a , b) = □-pair (mA a) (mB b)

Σ-mon : ((i : El I) → Mon (F i)) → Mon (Σ̂ I F)
Σ-mon m (i , a) = □-sum (i , m i a)

□-intro : Mon A → (A →̇ B) → (A →̇ □ B)
□-intro mA f = □-map f ∘ mA

-- Cover monad: a strong monad
------------------------------------------------------------------------

join : ◇ (◇ A) →̇ ◇ A
join (return c)  = c
join (bind u c)  = bind u (join c)
join (case x t)  = case x (join ∘ t)
join (split x c) = split x (join c)

◇-map : Map ◇
◇-map f (return  j) = return  (f j)
◇-map f (bind  u a) = bind  u (◇-map f a)
◇-map f (case  x t) = case  x (λ i → ◇-map f (t i))
◇-map f (split x a) = split x (◇-map f a)

◇-map! : Map! ◇
◇-map! f (return  j) = return  (extract f j)
◇-map! f (bind  u a) = bind  u (◇-map! (□-weak f) a)
◇-map! f (case  x t) = case  x (λ i → ◇-map! (□-weak f) (t i))
◇-map! f (split x a) = split x (◇-map! (□-weak (□-weak f)) a)

◇-bind : A →̇ ◇ B → ◇ A →̇ ◇ B
◇-bind f = join ∘ ◇-map f

◇-record : ◇ (Π̂ I F) →̇ Π̂ I (◇ ∘ F)
◇-record c i = ◇-map (_$ i) c

◇-fun : Mon A → ◇ (A ⇒̂ B) →̇ (A ⇒̂ ◇ B)
◇-fun mA c a = ◇-map! (λ τ f → f (mA a τ)) c

-- Monoidal functoriality

-- ◇-pair : ⟨ ◇ A ⊙ ◇ B ⟩→̇ ◇ (A ×̂ B)  -- does not hold!

◇-pair : ⟨ □ (◇ A) ⊙ ◇ (□ B) ⟩→̇ ◇ (A ×̂ B)
◇-pair ca = join ∘ ◇-map! λ τ b → ◇-map! (λ τ′ a → a , b τ′) (ca τ)

_⋉_ = ◇-pair

□◇-pair' : ⟨ □ (◇ A) ⊙ □ (◇ (□ B)) ⟩→̇ □ (◇ (A ×̂ B))
□◇-pair' ca cb τ = ◇-pair (□-mon ca τ) (cb τ)

□◇-pair : Mon B → ⟨ □ (◇ A) ⊙ □ (◇ B) ⟩→̇ □ (◇ (A ×̂ B))
□◇-pair mB ca cb τ = join $
  ◇-map! (λ τ₁ b → ◇-map! (λ τ₂ a → a , mB b τ₂) (ca (⊆-trans τ τ₁))) (cb τ)

◇□-pair' : ⟨ ◇ (□ A) ⊙ □ (◇ (□ B)) ⟩→̇ ◇ (□ (A ×̂ B))
◇□-pair' ca cb = join (◇-map! (λ τ a → ◇-map! (λ τ₁ b τ₂ → a (⊆-trans τ₁ τ₂) , b τ₂) (cb τ)) ca)

◇□-pair : ⟨ □ (◇ (□ A)) ⊙ ◇ (□ B) ⟩→̇ ◇ (□ (A ×̂ B))
◇□-pair ca cb = join (◇-map! (λ τ b → ◇-map! (λ τ₁ a τ₂ → a τ₂ , b (⊆-trans τ₁ τ₂)) (ca τ)) cb)

-- Runnability

Run : (A : Cxt → Set) → Set
Run A = ◇ A →̇ A

-- Negative ISets are runnable

◇-run : Run (◇ A)
◇-run = join

Π-run : (∀ i → Run (F i)) → Run (Π̂ I F)
Π-run f = Π-map f ∘ ◇-record

⇒-run : Mon A → Run B → Run (A ⇒̂ B)
⇒-run mA rB f = rB ∘ ◇-fun mA f

-- Bind for the ◇ monad

◇-elim : Run B → (A →̇ B) → ◇ A →̇ B
◇-elim rB f = rB ∘ ◇-map f

◇-elim! : Run B → ⟨ □ (A ⇒̂ B) ⊙ ◇ A ⟩→̇ B
◇-elim! rB f = rB ∘ ◇-map! f

◇-elim-□ : Run B → ⟨ □ (A ⇒̂ B) ⊙ □ (◇ A) ⟩→̇ □ B
◇-elim-□ rB f c = □-map (uncurry (◇-elim! rB)) (□-pair (□-mon f) c)

◇-elim-□-alt : Run B → ⟨ □ (A ⇒̂ B) ⊙ □ (◇ A) ⟩→̇ □ B
◇-elim-□-alt rB f c τ = ◇-elim! rB (□-mon f τ) (c τ)

bind! : Mon C → Run B → (C →̇ ◇ A) → (C →̇ (A ⇒̂ B)) → C →̇ B
bind! mC rB f k γ = ◇-elim! rB (λ τ a → k (mC γ τ) a) (f γ)

-- Type interpretation
------------------------------------------------------------------------

mutual
  ⟦_⟧⁺ : Ty⁺ → ISet
  ⟦ base o  ⟧⁺ = base o ∈_
  ⟦ P₁ ×̇ P₂ ⟧⁺ = ⟦ P₁ ⟧⁺ ×̂ ⟦ P₂ ⟧⁺
  ⟦ Σ̇ I P   ⟧⁺ = Σ̂ I λ i → ⟦ P i ⟧⁺
  ⟦ □̇ N     ⟧⁺ = □ ⟦ N ⟧⁻

  ⟦_⟧⁻ : Ty⁻ → ISet
  ⟦ ◇̇ P   ⟧⁻ = ◇ ⟦ P ⟧⁺
  ⟦ Π̇ I N ⟧⁻ = Π̂ I λ i → ⟦ N i ⟧⁻
  ⟦ P ⇒̇ N ⟧⁻ = ⟦ P ⟧⁺ ⇒̂ ⟦ N ⟧⁻

⟦_⟧ᶜ : Cxt → ISet
⟦_⟧ᶜ Γ Δ = All (λ P → ⟦ P ⟧⁺ Δ) Γ

-- ⟦ []    ⟧ᶜ = 1̂
-- ⟦ P ∷ Γ ⟧ᶜ = ⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺

-- Positive types are monotone.

mon⁺ : (P : Ty⁺) → Mon ⟦ P ⟧⁺
mon⁺ (base o)  = monVar
mon⁺ (P₁ ×̇ P₂) = ×-mon (mon⁺ P₁) (mon⁺ P₂)
mon⁺ (Σ̇ I P)   = Σ-mon (mon⁺ ∘ P)
mon⁺ (□̇ N)     = □-mon

monᶜ : (Γ : Cxt) → Mon ⟦ Γ ⟧ᶜ
monᶜ Γ γ τ = All.map (λ {P} v → mon⁺ P v τ) γ

-- Negative types are runnable.

run⁻ : (N : Ty⁻) → Run ⟦ N ⟧⁻
run⁻ (◇̇ P)   = ◇-run
run⁻ (Π̇ I N) = Π-run (run⁻ ∘ N)
run⁻ (P ⇒̇ N) = ⇒-run (mon⁺ P) (run⁻ N)

-- monᶜ []      = 1-mon
-- monᶜ (P ∷ Γ) = ×-mon (monᶜ Γ) (mon⁺ P)

-- Interpretation
------------------------------------------------------------------------

mutual

  ⦅_⦆⁺ : Val P Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⟧⁺
  ⦅ var x ⦆⁺      = λ γ → All.lookup γ x
  ⦅ pair v₁ v₂ ⦆⁺ = < ⦅ v₁ ⦆⁺ , ⦅ v₂ ⦆⁺ >
  ⦅ inj i v ⦆⁺    = (i ,_) ∘ ⦅ v ⦆⁺
  ⦅ thunk t ⦆⁺    = □-intro (monᶜ _) ⦅ t ⦆⁻

  λ⦅_⦆⁻ : Comp N (P ∷ Γ) → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⇒̇ N ⟧⁻
  λ⦅ t ⦆⁻ γ a = ⦅ t ⦆⁻ (a ∷ γ)

  ⦅_⦆⁻ : Comp N Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ N ⟧⁻
  ⦅ ret v ⦆⁻ = return ∘ ⦅ v ⦆⁺
  ⦅ rec t ⦆⁻ = flip λ i → ⦅ t i ⦆⁻
  ⦅ abs t ⦆⁻ = λ⦅ t ⦆⁻
  ⦅ split v t ⦆⁻ γ = let (a₁ , a₂) = ⦅ v ⦆⁺ γ in ⦅ t ⦆⁻ (a₂ ∷ (a₁ ∷ γ))
  ⦅ case v t ⦆⁻  γ = let (i , a) = ⦅ v ⦆⁺ γ in  ⦅ t i ⦆⁻ (a ∷ γ)
  ⦅ bind {Γ = Γ} {N = N} t t₁ ⦆⁻ = bind! (monᶜ Γ) (run⁻ N) ⦅ t ⦆⁻ λ⦅ t₁ ⦆⁻
  ⦅ force v ⦆⁻  = extract ∘ ⦅ v ⦆⁺
  ⦅ prj i t ⦆⁻  = (_$ i) ∘ ⦅ t ⦆⁻
  ⦅ app t v ⦆⁻  = ⦅ t ⦆⁻  ˢ ⦅ v ⦆⁺
  ⦅ letv v t ⦆⁻ = λ⦅ t ⦆⁻ ˢ ⦅ v ⦆⁺

-- Reflection and reification

mutual

  fresh□◇□ : ∀ P {Γ} → ⟨ P ⟩ (□ (◇ (□ ⟦ P ⟧⁺))) Γ
  fresh□◇□ P = reflect⁺□ P ∘ monVar here!

  fresh□ : ∀ P {Γ} → ⟨ P ⟩ (□ (◇ ⟦ P ⟧⁺)) Γ
  fresh□ P = ◇-map extract ∘ reflect⁺□ P ∘ monVar here!
  fresh□ P = reflect⁺ P ∘ monVar here!

  fresh : ∀ {P Γ} → ⟨ P ⟩ (◇ ⟦ P ⟧⁺) Γ
  fresh {P} = ◇-map extract (reflect⁺□ P here!)
  fresh {P} = reflect⁺ P here!

  fresh◇ : ∀ {P Γ} → ⟨ P ⟩ (◇ (□ ⟦ P ⟧⁺)) Γ
  fresh◇ {P} = reflect⁺□ P here!
  fresh◇ {P} = ◇-map (mon⁺ P) fresh

  -- saves us use of Mon P in freshᶜ
  reflect⁺□ : (P : Ty⁺) → (P ∈_) →̇ (◇ (□ ⟦ P ⟧⁺))
  reflect⁺□ (base o)  x = return (monVar x)
  reflect⁺□ (P₁ ×̇ P₂) x = split x (◇□-pair (reflect⁺□ P₁ ∘ monVar (there here!)) fresh◇)
  reflect⁺□ (Σ̇ I Ps)  x = case x λ i → ◇-map (□-map (i ,_)) fresh◇
  reflect⁺□ (□̇ N)     x = return (□-mon (reflect⁻ N ∘ force ∘ monVar x))

  reflect⁺ : (P : Ty⁺) → (P ∈_) →̇ (◇ ⟦ P ⟧⁺)
  reflect⁺ (base o)  x = return x
  reflect⁺ (P₁ ×̇ P₂) x = split x (□-weak (fresh□ P₁) ⋉ fresh◇)
  reflect⁺ (Σ̇ I Ps)  x = case x λ i → ◇-map (i ,_) fresh
  reflect⁺ (□̇ N)     x = return λ τ → reflect⁻ N (force (monVar x τ))

  reflect⁻ : (N : Ty⁻) → Ne N →̇ ⟦ N ⟧⁻
  reflect⁻ (◇̇ P)    u = bind u fresh
  reflect⁻ (Π̇ I Ns) u = λ i → reflect⁻ (Ns i) (prj i u)
  reflect⁻ (P ⇒̇ N)  u = λ a → reflect⁻ N (app u (reify⁺ P a))

  reify⁺ : (P : Ty⁺) → ⟦ P ⟧⁺ →̇ NVal P
  reify⁺ (base o) = var
  reify⁺ (P₁ ×̇ P₂) (a₁ , a₂) = pair (reify⁺ P₁ a₁) (reify⁺ P₂ a₂)
  reify⁺ (Σ̇ I Ps)  (i  , a ) = inj i (reify⁺ (Ps i) a)
  reify⁺ (□̇ N) a = thunk (reify⁻ N a)

  reify⁻ : (N : Ty⁻) → □ ⟦ N ⟧⁻ →̇ Nf N
  reify⁻ (◇̇ P)    f = ret (◇-map (reify⁺ P) (extract f))
  reify⁻ (Π̇ I Ns) f = rec λ i → reify⁻ (Ns i) (□-map (_$ i) f)
  reify⁻ (P ⇒̇ N)  f = abs $ reify⁻ N $ ◇-elim-□ (run⁻ N) (□-weak f) $ fresh□ P

ext : (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ⟦ P ∷ Γ ⟧ᶜ
ext (γ , a) = a ∷ γ

◇-ext : ◇ (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ◇ ⟦ P ∷ Γ ⟧ᶜ
◇-ext = ◇-map ext

-- Without the use of ◇-mon!

freshᶜ : (Γ : Cxt) → □ (◇ ⟦ Γ ⟧ᶜ) Γ
freshᶜ []      = λ τ → return []
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (fresh□◇□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair (mon⁺ P) (□-weak (freshᶜ Γ)) (fresh□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (◇-map (mon⁺ P) ∘ (fresh□ P))
freshᶜ (P ∷ Γ) = ◇-ext ∘ λ τ →
  (□-weak (□-mon (freshᶜ Γ)) τ)
  ⋉ ◇-map (mon⁺ P) (fresh□ P τ)

norm : Comp N →̇ Nf N
norm {N = N} {Γ = Γ} t = reify⁻ N $ □-map (run⁻ N ∘ ◇-map ⦅ t ⦆⁻) $ freshᶜ Γ
norm {N = N} {Γ = Γ} t = reify⁻ N $ run⁻ N ∘ ◇-map ⦅ t ⦆⁻ ∘ freshᶜ Γ

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


-----------------------------------------------------------------------
-- This file defines DC₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module DC2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , α)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

-----------------------------------------------------------------------
-- DC₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , (X × Y) , α ⊗ᵣ β)

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

-- The unit for tensor:
ι : ⊤ → ⊤ → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : Σ ⊤ (λ x → U)} {y : X} → (ι ⊗ᵣ α) u (triv , y) → α (snd u) y
λ⊗-p {U}{X}{α}{(triv , u)}{x} = snd

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ _ x → triv , x) , λ⊗-p

λ⊗-inv : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⊗-inv {(U , X , α)} = (λ u → triv , u) , (λ _ r → snd r) , λ⊗-inv-p
 where
  λ⊗-inv-p : ∀{U X α}{u : U} {y : Σ ⊤ (λ x → X)} → α u (snd y) → (ι ⊗ᵣ α) (triv , u) y
  λ⊗-inv-p {U}{X}{α}{u}{triv , x} p = triv , p

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ r x → x , triv) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : Σ U (λ x → ⊤)} {y : X} → (α ⊗ᵣ ι) u (y , triv) → α (fst u) y
  ρ⊗-p {U}{X}{α}{(u , _)}{x} (p , _) = p

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ u → u , triv) , (λ u r → fst r) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ X (λ x → ⊤)} → α u (fst y) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{x , triv} p = p , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , (λ r₁ r₂ → twist-× r₂) , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β}{u : Σ U (λ x → V)} {y : Σ Y (λ x → X)} → (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{u , v}{y , x} = twist-×

-- The associator:
Fα-inv : ∀{ℓ}{U V W X Y Z : Set ℓ} → (U × (V × W)) → ((X × Y) × Z) → (X × (Y × Z))
Fα-inv (u , (v , w)) ((x , y) , z) = x , y , z

α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   α-inv-cond : {u : Σ U (λ x → Σ V (λ x₁ → W))}{y : Σ (Σ X (λ x → Y)) (λ x → Z)}
     → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv u y)
     → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {u , (v , w)}{(x , y) , z} (p₁ , (p₂ , p₃)) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U Z : Set} → ((U × V) × W) → (X × (Y × Z)) → ((X × Y) × Z)
Fα {V}{W}{X}{Y}{U}{Z} ((u , v) , w) (x , (y , z)) = (x , y) , z

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}
      {y : Σ X (λ x → Σ Y (λ x₁ → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα u y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{x , (y , z)} ((p₁ , p₂) , p₃) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (Σ U (λ x → V)) (λ x → W)} → (λ z → Fα {V}{W}{X}{Y}{U}{Z} a (Fα-inv (lr-assoc-× a) z)) ≡ (λ y → y)
   aux' {(u , v), w} = ext-set aux''
    where
      aux'' : {a : Σ (Σ X (λ x → Y)) (λ x → Z)} → Fα ((u , v) , w) (Fα-inv (u , v , w) a) ≡ a
      aux'' {(x , y) , z} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a : Σ U (λ x → Σ V (λ x₁ → W))} → (λ z → Fα-inv {_}{U}{V}{W}{X}{Y}{Z} a (Fα (rl-assoc-× a) z)) ≡ (λ y → y)
   aux' {u , (v , w)} = ext-set aux''
    where
      aux'' : {a : Σ X (λ x → Σ Y (λ x₁ → Z))} → Fα-inv (u , v , w) (Fα ((u , v) , w) a) ≡ a
      aux'' {x , (y , z)} = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set}{α : U → X → Set}{β : V → Y → Set}
  → Σ (U → V) (λ x → U → Y → X)
  → Σ U (λ x → Y)
  → Set
⊸-cond {α = α}{β} (f , F) (u , y) = α u (F u y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (U → Y → X)) , ((U × Y) , ⊸-cond {α = α}{β})

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , cond
 where
  h : Σ (U → V) (λ x → U → Y → X) → Σ (W → S) (λ x → W → T → Z)
  h (i , I) = (λ w → g (i (f w))) , (λ w t → F w (I (f w) (G (i (f w)) t)))
  H : Σ (U → V) (λ x → U → Y → X) → Σ W (λ x → T) → Σ U (λ x → Y)
  H (i , I) (w , t) = f w , G (i (f w)) t
  cond : {u : Σ (U → V) (λ x → U → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond {α = α}{β} u (H u y) → ⊸-cond {α = γ}{δ} (h u) y
  cond {i , I}{w , y} p₃ p₄ = p₂ (p₃ (p₁ p₄))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) , (λ u r → fst (F (u , (fst r)) (snd r))) , cond
 where
   cond : {u : U} {y : Σ V (λ x → Z)}
     → α u (fst (F (u , fst y) (snd y)))
     → ⊸-cond {α = β}{γ} ((λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) y
   cond {u}{v , z} p₂ p₃ with (p₁ {u , v}{z})
   ... | p₄ with F (u , v) z
   ... | (x , y) = p₄ (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = let h = λ r → fst (f (fst r)) (snd r)
        H = λ r z → F (fst r) (snd r , z) , snd (f (fst r)) (snd r) z
     in h , (H , cond)
 where
  cond : {u : Σ U (λ x → V)} {y : Z} →
      (α ⊗ᵣ β) u (F (fst u) (snd u , y) , snd (f (fst u)) (snd u) y) →
      γ (fst (f (fst u)) (snd u)) y
  cond {u , v}{z} (p₂ , p₃) with p₁ {u} {v , z}
  ... | p₄ with f u
  ... | i , I = p₄ p₂ p₃

cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl
   aux₂ : {a : Σ U (λ x → V)} → (λ z → fst (F (fst a , snd a) z) , snd (F (fst a , snd a) z)) ≡ F a
   aux₂ {u , v} = ext-set aux₃
    where
      aux₃ : {a : Z} → (fst (F (u , v) a) , snd (F (u , v) a)) ≡ F (u , v) a
      aux₃ {z} with F (u , v) z
      ... | x , y = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = (ext-set aux) , ext-set (ext-set aux')
 where
  aux : {a : U} → ((λ v → fst (g a) v) , (λ v z → snd (g a) v z)) ≡ g a
  aux {u} with g u
  ... | i , I = refl
  aux' : {u : U}{r : Σ V (λ x → Z)} → G u (fst r , snd r) ≡ G u r
  aux' {u}{v , z} = refl

-- The of-course exponential:
!ₒ-cond : ∀{U X : Set} → (α : U → X → Set) → U → 𝕃 X → Set
!ₒ-cond {U}{X} α u [] = ⊤
!ₒ-cond {U}{X} α u (x :: xs) = (α u x) × (!ₒ-cond α u xs)

!ₒ-cond-++ : ∀{U X : Set}{α : U → X → Set}{u : U}{l₁ l₂ : 𝕃 X}
  → !ₒ-cond α u (l₁ ++ l₂) ≡ ((!ₒ-cond α u l₁) × (!ₒ-cond α u l₂))
!ₒ-cond-++ {U}{X}{α}{u}{[]}{l₂} = ∧-unit
!ₒ-cond-++ {U}{X}{α}{u}{x :: xs}{l₂} rewrite !ₒ-cond-++ {U}{X}{α}{u}{xs}{l₂} = ∧-assoc

!ₒ : Obj → Obj
!ₒ (U , X , α) = U ,  X * , !ₒ-cond α

!ₐ-s : ∀{U Y X : Set}
  → (U → Y → X)
  → (U → Y * → X *)
!ₐ-s f u l = map (f u) l

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , (!ₐ-s F , aux)
 where
   aux : {u : U} {y : 𝕃 Y} → !ₒ-cond α u (!ₐ-s F u y) → !ₒ-cond β (f u) y
   aux {u}{[]} p₁ = triv
   aux {u}{y :: ys} (p₁ , p₂) = p p₁ , aux p₂

-- Of-course is a comonad:
ε : ∀{A} → Hom (!ₒ A) A
ε {U , X , α} = id-set , (λ u x → [ x ]) , fst

δ-s : {U X : Set} → U → 𝕃 (𝕃 X) → 𝕃 X
δ-s u xs = foldr _++_ [] xs

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-s , cond
 where
   cond : {u : U} {y : 𝕃 (𝕃 X)} → !ₒ-cond α u (foldr _++_ [] y) → !ₒ-cond (!ₒ-cond α) u y
   cond {u}{[]} p = triv
   cond {u}{l :: ls} p with !ₒ-cond-++ {U}{X}{α}{u}{l}{foldr _++_ [] ls}
   ... | p' rewrite p' with p
   ... | p₂ , p₃ = p₂ , cond {u}{ls} p₃

comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} = refl , ext-set (λ {x} → ext-set (λ {l} → aux {x} {l}))
 where
  aux : ∀{x : U}{l : 𝕃 (𝕃 (𝕃 X))}
    → foldr _++_ [] (!ₐ-s (λ u xs
    → foldr _++_ [] xs) x l) ≡ foldr _++_ [] (foldr _++_ [] l)
  aux {u}{[]} = refl
  aux {u}{x :: xs} rewrite aux {u}{xs} = foldr-append {_}{_}{X}{X}{x}{foldr _++_ [] xs}

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {u} → ext-set (λ {l} → aux {l}))
  where
    aux : ∀{a : 𝕃 X} → a ++ [] ≡ foldr _++_ [] (map (λ x → x :: []) a)
    aux {[]} = refl
    aux {x :: xs} rewrite (++[] xs) | sym (foldr-map {_}{X}{xs}) = refl


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommAlgebra.Localisation where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Powerset

open import Cubical.Data.Sigma

open import Cubical.Reflection.StrictEquiv

open import Cubical.Structures.Axioms
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommRing.Base
open import Cubical.Algebra.CommRing.Properties
open import Cubical.Algebra.CommRing.Localisation.Base
open import Cubical.Algebra.CommRing.Localisation.UniversalProperty
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Algebra
open import Cubical.Algebra.CommAlgebra.Base
open import Cubical.Algebra.CommAlgebra.Properties

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

private
  variable
    ℓ ℓ′ : Level

module AlgLoc (R' : CommRing ℓ)
              (S' : ℙ (fst R')) (SMultClosedSubset : isMultClosedSubset R' S') where
 open isMultClosedSubset
 private R = fst R'
 open CommAlgebraStr
 open IsAlgebraHom
 open CommRingStr (snd R') renaming (_+_ to _+r_ ; _·_ to _·r_ ; ·Rid to ·rRid)
 open RingTheory (CommRing→Ring R')
 open CommRingTheory R'
 open Loc R' S' SMultClosedSubset
 open S⁻¹RUniversalProp R' S' SMultClosedSubset
 open CommAlgChar R'

 S⁻¹RAsCommAlg : CommAlgebra R' ℓ
 S⁻¹RAsCommAlg = toCommAlg (S⁻¹RAsCommRing , /1AsCommRingHom)

 hasLocAlgUniversalProp : (A : CommAlgebra R' ℓ)
                        → (∀ s → s ∈ S' → _⋆_ (snd A) s (1a (snd A)) ∈ (CommAlgebra→CommRing A) ˣ)
                        → Type (ℓ-suc ℓ)
 hasLocAlgUniversalProp A _ = (B : CommAlgebra R' ℓ)
                      → (∀ s → s ∈ S' →  _⋆_ (snd B) s (1a (snd B)) ∈ (CommAlgebra→CommRing B) ˣ)
                      → isContr (CommAlgebraHom A B)

 S⋆1⊆S⁻¹Rˣ : ∀ s → s ∈ S' → _⋆_ (snd S⁻¹RAsCommAlg) s (1a (snd S⁻¹RAsCommAlg)) ∈ S⁻¹Rˣ
 S⋆1⊆S⁻¹Rˣ s s∈S' = subst-∈ S⁻¹Rˣ
                    (cong [_] (≡-× (sym (·rRid s)) (Σ≡Prop (λ x → S' x .snd) (sym (·rRid _)))))
                    (S/1⊆S⁻¹Rˣ s s∈S')

 S⁻¹RHasAlgUniversalProp : hasLocAlgUniversalProp S⁻¹RAsCommAlg S⋆1⊆S⁻¹Rˣ
 S⁻¹RHasAlgUniversalProp B' S⋆1⊆Bˣ = χᴬ , χᴬuniqueness
  where
  B = fromCommAlg B' .fst
  φ = fromCommAlg B' .snd
  open CommRingStr (snd B) renaming (_·_ to _·b_ ; 1r to 1b ; ·Lid to ·bLid)

  χ : CommRingHom S⁻¹RAsCommRing B
  χ = S⁻¹RHasUniversalProp B φ S⋆1⊆Bˣ .fst .fst

  χcomp : ∀ r → fst χ (r /1) ≡ fst φ r
  χcomp = funExt⁻ (S⁻¹RHasUniversalProp B φ S⋆1⊆Bˣ .fst .snd)

  χᴬ : CommAlgebraHom S⁻¹RAsCommAlg B'
  fst χᴬ = fst χ
  pres0 (snd χᴬ) = IsRingHom.pres0 (snd χ)
  pres1 (snd χᴬ) = IsRingHom.pres1 (snd χ)
  pres+ (snd χᴬ) = IsRingHom.pres+ (snd χ)
  pres· (snd χᴬ) = IsRingHom.pres· (snd χ)
  pres- (snd χᴬ) = IsRingHom.pres- (snd χ)
  pres⋆ (snd χᴬ) r x = path
   where
   path : fst χ ((r /1) ·ₗ x) ≡ _⋆_  (snd B') r (fst χ x)
   path = fst χ ((r /1) ·ₗ x)             ≡⟨ IsRingHom.pres· (snd χ) _ _ ⟩
          fst χ (r /1) ·b fst χ x         ≡⟨ cong (_·b fst χ x) (χcomp r) ⟩
          fst φ r ·b fst χ x              ≡⟨ refl ⟩
          _⋆_  (snd B') r 1b ·b fst χ x   ≡⟨ ⋆-lassoc (snd B') _ _ _ ⟩
          _⋆_  (snd B') r (1b ·b fst χ x) ≡⟨ cong (_⋆_ (snd B') r) (·bLid _) ⟩
          _⋆_  (snd B') r (fst χ x)       ∎

  χᴬuniqueness : (ψ : CommAlgebraHom S⁻¹RAsCommAlg B') → χᴬ ≡ ψ
  χᴬuniqueness ψ = Σ≡Prop (λ _ → isPropIsAlgebraHom _ _ _ _)
                          (cong (fst ∘ fst) (χuniqueness (ψ' , funExt ψ'r/1≡φr)))
   where
   χuniqueness = S⁻¹RHasUniversalProp B φ S⋆1⊆Bˣ .snd

   ψ' : CommRingHom S⁻¹RAsCommRing B
   fst ψ' = fst ψ
   IsRingHom.pres0 (snd ψ') = pres0 (snd ψ)
   IsRingHom.pres1 (snd ψ') = pres1 (snd ψ)
   IsRingHom.pres+ (snd ψ') = pres+ (snd ψ)
   IsRingHom.pres· (snd ψ') = pres· (snd ψ)
   IsRingHom.pres- (snd ψ') = pres- (snd ψ)

   ψ'r/1≡φr : ∀ r → fst ψ (r /1) ≡ fst φ r
   ψ'r/1≡φr r =
    fst ψ (r /1) ≡⟨ cong (fst ψ) (sym (·ₗ-rid _)) ⟩
    fst ψ (_⋆_ (snd S⁻¹RAsCommAlg) r (1a (snd S⁻¹RAsCommAlg))) ≡⟨ pres⋆ (snd ψ) _ _ ⟩
    _⋆_  (snd B') r (fst ψ (1a (snd S⁻¹RAsCommAlg))) ≡⟨ cong (_⋆_ (snd B') r) (pres1 (snd ψ)) ⟩
    _⋆_  (snd B') r 1b ∎

 -- an immediate corollary:
 isContrHomS⁻¹RS⁻¹R : isContr (CommAlgebraHom S⁻¹RAsCommAlg S⁻¹RAsCommAlg)
 isContrHomS⁻¹RS⁻¹R = S⁻¹RHasAlgUniversalProp S⁻¹RAsCommAlg S⋆1⊆S⁻¹Rˣ

module AlgLocTwoSubsets (R' : CommRing ℓ)
                        (S₁ : ℙ (fst R')) (S₁MultClosedSubset : isMultClosedSubset R' S₁)
                        (S₂ : ℙ (fst R')) (S₂MultClosedSubset : isMultClosedSubset R' S₂) where
 open isMultClosedSubset
 open CommRingStr (snd R') hiding (is-set)
 open RingTheory (CommRing→Ring R')
 open Loc R' S₁ S₁MultClosedSubset renaming (S⁻¹R to S₁⁻¹R ;
                                             S⁻¹RAsCommRing to S₁⁻¹RAsCommRing)
 open Loc R' S₂ S₂MultClosedSubset renaming (S⁻¹R to S₂⁻¹R ;
                                             S⁻¹RAsCommRing to S₂⁻¹RAsCommRing)
 open AlgLoc R' S₁ S₁MultClosedSubset renaming ( S⁻¹RAsCommAlg to S₁⁻¹RAsCommAlg
                                               ; S⋆1⊆S⁻¹Rˣ to S₁⋆1⊆S₁⁻¹Rˣ
                                               ; S⁻¹RHasAlgUniversalProp to S₁⁻¹RHasAlgUniversalProp
                                               ; isContrHomS⁻¹RS⁻¹R to isContrHomS₁⁻¹RS₁⁻¹R)
 open AlgLoc R' S₂ S₂MultClosedSubset renaming ( S⁻¹RAsCommAlg to S₂⁻¹RAsCommAlg
                                               ; S⋆1⊆S⁻¹Rˣ to S₂⋆1⊆S₂⁻¹Rˣ
                                               ; S⁻¹RHasAlgUniversalProp to S₂⁻¹RHasAlgUniversalProp
                                               ; isContrHomS⁻¹RS⁻¹R to isContrHomS₂⁻¹RS₂⁻¹R)

 open IsAlgebraHom
 open CommAlgebraStr ⦃...⦄

 private
  R = fst R'
  S₁⁻¹Rˣ = S₁⁻¹RAsCommRing ˣ
  S₂⁻¹Rˣ = S₂⁻¹RAsCommRing ˣ
  instance
   _ = snd S₁⁻¹RAsCommAlg
   _ = snd S₂⁻¹RAsCommAlg

 isContrS₁⁻¹R≡S₂⁻¹R : (∀ s₁ → s₁ ∈ S₁ → s₁ ⋆ 1a ∈ S₂⁻¹Rˣ)
                    → (∀ s₂ → s₂ ∈ S₂ → s₂ ⋆ 1a ∈ S₁⁻¹Rˣ)
                    → isContr (S₁⁻¹RAsCommAlg ≡ S₂⁻¹RAsCommAlg)
 isContrS₁⁻¹R≡S₂⁻¹R S₁⊆S₂⁻¹Rˣ S₂⊆S₁⁻¹Rˣ = isOfHLevelRetractFromIso 0
                                            (equivToIso (invEquiv (CommAlgebraPath _ _ _)))
                                              isContrS₁⁻¹R≅S₂⁻¹R
  where
  χ₁ : CommAlgebraHom S₁⁻¹RAsCommAlg S₂⁻¹RAsCommAlg
  χ₁ = S₁⁻¹RHasAlgUniversalProp S₂⁻¹RAsCommAlg S₁⊆S₂⁻¹Rˣ .fst

  χ₂ : CommAlgebraHom S₂⁻¹RAsCommAlg S₁⁻¹RAsCommAlg
  χ₂ = S₂⁻¹RHasAlgUniversalProp S₁⁻¹RAsCommAlg S₂⊆S₁⁻¹Rˣ .fst

  χ₁∘χ₂≡id : χ₁ ∘a χ₂ ≡ idAlgHom
  χ₁∘χ₂≡id = isContr→isProp isContrHomS₂⁻¹RS₂⁻¹R _ _

  χ₂∘χ₁≡id : χ₂ ∘a χ₁ ≡ idAlgHom
  χ₂∘χ₁≡id = isContr→isProp isContrHomS₁⁻¹RS₁⁻¹R _ _

  IsoS₁⁻¹RS₂⁻¹R : Iso S₁⁻¹R S₂⁻¹R
  Iso.fun IsoS₁⁻¹RS₂⁻¹R = fst χ₁
  Iso.inv IsoS₁⁻¹RS₂⁻¹R = fst χ₂
  Iso.rightInv IsoS₁⁻¹RS₂⁻¹R = funExt⁻ (cong fst χ₁∘χ₂≡id)
  Iso.leftInv IsoS₁⁻¹RS₂⁻¹R = funExt⁻ (cong fst χ₂∘χ₁≡id)

  isContrS₁⁻¹R≅S₂⁻¹R : isContr (CommAlgebraEquiv S₁⁻¹RAsCommAlg S₂⁻¹RAsCommAlg)
  isContrS₁⁻¹R≅S₂⁻¹R = center , uniqueness
   where
   center : CommAlgebraEquiv S₁⁻¹RAsCommAlg S₂⁻¹RAsCommAlg
   fst center = isoToEquiv IsoS₁⁻¹RS₂⁻¹R
   pres0 (snd center) = pres0 (snd χ₁)
   pres1 (snd center) = pres1 (snd χ₁)
   pres+ (snd center) = pres+ (snd χ₁)
   pres· (snd center) = pres· (snd χ₁)
   pres- (snd center) = pres- (snd χ₁)
   pres⋆ (snd center) = pres⋆ (snd χ₁)

   uniqueness : (φ : CommAlgebraEquiv S₁⁻¹RAsCommAlg S₂⁻¹RAsCommAlg) → center ≡ φ
   uniqueness φ = Σ≡Prop (λ _ → isPropIsAlgebraHom _ _ _ _)
                         (equivEq (cong fst
                           (S₁⁻¹RHasAlgUniversalProp S₂⁻¹RAsCommAlg S₁⊆S₂⁻¹Rˣ .snd
                             (AlgebraEquiv→AlgebraHom φ))))

 isPropS₁⁻¹R≡S₂⁻¹R  : isProp (S₁⁻¹RAsCommAlg ≡ S₂⁻¹RAsCommAlg)
 isPropS₁⁻¹R≡S₂⁻¹R S₁⁻¹R≡S₂⁻¹R  =
   isContr→isProp (isContrS₁⁻¹R≡S₂⁻¹R  S₁⊆S₂⁻¹Rˣ S₂⊆S₁⁻¹Rˣ) S₁⁻¹R≡S₂⁻¹R
    where
    S₁⊆S₂⁻¹Rˣ : ∀ s₁ → s₁ ∈ S₁ → s₁ ⋆ 1a ∈ S₂⁻¹Rˣ
    S₁⊆S₂⁻¹Rˣ s₁ s₁∈S₁ =
      transport (λ i → _⋆_ ⦃ S₁⁻¹R≡S₂⁻¹R i .snd ⦄ s₁ (1a ⦃ S₁⁻¹R≡S₂⁻¹R i .snd ⦄)
                     ∈ (CommAlgebra→CommRing (S₁⁻¹R≡S₂⁻¹R i)) ˣ) (S₁⋆1⊆S₁⁻¹Rˣ s₁ s₁∈S₁)

    S₂⊆S₁⁻¹Rˣ : ∀ s₂ → s₂ ∈ S₂ → s₂ ⋆ 1a ∈ S₁⁻¹Rˣ
    S₂⊆S₁⁻¹Rˣ s₂ s₂∈S₂ =
      transport (λ i → _⋆_ ⦃ (sym S₁⁻¹R≡S₂⁻¹R) i .snd ⦄ s₂ (1a ⦃ (sym S₁⁻¹R≡S₂⁻¹R) i .snd ⦄)
                     ∈ (CommAlgebra→CommRing ((sym S₁⁻¹R≡S₂⁻¹R) i)) ˣ) (S₂⋆1⊆S₂⁻¹Rˣ s₂ s₂∈S₂)


{-# OPTIONS --universe-polymorphism #-}
open import Common.Prelude
  renaming (Nat to ℕ; module Nat to ℕ)
   using (zero; suc; _+_; _∸_; List; []; _∷_; Bool; true; false)
open import Common.Level
open import Common.Reflection

module TermSplicing where

module Library where
  data Box {a} (A : Set a) : Set a where
    box : A → Box A

  record ⊤ : Set where
    constructor tt

  infixr 5 _×_
  record _×_ (A B : Set) : Set where
    constructor _,_
    field
      proj₁ : A
      proj₂ : B

  [_] : ∀ {A : Set} → A → List A
  [ x ] = x ∷ []

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

  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)

  foldl : ∀ {A B : Set} → (A → B → A) → A → List B → A
  foldl c n []       = n
  foldl c n (x ∷ xs) = foldl c (c n x) xs

  reverse : ∀ {A : Set} → List A → List A
  reverse = foldl (λ rev x → x ∷ rev) []

  length : ∀ {A : Set} → List A → ℕ
  length = foldr (λ _ → suc) 0

  data Maybe (A : Set) : Set where
    nothing : Maybe A
    just    : A → Maybe A

  mapMaybe : ∀ {A B : Set} → (A → B) → Maybe A → Maybe B
  mapMaybe f (just x) = just (f x)
  mapMaybe f nothing  = nothing

  when : ∀ {A} → Bool → Maybe A → Maybe A
  when true  x = x
  when false _ = nothing

  infix 6 _≡_

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

  _→⟨_⟩_ : ∀ (A : Set) (n : ℕ) (B : Set) → Set
  A →⟨ zero  ⟩ B = B
  A →⟨ suc n ⟩ B = A → A →⟨ n ⟩ B

open Library

module ReflectLibrary where
  lamᵛ : Term → Term
  lamᵛ t = lam visible (abs "_" t)

  lamʰ : Term → Term
  lamʰ t = lam hidden (abs "_" t)

  argᵛʳ : ∀{a} {A : Set a} → A → Arg A
  argᵛʳ = arg (argInfo visible relevant)

  argʰʳ : ∀{a} {A : Set a} → A → Arg A
  argʰʳ = arg (argInfo hidden relevant)

  app` : (Args → Term) → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  app` f = go [] where
    go : List (Arg Term) → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
    go args []             = f (reverse args)
    go args (i ∷ hs) = λ t → go (arg i t ∷ args) hs

  con` : QName → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  con` x = app` (con x)

  def` : QName → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  def` x = app` (def x)

  var` : ℕ → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  var` x = app` (var x)

  coe : ∀ {A : Set} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
  coe zero    t = t
  coe (suc n) f = λ t → coe n (f t)

  con`ⁿʳ : QName → (n : ℕ) → Term →⟨ n ⟩ Term
  con`ⁿʳ x n = coe n (app` (con x) (replicate n (argInfo visible relevant)))

  def`ⁿʳ : QName → (n : ℕ) → Term →⟨ n ⟩ Term
  def`ⁿʳ x n = coe n (app` (def x) (replicate n (argInfo visible relevant)))

  var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
  var`ⁿʳ x n = coe n (app` (var x) (replicate n (argInfo visible relevant)))

  sort₀ : Sort
  sort₀ = lit 0

  sort₁ : Sort
  sort₁ = lit 1

  `Set₀ : Term
  `Set₀ = sort sort₀

  unArg : ∀ {a} {A : Set a} → Arg A → A
  unArg (arg _ a) = a

  `Level : Term
  `Level = def (quote Level) []

  ℕ→Level : ℕ → Level
  ℕ→Level zero    = lzero
  ℕ→Level (suc n) = lsuc (ℕ→Level n)

  -- Can't match on Levels anymore
--   Level→ℕ : Level → ℕ
--   Level→ℕ zero    = zero
--   Level→ℕ (suc n) = suc (Level→ℕ n)

  setLevel : Level → Sort
  setLevel ℓ = lit 0 -- (Level→ℕ ℓ)

  _==_ : QName → QName → Bool
  _==_ = primQNameEquality

  decodeSort : Sort → Maybe Level
  decodeSort (set (con c [])) = when (quote lzero == c) (just lzero)
  decodeSort (set (con c (arg (argInfo visible relevant) s ∷ [])))
    = when (quote lsuc == c) (mapMaybe lsuc (decodeSort (set s)))
  decodeSort (set (sort s)) = decodeSort s
  decodeSort (set _) = nothing
  decodeSort (lit n) = just (ℕ→Level n)
  decodeSort (prop _) = nothing
  decodeSort (propLit _) = nothing
  decodeSort (inf _) = nothing
  decodeSort unknown = nothing

  _`⊔`_ : Sort → Sort → Sort
  s₁ `⊔` s₂ with decodeSort s₁ | decodeSort s₂
  ...          | just n₁       | just n₂        = setLevel (n₁ ⊔ n₂)
  ...          | _             | _              = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

  Π : Arg Type → Type → Type
  Π t u = pi t (abs "_" u)

  Πᵛʳ : Type → Type → Type
  Πᵛʳ t u = Π (vArg t) u

  Πʰʳ : Type → Type → Type
  Πʰʳ t u = Π (hArg t) u

open ReflectLibrary

`ℕ : Term
`ℕ = def (quote ℕ) []

`ℕOk : (unquote (give `ℕ)) ≡ ℕ
`ℕOk = refl

idℕ : ℕ → ℕ
idℕ = unquote (give (lamᵛ (var 0 [])))

id : (A : Set) → A → A
id = unquote (give (lamᵛ (lamᵛ (var 0 []))))

idBox : Box ({A : Set} → A → A)
idBox = box (unquote (give (lamᵛ (var 0 []))))

-- builds a pair
_`,_ : Term → Term → Term
_`,_ = con`ⁿʳ (quote _,_) 2

`tt : Term
`tt = con (quote tt) []

tuple : List Term → Term
tuple = foldr _`,_ `tt

`refl : Term
`refl = con (quote refl) []

`zero : Term
`zero = con (quote ℕ.zero) []

`[] : Term
`[] = con (quote []) []

_`∷_ : (`x `xs : Term) → Term
_`∷_ = con`ⁿʳ (quote _∷_) 2

`abs : (`s `body : Term) → Term
`abs = con`ⁿʳ (quote abs) 2

`var : (`n `args : Term) → Term
`var = con`ⁿʳ (quote Term.var) 2

`lam : (`hiding `body : Term) → Term
`lam = con`ⁿʳ (quote lam) 2

`lit : Term → Term
`lit = con`ⁿʳ (quote Term.lit) 1

`string : Term → Term
`string = con`ⁿʳ (quote string) 1

`visible : Term
`visible = con (quote visible) []

`hidden : Term
`hidden = con (quote hidden) []

`[_`] : Term → Term
`[ x `] = x `∷ `[]

quotedTwice : Term
quotedTwice = `lam `visible (`abs (lit (string "_")) (`var `zero `[]))

unquoteTwice₂ : ℕ → ℕ
unquoteTwice₂ = unquote (give (unquote (give quotedTwice)))

unquoteTwice : ℕ → ℕ
unquoteTwice x = unquote (give (unquote (give (`var `zero `[]))))

id₂ : {A : Set} → A → A
id₂ = unquote (give (lamᵛ (var 0 [])))

id₃ : {A : Set} → A → A
id₃ x = unquote (give (var 0 []))

module Id {A : Set} (x : A) where
  x′ : A
  x′ = unquote (give (var 0 []))

k`ℕ : ℕ → Term
k`ℕ zero    = `ℕ
k`ℕ (suc n) = unquote (give (def (quote k`ℕ) [ argᵛʳ (var 0 []) ])) -- k`ℕ n

test : id ≡ (λ A (x : A) → x)
     × unquote (give `Set₀)                      ≡ Set
     × unquote (give `ℕ)                        ≡ ℕ
     × unquote (give (lamᵛ (var 0 [])))          ≡ (λ (x : Set) → x)
     × id                                        ≡ (λ A (x : A) → x)
     × unquote (give `tt)                        ≡ tt
     × (λ {A} → Id.x′ {A})                ≡ (λ {A : Set} (x : A) → x)
     × unquote (give (pi (vArg `Set₀) (abs "_" `Set₀)))  ≡ (Set → Set)
     × unquoteTwice                        ≡ (λ (x : ℕ) → x)
     × unquote (give (k`ℕ 42))                    ≡ ℕ
     × unquote (give (lit (nat 15)))              ≡ 15
     × unquote (give (lit (float 3.1415)))        ≡ 3.1415
     × unquote (give (lit (string "foo")))        ≡ "foo"
     × unquote (give (lit (char 'X')))            ≡ 'X'
     × unquote (give (lit (qname (quote ℕ))))      ≡ quote ℕ
     × ⊤
test = unquote (give (tuple (replicate n `refl))) where n = 15

Πⁿ : ℕ → Type → Type
Πⁿ zero    t = t
Πⁿ (suc n) t = Π (argʰʳ `Set₀) (Πⁿ n t)

ƛⁿ : Hiding → ℕ → Term → Term
ƛⁿ h zero    t = t
ƛⁿ h (suc n) t = lam h (abs "_" (ƛⁿ h n t))

-- projᵢ : Proj i n
-- projᵢ = proj i n
-- Projᵢ = {A₁ ... Ai ... An : Set} → A₁ → ... → Aᵢ → ... → An → Aᵢ
-- projᵢ = λ {A₁ ... Ai ... An} x₁ ... xᵢ ... xn → xᵢ

Proj : (i n : ℕ) → Term
Proj i n = Πⁿ n (go n) where
  n∸1 = n ∸ 1
  go : ℕ → Type
  go zero    = var ((n + n) ∸ i) []
  go (suc m) = Π (argᵛʳ (var n∸1 [])) (go m)

proj : (i n : ℕ) → Term
proj i n = ƛⁿ visible n (var (n ∸ i) [])

projFull : (i n : ℕ) → Term
projFull i n = ƛⁿ hidden n (proj i n)

ℕ→ℕ : Set
ℕ→ℕ = unquote (give (Π (argᵛʳ `ℕ) `ℕ))

ℕ→ℕOk : ℕ→ℕ ≡ (ℕ → ℕ)
ℕ→ℕOk = refl

``∀A→A : Type
``∀A→A = Πᵛʳ `Set₀ (var 0 [])

∀A→A : Set₁
∀A→A = unquote (give ``∀A→A)

Proj₁¹ : Set₁
Proj₁¹ = unquote (give (Proj 1 1))

Proj₁² : Set₁
Proj₁² = unquote (give (Proj 1 2))

Proj₂² : Set₁
Proj₂² = unquote (give (Proj 2 2))

proj₃⁵ : unquote (give (Proj 3 5))
proj₃⁵ _ _ x _ _ = x

proj₃⁵′ : Box (unquote (give (Proj 3 5)))
proj₃⁵′ = box (unquote (give (proj 3 5)))

proj₂⁷ : unquote (give (Proj 2 7))
proj₂⁷ = unquote (give (proj 2 7))

test-proj : proj₃⁵′                ≡ box (λ _ _ x _ _ → x)
          × Proj₁¹                 ≡ ({A : Set} → A → A)
          × Proj₁²                 ≡ ({A₁ A₂ : Set} → A₁ → A₂ → A₁)
          × Proj₂²                 ≡ ({A₁ A₂ : Set} → A₁ → A₂ → A₂)
          × unquote (give (Proj 3 5))     ≡ ({A₁ A₂ A₃ A₄ A₅ : Set} → A₁ → A₂ → A₃ → A₄ → A₅ → A₃)
          × unquote (give (projFull 1 1)) ≡ (λ {A : Set} (x : A) → x)
          × unquote (give (projFull 1 2)) ≡ (λ {A₁ A₂ : Set} (x₁ : A₁) (x₂ : A₂) → x₁)
          × unquote (give (projFull 2 2)) ≡ (λ {A₁ A₂ : Set} (x₁ : A₁) (x₂ : A₂) → x₂)
          × ∀A→A                   ≡ (∀ (A : Set) → A)
          × ⊤
test-proj = unquote (give (tuple (replicate n `refl))) where n = 9

module Test where
  data Squash (A : Set) : Set where
    squash : unquote (give (Π (arg (argInfo visible irrelevant) (var 0 []))
                              (def (quote Squash) (argᵛʳ (var 1 []) ∷ []))))

data Squash (A : Set) : Set where
  squash : .A → Squash A

`Squash : Term → Term
`Squash = def`ⁿʳ (quote Squash) 1

squash-type : Type
squash-type = Π (arg (argInfo visible irrelevant) (var 0 [])) (`Squash (var 1 []))

test-squash : ∀ {A} → (.A → Squash A) ≡ unquote (give squash-type)
test-squash = refl

`∀ℓ→Setℓ : Type
`∀ℓ→Setℓ = Πᵛʳ `Level (sort (set (var 0 [])))


{-
 following Johnstone's book "Stone Spaces" we define semilattices
 to be commutative monoids such that every element is idempotent.
 In particular, we take every semilattice to have a neutral element
 that is either the maximal or minimal element depending on whether
 we have a join or meet semilattice.
-}

{-# OPTIONS --safe #-}
module Cubical.Algebra.Semilattice.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommMonoid

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Relation.Binary
open import Cubical.Relation.Binary.Poset

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ ℓ' : Level

record IsSemilattice {A : Type ℓ} (ε : A) (_·_ : A → A → A) : Type ℓ where
  constructor issemilattice

  field
   isCommMonoid : IsCommMonoid ε _·_
   idem : (x : A) → x · x ≡ x

  open IsCommMonoid isCommMonoid public

unquoteDecl IsSemilatticeIsoΣ = declareRecordIsoΣ IsSemilatticeIsoΣ (quote IsSemilattice)

record SemilatticeStr (A : Type ℓ) : Type ℓ where
  constructor semilatticestr

  field
    ε        : A
    _·_      : A → A → A
    isSemilattice : IsSemilattice ε _·_

  infixl 7 _·_

  open IsSemilattice isSemilattice public

Semilattice : ∀ ℓ → Type (ℓ-suc ℓ)
Semilattice ℓ = TypeWithStr ℓ SemilatticeStr

semilattice : (A : Type ℓ) (ε : A) (_·_ : A → A → A) (h : IsSemilattice ε _·_) → Semilattice ℓ
semilattice A ε _·_ h = A , semilatticestr ε _·_ h

-- Easier to use constructors
makeIsSemilattice : {L : Type ℓ} {ε : L} {_·_ : L → L → L}
               (is-setL : isSet L)
               (assoc : (x y z : L) → x · (y · z) ≡ (x · y) · z)
               (rid : (x : L) → x · ε ≡ x)
               (lid : (x : L) → ε · x ≡ x)
               (comm : (x y : L) → x · y ≡ y · x)
               (idem : (x : L) → x · x ≡ x)
             → IsSemilattice ε _·_
IsSemilattice.isCommMonoid (makeIsSemilattice is-setL assoc rid lid comm idem) =
                                        makeIsCommMonoid is-setL assoc rid lid comm
IsSemilattice.idem (makeIsSemilattice is-setL assoc rid lid comm idem) = idem

makeSemilattice : {L : Type ℓ} (ε : L) (_·_ : L → L → L)
             (is-setL : isSet L)
             (assoc : (x y z : L) → x · (y · z) ≡ (x · y) · z)
             (rid : (x : L) → x · ε ≡ x)
             (lid : (x : L) → ε · x ≡ x)
             (comm : (x y : L) → x · y ≡ y · x)
             (idem : (x : L) → x · x ≡ x)
             → Semilattice ℓ
makeSemilattice ε _·_ is-setL assoc rid lid comm idem =
  semilattice _ ε _·_ (makeIsSemilattice is-setL assoc rid lid comm idem)

SemilatticeStr→MonoidStr : {A : Type ℓ} → SemilatticeStr A → MonoidStr A
SemilatticeStr→MonoidStr (semilatticestr _ _ H) =
                          monoidstr _ _ (H .IsSemilattice.isCommMonoid .IsCommMonoid.isMonoid)

Semilattice→Monoid : Semilattice ℓ → Monoid ℓ
Semilattice→Monoid (_ , semilatticestr _ _ H) =
                    _ , monoidstr _ _ (H .IsSemilattice.isCommMonoid .IsCommMonoid.isMonoid)

Semilattice→CommMonoid : Semilattice ℓ → CommMonoid ℓ
Semilattice→CommMonoid (_ , semilatticestr _ _ H) =
                        _ , commmonoidstr _ _ (H .IsSemilattice.isCommMonoid)

SemilatticeHom : (L : Semilattice ℓ) (M : Semilattice ℓ') → Type (ℓ-max ℓ ℓ')
SemilatticeHom L M = MonoidHom (Semilattice→Monoid L) (Semilattice→Monoid M)

IsSemilatticeEquiv : {A : Type ℓ} {B : Type ℓ'}
  (M : SemilatticeStr A) (e : A ≃ B) (N : SemilatticeStr B) → Type (ℓ-max ℓ ℓ')
IsSemilatticeEquiv M e N =
                   IsMonoidHom (SemilatticeStr→MonoidStr M) (e .fst) (SemilatticeStr→MonoidStr N)

SemilatticeEquiv : (M : Semilattice ℓ) (N : Semilattice ℓ') → Type (ℓ-max ℓ ℓ')
SemilatticeEquiv M N = Σ[ e ∈ (M .fst ≃ N .fst) ] IsSemilatticeEquiv (M .snd) e (N .snd)

isPropIsSemilattice : {L : Type ℓ} (ε : L) (_·_ : L → L → L)
             → isProp (IsSemilattice ε _·_)
isPropIsSemilattice ε _·_ (issemilattice LL LC) (issemilattice SL SC) =
  λ i → issemilattice (isPropIsCommMonoid _ _ LL SL i) (isPropIdem LC SC i)
  where
  isSetL : isSet _
  isSetL = LL .IsCommMonoid.isMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

  isPropIdem : isProp ((x : _) → x · x ≡ x)
  isPropIdem = isPropΠ λ _ → isSetL _ _

𝒮ᴰ-Semilattice : DUARel (𝒮-Univ ℓ) SemilatticeStr ℓ
𝒮ᴰ-Semilattice =
  𝒮ᴰ-Record (𝒮-Univ _) IsSemilatticeEquiv
    (fields:
      data[ ε ∣ autoDUARel _ _ ∣ presε ]
      data[ _·_ ∣ autoDUARel _ _ ∣ isHom ]
      prop[ isSemilattice ∣ (λ _ _ → isPropIsSemilattice _ _) ])
  where
  open SemilatticeStr
  open IsMonoidHom

SemilatticePath : (L K : Semilattice ℓ) → SemilatticeEquiv L K ≃ (L ≡ K)
SemilatticePath = ∫ 𝒮ᴰ-Semilattice .UARel.ua

-- TODO: decide if that's the right approach
module JoinSemilattice (L' : Semilattice ℓ) where
 private L = fst L'
 open SemilatticeStr (snd L') renaming (_·_ to _∨l_ ; ε to 1l)
 open CommMonoidTheory (Semilattice→CommMonoid L')

 _≤_ : L → L → Type ℓ
 x ≤ y = x ∨l y ≡ y

 infix 4 _≤_

 IndPoset : Poset ℓ ℓ
 fst IndPoset = L
 PosetStr._≤_ (snd IndPoset) = _≤_
 IsPoset.is-set (PosetStr.isPoset (snd IndPoset)) = is-set
 IsPoset.is-prop-valued (PosetStr.isPoset (snd IndPoset)) = λ _ _ → is-set _ _
 IsPoset.is-refl (PosetStr.isPoset (snd IndPoset)) = idem
 IsPoset.is-trans (PosetStr.isPoset (snd IndPoset)) = path
  where
  path : (a b c : L) → a ∨l b ≡ b → b ∨l c ≡ c → a ∨l c ≡ c
  path a b c a∨b≡b b∨c≡c = a ∨l c ≡⟨ cong (a ∨l_) (sym b∨c≡c) ⟩
                            a ∨l (b ∨l c) ≡⟨ assoc _ _ _ ⟩
                            (a ∨l b) ∨l c ≡⟨ cong (_∨l c) a∨b≡b ⟩
                            b ∨l c ≡⟨ b∨c≡c ⟩
                            c ∎
 IsPoset.is-antisym (PosetStr.isPoset (snd IndPoset)) =
   λ _ _ a∨b≡b b∨a≡a → sym b∨a≡a ∙∙ comm _ _ ∙∙ a∨b≡b

 ∨lIsMax : ∀ x y z → x ≤ z → y ≤ z → x ∨l y ≤ z
 ∨lIsMax x y z x≤z y≤z = cong ((x ∨l y) ∨l_) (sym (idem z)) ∙ commAssocSwap x y z z
                                                            ∙ cong₂ (_∨l_) x≤z y≤z
                                                            ∙ idem z

 ≤-∨Pres : ∀ x y u w → x ≤ y → u ≤ w → x ∨l u ≤ y ∨l w
 ≤-∨Pres x y u w x≤y u≤w = commAssocSwap x u y w ∙ cong₂ (_∨l_) x≤y u≤w

 ≤-∨LPres : ∀ x y z → x ≤ y → z ∨l x ≤ z ∨l y
 ≤-∨LPres x y z x≤y = ≤-∨Pres _ _ _ _ (idem z) x≤y

module MeetSemilattice (L' : Semilattice ℓ) where
 private L = fst L'
 open SemilatticeStr (snd L') renaming (_·_ to _∧l_ ; ε to 0l)
 open CommMonoidTheory (Semilattice→CommMonoid L')

 _≤_ : L → L → Type ℓ
 x ≤ y = x ∧l y ≡ x

 infix 4 _≤_

 IndPoset : Poset ℓ ℓ
 fst IndPoset = L
 PosetStr._≤_ (snd IndPoset) = _≤_
 IsPoset.is-set (PosetStr.isPoset (snd IndPoset)) = is-set
 IsPoset.is-prop-valued (PosetStr.isPoset (snd IndPoset)) = λ _ _ → is-set _ _
 IsPoset.is-refl (PosetStr.isPoset (snd IndPoset)) = idem
 IsPoset.is-trans (PosetStr.isPoset (snd IndPoset)) = path
  where
  path : (a b c : L) → a ∧l b ≡ a → b ∧l c ≡ b → a ∧l c ≡ a
  path a b c a∧b≡a b∧c≡b = a ∧l c ≡⟨ cong (_∧l c) (sym a∧b≡a) ⟩
                            (a ∧l b) ∧l c ≡⟨ sym (assoc _ _ _) ⟩
                            a ∧l (b ∧l c) ≡⟨ cong (a ∧l_) b∧c≡b ⟩
                            a ∧l b ≡⟨ a∧b≡a ⟩
                            a ∎
 IsPoset.is-antisym (PosetStr.isPoset (snd IndPoset)) =
   λ _ _ a∧b≡a b∧a≡b → sym a∧b≡a ∙∙ comm _ _ ∙∙ b∧a≡b

 ≤-∧LPres : ∀ x y z → x ≤ y → z ∧l x ≤ z ∧l y
 ≤-∧LPres x y z x≤y = commAssocSwap z x z y ∙∙ cong (_∧l (x ∧l y)) (idem z) ∙∙ cong (z ∧l_) x≤y

 ∧≤LCancel : ∀ x y → x ∧l y ≤ y
 ∧≤LCancel x y = sym (assoc _ _ _) ∙ cong (x ∧l_) (idem y)

 ∧≤RCancel : ∀ x y → x ∧l y ≤ x
 ∧≤RCancel x y = commAssocr x y x ∙ cong (_∧l y) (idem x)

 ∧lIsMin : ∀ x y z → z ≤ x → z ≤ y → z ≤ x ∧l y
 ∧lIsMin x y z z≤x z≤y = cong (_∧l (x ∧l y)) (sym (idem z)) ∙ commAssocSwap z z x y
                                                            ∙ cong₂ (_∧l_) z≤x z≤y
                                                            ∙ idem z


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

module Function where

open import Level
open import Path

infixr 9 _∘_ _∘′_
_∘_ : ∀ {A : Type a} {B : A → Type b} {C : {x : A} → B x → Type c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

_∘′_ : (B → C) → (A → B) → A → C
f ∘′ g = λ x → f (g x)

flip : ∀ {A : Type a} {B : Type b} {C : A → B → Type c} →
        ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ y x → f x y

id : ∀ {A : Type a} → A → A
id x = x

const : A → B → A
const x _ = x

infixr -1 _$_
_$_ : ∀ {A : Type a} {B : A → Type b}
      → (∀ (x : A) → B x)
      → (x : A)
      → B x
f $ x = f x

infixl 1 _⟨_⟩_
_⟨_⟩_ : A → (A → B → C) → B → C
x ⟨ f ⟩ y = f x y

infixl 0 _∋_
_∋_ : (A : Type a) → A → A
A ∋ x = x

infix 0 case_of_
case_of_ : A → (A → B) → B
case x of f = f x

record Reveal_·_is_ {A : Type a} {B : A → Type b} (f : (x : A) → B x) (x : A) (y : B x) : Type b where
  constructor 〖_〗
  field eq : f x ≡ y

inspect : {A : Type a} {B : A → Type b} (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = 〖 refl 〗


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommAlgebra.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Reflection.StrictEquiv

open import Cubical.Structures.Axioms
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Algebra
open import Cubical.Algebra.CommAlgebra.Base

private
  variable
    ℓ ℓ′ : Level

-- An R-algebra is the same as a CommRing A with a CommRingHom φ : R → A
module CommAlgChar (R : CommRing ℓ) where
 open Iso
 open IsRingHom
 open CommRingTheory

 CommRingWithHom : Type (ℓ-suc ℓ)
 CommRingWithHom = Σ[ A ∈ CommRing ℓ ] CommRingHom R A

 toCommAlg : CommRingWithHom → CommAlgebra R ℓ
 toCommAlg (A , φ , φIsHom) = ⟨ A ⟩ , ACommAlgStr
  where
  open CommRingStr (snd A)
  ACommAlgStr : CommAlgebraStr R ⟨ A ⟩
  CommAlgebraStr.0a ACommAlgStr = 0r
  CommAlgebraStr.1a ACommAlgStr = 1r
  CommAlgebraStr._+_ ACommAlgStr = _+_
  CommAlgebraStr._·_ ACommAlgStr = _·_
  CommAlgebraStr.- ACommAlgStr = -_
  CommAlgebraStr._⋆_ ACommAlgStr r a = (φ r) · a
  CommAlgebraStr.isCommAlgebra ACommAlgStr = makeIsCommAlgebra
   is-set +Assoc +Rid +Rinv +Comm ·Assoc ·Lid ·Ldist+ ·Comm
   (λ _ _ x → cong (λ y →  y · x) (pres· φIsHom _ _) ∙ sym (·Assoc _ _ _))
   (λ _ _ x → cong (λ y → y · x) (pres+ φIsHom _ _) ∙ ·Ldist+ _ _ _)
   (λ _ _ _ → ·Rdist+ _ _ _)
   (λ x → cong (λ y → y · x) (pres1 φIsHom) ∙ ·Lid x)
   (λ _ _ _ → sym (·Assoc _ _ _))

 fromCommAlg : CommAlgebra R ℓ → CommRingWithHom
 fromCommAlg A = (CommAlgebra→CommRing A) , φ , φIsHom
  where
  open CommRingStr (snd R) renaming (_·_ to _·r_) hiding (·Lid)
  open CommAlgebraStr (snd A)
  open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
  φ : ⟨ R ⟩ → ⟨ A ⟩
  φ r = r ⋆ 1a
  φIsHom : IsRingHom (CommRing→Ring R .snd) φ (CommRing→Ring (CommAlgebra→CommRing A) .snd)
  φIsHom = makeIsRingHom (⋆-lid _) (λ _ _ → ⋆-ldist _ _ _)
           λ x y → cong (λ a → (x ·r y) ⋆ a) (sym (·Lid _)) ∙ ⋆Dist· _ _ _ _

 CommRingWithHomRoundTrip : (Aφ : CommRingWithHom) → fromCommAlg (toCommAlg Aφ) ≡ Aφ
 CommRingWithHomRoundTrip (A , φ) = ΣPathP (APath , φPathP)
  where
  open CommRingStr
  -- note that the proofs of the axioms might differ!
  APath : fst (fromCommAlg (toCommAlg (A , φ))) ≡ A
  fst (APath i) = ⟨ A ⟩
  0r (snd (APath i)) = 0r (snd A)
  1r (snd (APath i)) = 1r (snd A)
  _+_ (snd (APath i)) = _+_ (snd A)
  _·_ (snd (APath i)) = _·_ (snd A)
  -_ (snd (APath i)) = -_ (snd A)
  isCommRing (snd (APath i)) = isProp→PathP (λ i → isPropIsCommRing _ _ _ _ _ )
             (isCommRing (snd (fst (fromCommAlg (toCommAlg (A , φ)))))) (isCommRing (snd A)) i

  -- this only works because fst (APath i) = fst A definitionally!
  φPathP : PathP (λ i → CommRingHom R (APath i)) (snd (fromCommAlg (toCommAlg (A , φ)))) φ
  φPathP = RingHomPathP _ _ _ _ _ _ λ i x → ·Rid (snd A) (fst φ x) i

 CommAlgRoundTrip : (A : CommAlgebra R ℓ) → toCommAlg (fromCommAlg A) ≡ A
 CommAlgRoundTrip A = ΣPathP (refl , AlgStrPathP)
  where
  open CommAlgebraStr ⦃...⦄
  instance
   _ = snd A
  AlgStrPathP : PathP (λ i → CommAlgebraStr R ⟨ A ⟩) (snd (toCommAlg (fromCommAlg A))) (snd A)
  CommAlgebraStr.0a (AlgStrPathP i) = 0a
  CommAlgebraStr.1a (AlgStrPathP i) = 1a
  CommAlgebraStr._+_ (AlgStrPathP i) = _+_
  CommAlgebraStr._·_ (AlgStrPathP i) = _·_
  CommAlgebraStr.-_ (AlgStrPathP i) = -_
  CommAlgebraStr._⋆_ (AlgStrPathP i) r x = (⋆-lassoc r 1a x ∙ cong (r ⋆_) (·Lid x)) i
  CommAlgebraStr.isCommAlgebra (AlgStrPathP i) = isProp→PathP
    (λ i → isPropIsCommAlgebra _ _ _ _ _ _ (CommAlgebraStr._⋆_ (AlgStrPathP i)))
    (CommAlgebraStr.isCommAlgebra (snd (toCommAlg (fromCommAlg A)))) isCommAlgebra i

 CommAlgIso : Iso (CommAlgebra R ℓ) CommRingWithHom
 fun CommAlgIso = fromCommAlg
 inv CommAlgIso = toCommAlg
 rightInv CommAlgIso = CommRingWithHomRoundTrip
 leftInv CommAlgIso = CommAlgRoundTrip