------------------------------------------------------------------------
-- Instantiation of Contractive for streams
------------------------------------------------------------------------

-- Taken from the paper.

-- The definition of Eq has been changed slightly, as compared to the
-- paper. The paper uses
--   Eq = λ n xs ys → take n xs ≡ take n ys.
-- The reason for the change is that with the definition above
-- coherence does not say anything about the first element in limU s.
-- With the definition in the paper head (s 0), which is the first
-- element in limU s, does not have to be related to head (s n) for
-- any other n, and this makes it impossible to prove isLimitU.
-- (Unless I have missed something.)

module Contractive.Stream {A : Set} where

open import Codata.Musical.Notation
open import Codata.Musical.Stream
open import Contractive
open import Data.Nat
open import Data.Nat.Induction
open import Data.Nat.Properties
import Data.Vec as Vec
open Vec using (_∷_; [])
open import Function
open import Relation.Unary
open import Relation.Binary.PropositionalEquality

<′-isWellFoundedOrder : IsWellFoundedOrder _<′_
<′-isWellFoundedOrder = record
  { trans         = λ {i} {j} {k} i+1≤j j+1≤k → ≤⇒≤′ (begin
                       suc i  ≤⟨ ≤′⇒≤ (≤′-step i+1≤j) ⟩
                       suc j  ≤⟨ ≤′⇒≤ j+1≤k ⟩
                       k      ∎)
  ; isWellFounded = <′-wellFounded
  }
  where open ≤-Reasoning

ofe : OFE
ofe = record
  { Carrier            = ℕ
  ; Domain             = Stream A
  ; _<_                = _<′_
  ; isWellFoundedOrder = <′-isWellFoundedOrder
  ; Eq                 = λ n xs ys → take (suc n) xs ≡ take (suc n) ys
  ; isEquivalence      = λ _ → record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }

open OFE ofe

private

  limU : (ℕ → Stream A) → Stream A
  limU s = head (s 0) ∷ ♯ limU (tail ∘ s ∘ suc)

  η : ∀ {n} {xs : Stream A} → Eq n xs (head xs ∷ ♯ tail xs)
  η {xs = x ∷ xs} = refl

  step : ∀ s →
         IsCoherent {U} (lift s) →
         IsCoherent {U} (lift (tail ∘ s ∘ suc))
  step s coh {m} {n} _ _ m<n = begin
    take (suc m) (tail (s (suc m)))      ≡⟨ lem (s (suc m)) ⟩
    Vec.tail (take (2 + m) (s (1 + m)))  ≡⟨ cong Vec.tail $ coh {1 + m} {1 + n} _ _ (s≤′s m<n) ⟩
    Vec.tail (take (2 + m) (s (1 + n)))  ≡⟨ sym $ lem (s (suc n)) ⟩
    take (suc m) (tail (s (suc n)))      ∎
    where
    open ≡-Reasoning

    lem : ∀ {n} (xs : Stream A) →
          take n (tail xs) ≡ Vec.tail (take (1 + n) xs)
    lem (x ∷ xs) = refl

  isLimitU : ∀ s →
             IsCoherent {U} (lift s) →
             IsLimit {U} (lift s) (limU s)
  isLimitU s coh {zero}  _ = begin
    take 1 (s 0)     ≡⟨ η ⟩
    head (s 0) ∷ []  ∎
    where open ≡-Reasoning
  isLimitU s coh {suc n} _ = begin
    take (2 + n) (s (1 + n))                                 ≡⟨ η ⟩
    head (s (1 + n)) ∷ take (1 + n) ((tail ∘ s ∘ suc) n)     ≡⟨ cong₂ _∷_ lem₁ (isLimitU (tail ∘ s ∘ suc)
                                                                                (step s coh) {n} _) ⟩
    head (s 0)       ∷ take (1 + n) (limU (tail ∘ s ∘ suc))  ∎
    where
    open ≡-Reasoning

    lem₂ : ∀ {n} (xs ys : Stream A) →
           Eq n xs ys → head xs ≡ head ys
    lem₂ (x ∷ xs) (y ∷ ys) = cong Vec.head

    lem₁ : head (s (1 + n)) ≡ head (s 0)
    lem₁ = lem₂ _ _ $ sym $ coh {0} {suc n} _ _ (s≤′s z≤′n)

  lim↓ : A → ∀ n → (∀ n' → n' <′ n → Stream A) → Stream A
  lim↓ x zero    s = repeat x
  lim↓ x (suc n) s = s n ≤′-refl

  isLimit↓ : ∀ x n (s : Family (↓ n)) →
             IsCoherent s → IsLimit s (lim↓ x n s)
  isLimit↓ x zero    s coh ()
  isLimit↓ x (suc n) s coh ≤′-refl       = refl
  isLimit↓ x (suc n) s coh (≤′-step m<n) =
    coh (≤′-step m<n) ≤′-refl m<n

-- The paper implicitly assumes that A is non-empty.

cofe : A → COFE
cofe x = record
  { ofe      = ofe
  ; limU     = limU
  ; isLimitU = isLimitU _
  ; lim↓     = lim↓ x
  ; isLimit↓ = λ n {s} → isLimit↓ x n s
  }


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

open import Base
open import Coinduction

module CoindEquiv where

-- Coinductive equivalences
record _∼_ {i j} (A : Set i) (B : Set j) : Set (max i j) where
  constructor _,_,_
  field
    to : A → B
    from : B → A
    eq : ∞ ((a : A) (b : B) → ((to a ≡ b) ∼ (a ≡ from b)))

-- Identity
id-∼ : ∀ {i} (A : Set i) → A ∼ A
id-∼ A = (id A) , (id A) , ♯ (λ a b → id-∼ (a ≡ b))

-- Transitivity
trans-∼ : ∀ {i} {A B C : Set i} → A ∼ B → B ∼ C → A ∼ C
trans-∼ (to , from , eq) (to' , from' , eq') =
  ((to' ◯ to) , (from ◯ from') ,
    ♯ (λ a c → trans-∼ (♭ eq' (to a) c) (♭ eq a (from' c))) ) --(λ a c → ♯ trans-∼ (♭ (eq' (to a) c)) (♭ (eq a (from' c)))))

-- -- Left unity
-- left-unit-∼ : ∀ {i} {A B : Set i} (f : A ∼ B) → trans-∼ (id-∼ A) f ≡ f
-- left-unit-∼ f = {!!}

postulate
  !-≡ : ∀ {i} {A : Set i} {u v : A} → (u ≡ v) ≡ (v ≡ u)

-- Symmetry is harder
sym-∼ : ∀ {i} {A B : Set i} → A ∼ B → B ∼ A
sym-∼ (to , from , eq) = (from , to ,
  ♯ (λ b a → let (too , fromo , eqo) = sym-∼ (♭ eq a b) in ((! ◯ (too ◯ !)) , {!!} , {!!})))
--(λ a b → transport (λ u → ∞ (u ∼ (a ≡ to b))) !-≡ (transport (λ u → ∞ ((b ≡ from a) ∼ u)) !-≡ (♯ (sym-∼ (♭ (eq b a))))))) --♯ trans-∼ {!!} (trans-∼ (sym-∼ (♭ (eq b a))) {!!})))

-- Logical equivalence with the usual notion of equivalences

∼-to-≃ : ∀ {i j} {A : Set i} {B : Set j} → (A ∼ B → A ≃ B)
∼-to-≃ (to , from , eq) =
  (to , iso-is-eq to from (λ b → _∼_.from (♭ eq (from b) b) refl)
                          (λ a → ! (_∼_.to (♭ eq a (to a)) refl)))

≃-to-∼ : ∀ {i j} {A : Set i} {B : Set j} → (A ≃ B → A ∼ B)
≃-to-∼ e = (π₁ e) , (inverse e) ,
  ♯ (λ a b → ≃-to-∼ (equiv-compose
    (path-to-eq (ap (λ b → e ☆ a ≡ b) (! (inverse-right-inverse e b))))
    ((equiv-ap e a (inverse e b))⁻¹)))

-- Unfinished attempt to prove that this notion is coherent

∼-eq-raw : ∀ {i j} {A : Set i} {B : Set j}
  {f f' : A → B} (p : f ≡ f') {g g' : B → A} (q : g ≡ g')
  {eq : ∞ ((a : A) (b : B) → ((f a ≡ b) ∼ (a ≡ g b)))}
  {eq' : ∞ ((a : A) (b : B) → ((f' a ≡ b) ∼ (a ≡ g' b)))}
  (r : transport _ p (transport _ q eq) ≡ eq')
  → (f , g , eq) ≡ (f' , g' , eq')
∼-eq-raw refl refl refl = refl

-- ∼-eq : ∀ {i j} {A : Set i} {B : Set j}
--   {f f' : A → B} (p : (a : A) → f a ≡ f' a)
--   {g g' : B → A} (q : (b : B) → g b ≡ g' b)
--   {eq : (a : A) (b : B) → ∞ ((f a ≡ b) ∼ (a ≡ g b))}
--   {eq' : (a : A) (b : B) → ∞ ((f' a ≡ b) ∼ (a ≡ g' b))}
--   (r : (a : A) (b : B) →
--      transport (λ u → (u ≡ b) ∼ (a ≡ g' b)) (p a) (
--      transport (λ u → (f a ≡ b) ∼ (a ≡ u)) (q b) (♭ (eq a b)))
--      ≡ ♭ (eq' a b))
--   → (f , g , eq) ≡ (f' , g' , eq')
-- ∼-eq p q r = ∼-eq-raw (funext p) (funext q)
--   (funext (λ a → (funext (λ b → {!r a b!}))))

-- coherent : ∀ {i j} (A : Set i) (B : Set j) → ((A ≃ B) ≃ (A ∼ B))
-- coherent A B = (≃-to-∼ A B , iso-is-eq _ (∼-to-≃ A B)
--   (λ y → ∼-eq (λ a → refl _)
--               (λ b → happly (inverse-iso-is-eq (_∼_.to y) (_∼_.from y) _ _) b)
--               (λ a b → {!!}))
--   (λ e → Σ-eq (refl _) (π₁ (is-equiv-is-prop _ _ _))))


import SOAS.Syntax.Signature as Sig
open import SOAS.Families.Core

-- Term syntax for a signature
module SOAS.Syntax.Term
  {T : Set}(open Sig T)
  {O : Set}(S : Signature O) where

open import SOAS.Syntax.Arguments {T}
open import SOAS.Metatheory.Syntax {T}

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Variable
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Abstract.Hom

open import Categories.Object.Initial

open import Data.List.Base using (List ; [] ; [_] ; _∷_)
open import Data.Unit

open Signature S

private
  variable
    α β τ : T
    Γ Δ Π : Ctx

module _ (𝔛 : Familyₛ) where
  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  -- Grammar of terms for a (⅀,𝔛)-meta-algebra
  data 𝕋 : Familyₛ where
    con  : ⅀ 𝕋 τ Γ → 𝕋 τ Γ
    var  : ℐ τ Γ → 𝕋 τ Γ
    mvar : 𝔛 τ Π → Sub 𝕋 Π Γ → 𝕋 τ Γ

  Tmᵃ : MetaAlg 𝕋
  Tmᵃ = record { 𝑎𝑙𝑔 = con ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 ε → mvar 𝔪 (tabulate ε) }

  -- 𝕋 is the initial meta-algebra
  𝕋:Init : Initial 𝕄etaAlgebras
  𝕋:Init = record
    { ⊥ = 𝕋 ⋉ Tmᵃ
    ; ⊥-is-initial = record
      { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → (𝕤𝕖𝕞 𝒜ᵃ) ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
      ; !-unique = λ { {𝒜 ⋉ 𝒜ᵃ}(g ⋉ gᵃ⇒) {x = t} →  𝕤𝕖𝕞! 𝒜ᵃ gᵃ⇒ t } } }
    where
    module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where
      open MetaAlg 𝒜ᵃ
      𝕤𝕖𝕞 : 𝕋 ⇾̣ 𝒜
      𝔸 : (as : List (Ctx × T)) → Arg as 𝕋 Γ → Arg as 𝒜 Γ
      𝔸 [] tt = tt
      𝔸 (_ ∷ []) t = 𝕤𝕖𝕞 t
      𝔸 (_ ∷ a ∷ as) (t , ts) = (𝕤𝕖𝕞 t , 𝔸 (a ∷ as) ts)
      𝕊 : Sub 𝕋 Π Γ → Π ~[ 𝒜 ]↝ Γ
      𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
      𝕊 (t ◂ σ) (old v) = 𝕊 σ v
      𝕤𝕖𝕞 (con (o ⋮ a)) = 𝑎𝑙𝑔 (o ⋮ 𝔸 (Arity o) a)
      𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v
      𝕤𝕖𝕞 (mvar 𝔪 ε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 ε)

      𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ Tmᵃ 𝒜ᵃ 𝕤𝕖𝕞
      𝕤𝕖𝕞ᵃ⇒ = record
        { ⟨𝑎𝑙𝑔⟩ = λ{ {t = (o ⋮ a)} → cong (λ - → 𝑎𝑙𝑔 (o ⋮ -)) (𝔸-Arg₁ (Arity o) a) }
        ; ⟨𝑣𝑎𝑟⟩ = refl
        ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{ε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab ε)) }
        }
        where
        𝔸-Arg₁ : (as : List (Ctx × T))(a : Arg as 𝕋 Γ)
            → 𝔸 as a ≡ Arg₁ as 𝕤𝕖𝕞 a
        𝔸-Arg₁ [] tt = refl
        𝔸-Arg₁ (_ ∷ []) t = refl
        𝔸-Arg₁ (_ ∷ a ∷ as) (t , ap) = cong (_ ,_) (𝔸-Arg₁ (a ∷ as) ap)

        𝕊-tab : (ε : Π ~[ 𝕋 ]↝ Γ)(v : ℐ α Π)
              → 𝕊 (tabulate ε) v ≡ 𝕤𝕖𝕞 (ε v)
        𝕊-tab ε new = refl
        𝕊-tab ε (old v) = 𝕊-tab (ε ∘ old) v

      module _ {g : 𝕋 ⇾̣ 𝒜}(gᵃ⇒ : MetaAlg⇒ Tmᵃ 𝒜ᵃ g) where
        open MetaAlg⇒ gᵃ⇒

        𝕤𝕖𝕞! : (t : 𝕋 α Γ) → 𝕤𝕖𝕞 t ≡ g t
        𝕊-ix : (ε : Sub 𝕋 Π Γ)(v : ℐ α Π) → 𝕊 ε v ≡ g (index ε v)
        𝕊-ix (x ◂ ε) new = 𝕤𝕖𝕞! x
        𝕊-ix (x ◂ ε) (old v) = 𝕊-ix ε v
        𝔸-Arg₁ : (as : List (Ctx × T))(ar : Arg as 𝕋 Γ)
              → 𝔸 as ar ≡ Arg₁ as g ar
        𝔸-Arg₁ [] tt = refl
        𝔸-Arg₁ (_ ∷ []) t = 𝕤𝕖𝕞! t
        𝔸-Arg₁ (_ ∷ a ∷ as) (t , ap) = cong₂ _,_ (𝕤𝕖𝕞! t) (𝔸-Arg₁ (a ∷ as) ap)

        𝕤𝕖𝕞! (con (o ⋮ a)) rewrite 𝔸-Arg₁ (Arity o) a = sym ⟨𝑎𝑙𝑔⟩
        𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩
        𝕤𝕖𝕞! (mvar 𝔪 ε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix ε)) =
          trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id ε))

-- Syntax instance for a term grammar
𝕋:Syn : Syntax
𝕋:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; 𝕋:Init = 𝕋:Init
  ; mvarᵢ = mvar }


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

open import lib.Base

module lib.types.List where

data List {i} (A : Type i) : Type i where
  nil : List A
  _::_ : A → List A → List A

data HList {i} : List (Type i) → Type (lsucc i) where
  nil : HList nil
  _::_ : {A : Type i} {L : List (Type i)} → A → HList L → HList (A :: L)

hlist-curry-type : ∀ {i j} (L : List (Type i))
  (B : HList L → Type (lmax i j)) → Type (lmax i j)
hlist-curry-type nil B = B nil
hlist-curry-type {j = j} (A :: L) B =
  (x : A) → hlist-curry-type {j = j} L (λ xs → B (x :: xs))

hlist-curry : ∀ {i j} {L : List (Type i)} {B : HList L → Type (lmax i j)}
  (f : Π (HList L) B) → hlist-curry-type {j = j} L B
hlist-curry {L = nil} f = f nil
hlist-curry {L = A :: _} f = λ x → hlist-curry (λ xs → f (x :: xs))


open import Level
open import Relation.Binary.PropositionalEquality

import Categories.Category

open import Syntax

module Renaming where

  open Equality

  -- the set of renamings

  infix 5 _→ʳ_

  _→ʳ_ : VShape → VShape → Set
  γ →ʳ δ = var γ → var δ

  -- equality of renamings

  infix 5 _≡ʳ_

  _≡ʳ_ : ∀ {γ δ} → (ρ : γ →ʳ δ) → (t : γ →ʳ δ) → Set
  ρ ≡ʳ σ = ∀ x → ρ x ≡ σ x

  -- equality is an equivalence relation

  ≡ʳ-refl : ∀ {γ δ} → {ρ : γ →ʳ δ} → ρ ≡ʳ ρ
  ≡ʳ-refl x = refl

  ≡ʳ-sym : ∀ {γ δ} → {ρ τ : γ →ʳ δ} → ρ ≡ʳ τ → τ ≡ʳ ρ
  ≡ʳ-sym ξ x = sym (ξ x)

  ≡ʳ-trans : ∀ {γ δ} → {ρ τ χ : γ →ʳ δ} → ρ ≡ʳ τ → τ ≡ʳ χ → ρ ≡ʳ χ
  ≡ʳ-trans ζ ξ x = trans (ζ x) (ξ x)

  -- 𝟘 is the weakly initial shape

  𝟘-initial : ∀ {γ} → 𝟘 →ʳ γ
  𝟘-initial ()

  -- identity renaming

  𝟙ʳ : ∀ {γ} → γ →ʳ γ
  𝟙ʳ x = x

  -- composition of renamings

  infixl 7 _∘ʳ_

  _∘ʳ_ : ∀ {γ δ η} → (δ →ʳ η) → (γ →ʳ δ) → (γ →ʳ η)
  (ρ ∘ʳ τ) x =  ρ (τ x)

  -- join of renamings

  infix 6 [_,_]ʳ

  [_,_]ʳ : ∀ {γ δ η} → (γ →ʳ η) → (δ →ʳ η) → (γ ⊕ δ →ʳ η)
  [ ρ , τ ]ʳ (var-left x) = ρ x
  [ ρ , τ ]ʳ (var-right y) = τ y

  -- renaming extension
  ⇑ʳ : ∀ {γ δ η} → (γ →ʳ δ) → (γ ⊕ η →ʳ δ ⊕ η)
  ⇑ʳ ρ (var-left x) =  var-left (ρ x)
  ⇑ʳ ρ (var-right y) = var-right y

  -- extension preserves equality

  ⇑ʳ-resp-≡ʳ : ∀ {γ δ η} {ρ τ : γ →ʳ δ} → ρ ≡ʳ τ → ⇑ʳ {η = η} ρ ≡ʳ ⇑ʳ τ
  ⇑ʳ-resp-≡ʳ ξ (var-left x) = cong var-left (ξ x)
  ⇑ʳ-resp-≡ʳ ξ (var-right y) = refl

  -- extension respects identity

  ⇑ʳ-resp-𝟙ʳ : ∀ {γ δ} → ⇑ʳ {η = δ} (𝟙ʳ {γ = γ})  ≡ʳ 𝟙ʳ
  ⇑ʳ-resp-𝟙ʳ (var-left x) = refl
  ⇑ʳ-resp-𝟙ʳ (var-right x) = refl

  -- extension commutes with composition

  ⇑ʳ-resp-∘ʳ : ∀ {β γ δ η} {ρ : β →ʳ γ} {τ : γ →ʳ δ} → ⇑ʳ {η = η} (τ ∘ʳ ρ) ≡ʳ ⇑ʳ τ ∘ʳ ⇑ʳ ρ
  ⇑ʳ-resp-∘ʳ (var-left x) = refl
  ⇑ʳ-resp-∘ʳ (var-right y) = refl

  module _ {𝕊 : Signature} where
    open Expression 𝕊

    -- the action of a renaming on an expression

    infixr 6 [_]ʳ_

    [_]ʳ_ : ∀ {𝕄} {cl} {γ} {δ} (ρ : γ →ʳ δ) → Expr 𝕄 cl γ → Expr 𝕄 cl δ
    [ ρ ]ʳ (expr-var x) = expr-var (ρ x)
    [ ρ ]ʳ (expr-symb S es) = expr-symb S (λ i → [ ⇑ʳ ρ ]ʳ (es i))
    [ ρ ]ʳ (expr-meta M ts) = expr-meta M (λ i → [ ρ ]ʳ (ts i))
    [ ρ ]ʳ expr-eqty = expr-eqty
    [ ρ ]ʳ expr-eqtm = expr-eqtm

    -- the action respects equality of renamings and equality of terms

    []ʳ-resp-≈ : ∀ {𝕄} {cl} {γ} {δ} (ρ : γ →ʳ δ) {t u : Expr 𝕄 cl γ} → t ≈ u → [ ρ ]ʳ t ≈ [ ρ ]ʳ u
    []ʳ-resp-≈ ρ (≈-≡ ξ) = ≈-≡ (cong [ ρ ]ʳ_ ξ)
    []ʳ-resp-≈ ρ (≈-symb ξ) = ≈-symb (λ i → []ʳ-resp-≈ (⇑ʳ ρ) (ξ i))
    []ʳ-resp-≈ ρ (≈-meta ξ) = ≈-meta (λ i → []ʳ-resp-≈ ρ (ξ i))

    []ʳ-resp-≡ʳ : ∀ {𝕄} {cl} {γ} {δ} {ρ τ : γ →ʳ δ} (t : Expr cl 𝕄 γ) → ρ ≡ʳ τ → [ ρ ]ʳ t ≈ [ τ ]ʳ t
    []ʳ-resp-≡ʳ (expr-var x) ξ = ≈-≡ (cong expr-var (ξ x))
    []ʳ-resp-≡ʳ (expr-symb S es) ξ = ≈-symb (λ i → []ʳ-resp-≡ʳ (es i) (⇑ʳ-resp-≡ʳ ξ))
    []ʳ-resp-≡ʳ (expr-meta M ts) ξ = ≈-meta (λ i → []ʳ-resp-≡ʳ (ts i) ξ)
    []ʳ-resp-≡ʳ expr-eqty ξ = ≈-eqty
    []ʳ-resp-≡ʳ expr-eqtm ξ = ≈-eqtm

    -- the action is functorial

    [𝟙ʳ] : ∀ {cl 𝕄 γ} {t : Expr cl 𝕄 γ} → [ 𝟙ʳ ]ʳ t ≈ t
    [𝟙ʳ] {t = expr-var x} = ≈-refl
    [𝟙ʳ] {t = expr-symb S es} = ≈-symb (λ i → ≈-trans ([]ʳ-resp-≡ʳ (es i) ⇑ʳ-resp-𝟙ʳ) [𝟙ʳ])
    [𝟙ʳ] {t = expr-meta M ts} = ≈-meta (λ i → [𝟙ʳ])
    [𝟙ʳ] {t = expr-eqty} = ≈-eqty
    [𝟙ʳ] {t = expr-eqtm} = ≈-eqtm

    [∘ʳ] : ∀ {cl 𝕄} {γ δ η} {ρ : γ →ʳ δ} {τ : δ →ʳ η} (t : Expr cl 𝕄 γ) → [ τ ∘ʳ ρ ]ʳ t ≈ [ τ ]ʳ [ ρ ]ʳ t
    [∘ʳ] (expr-var x) = ≈-refl
    [∘ʳ] (expr-symb S es) = ≈-symb (λ i → ≈-trans ([]ʳ-resp-≡ʳ (es i) ⇑ʳ-resp-∘ʳ) ([∘ʳ] (es i)))
    [∘ʳ] (expr-meta M ts) = ≈-meta (λ i → [∘ʳ] (ts i))
    [∘ʳ] expr-eqty = ≈-eqty
    [∘ʳ] expr-eqtm = ≈-eqtm

    []ʳ-id : ∀ {cl 𝕄 γ} {ρ : γ →ʳ γ} {t : Expr cl 𝕄 γ} → ρ ≡ʳ 𝟙ʳ → [ ρ ]ʳ t ≈ t
    []ʳ-id ξ = ≈-trans ([]ʳ-resp-≡ʳ _ ξ) [𝟙ʳ]

  -- the categorical structure

  module _ where
    open Categories.Category

    Renamings : Category zero zero zero
    Renamings =
      record
        { Obj = VShape
        ; _⇒_ = _→ʳ_
        ; _≈_ = _≡ʳ_
        ; id = 𝟙ʳ
        ; _∘_ = _∘ʳ_
        ; assoc = λ _ → refl
        ; sym-assoc = λ _ → refl
        ; identityˡ = λ _ → refl
        ; identityʳ = λ _ → refl
        ; identity² = λ _ → refl
        ; equiv = record { refl = ≡ʳ-refl ; sym = ≡ʳ-sym ; trans = ≡ʳ-trans }
        ; ∘-resp-≈ = λ {_} {_} {_} {ρ} {_} {_} {τ} ζ ξ x → trans (cong ρ (ξ x)) (ζ (τ x))
        }


{-# OPTIONS --safe --without-K #-}
module Data.Fin.Relation.Binary.Closure where

open import Data.Fin
open import Data.Fin.Subset
open import Data.Fin.Subset.Dec
open import Data.Fin.Subset.Properties
open import Data.Fin.Subset.Properties.Dec
open import Data.Nat as ℕ using (ℕ)
open import Relation.Binary.Construct.Closure.Transitive
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.PropositionalEquality as Eq
open import Relation.Binary renaming (Decidable to Dec₂)
open import Function using (flip; _∘_; case_of_; _∋_)
open import Data.List as List using (List; _∷_; [])
open import Data.Sum
import Data.List.Membership.Propositional as Mem
open import Data.List.Membership.Propositional.Properties as MemP
open import Data.Product
open import Induction.Nat
open import Data.Vec using (Vec; []; _∷_; here)
open import Data.Vec.Properties
open import Data.Bool.Properties as B
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Data.Nat.Properties as ℕP
open import Function.Equivalence using (Equivalence)
open import Function.Equality using (_⟨$⟩_)

private
  iter : ∀ {a}{A : Set a} → (A → A) → A → ℕ → A
  iter f z ℕ.zero = z
  iter f z (ℕ.suc n) = f (iter f z n)
  _≟s_ : ∀ {n} → Dec₂ (_≡_{A = Subset n})
  _≟s_ = ≡-dec B._≟_
  p⊂q⇒∣p∣<∣q∣ : ∀ {n} {p q : Subset n} → p ⊆ q → p ≢ q → ∣ p ∣ ℕ.< ∣ q ∣
  p⊂q⇒∣p∣<∣q∣ {p = []} {[]} p⊆q p≢q = contradiction refl p≢q
  p⊂q⇒∣p∣<∣q∣ {p = outside ∷ p} {outside ∷ q} p⊆q p≢q = p⊂q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q) (p≢q ∘ cong (outside ∷_))
  p⊂q⇒∣p∣<∣q∣ {p = outside ∷ p} {inside ∷ q} p⊆q p≢q = ℕ.s≤s (p⊆q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q))
  p⊂q⇒∣p∣<∣q∣ {p = inside ∷ p} {outside ∷ q} p⊆q p≢q = contradiction (p⊆q here) λ ()
  p⊂q⇒∣p∣<∣q∣ {p = inside ∷ p} {inside ∷ q} p⊆q p≢q = ℕ.s≤s (p⊂q⇒∣p∣<∣q∣ (drop-∷-⊆ p⊆q) (p≢q ∘ cong (inside ∷_)))

  m<n⇒0<n : ∀ {m n} → m ℕ.< n → 0 ℕ.< n
  m<n⇒0<n (ℕ.s≤s m<n) = ℕ.s≤s ℕ.z≤n

  saturate : ∀ {n} → (f : Subset n → Subset n) → (∀ {s} → s ⊆ f s) → (z : Subset n) → iter f z n ≡ iter f z (ℕ.suc n)
  saturate {n} f p z = case rec P g n of
          λ { (inj₁ eq) → eq ;
               (inj₂ n<f) → contradiction n<f (≤⇒≯ (∣p∣≤n (f (iter f z n)))) }
    where
      open ℕP.≤-Reasoning
      P : ℕ → Set
      P n = iter f z n ≡ iter f z (ℕ.suc n) ⊎ n ℕ.< ∣ iter f z (ℕ.suc n) ∣

      g : ∀ n → Rec _ P n → P n
      g ℕ.zero _ with z ≟s f z
      ... | yes eq = inj₁ eq
      ... | no  z≢fz = inj₂ (m<n⇒0<n (p⊂q⇒∣p∣<∣q∣ p z≢fz))
      g (ℕ.suc n) (inj₁ eq) = inj₁ (cong f eq)
      g (ℕ.suc n) (inj₂ n<f) with f (iter f z n) ≟s f (iter f z (ℕ.suc n))
      ... | yes eq = inj₁ eq
      ... | no  neq = inj₂ (begin-strict ℕ.suc n <⟨ ℕ.s≤s n<f ⟩ _ ≤⟨ p⊂q⇒∣p∣<∣q∣ p neq ⟩ _ ∎)

  ∈-saturate : ∀ {n}(f : Subset n → Subset n)(p : ∀ {s} → s ⊆ f s) z {i} → (∃ λ m → i ∈ iter f z m) → i ∈ iter f z n
  ∈-saturate {n} f p z (m , i∈fm) with n ℕP.≤? m

  ... | yes n≤m rewrite sym (ℕP.m∸n+n≡m n≤m) = subst (_ ∈_) (sym (lemma (m ℕ.∸ n))) i∈fm
    where
      lemma : ∀ k → iter f z n ≡ iter f z (k ℕ.+ n)
      lemma 0 = refl
      lemma (ℕ.suc k) = trans (saturate f p z) (cong f (lemma k))

  ... | no n≰m  rewrite sym (ℕP.m∸n+n≡m (ℕP.≰⇒> n≰m)) = lemma (n ℕ.∸ ℕ.suc m) (p i∈fm)
    where
      lemma : ∀ k {m j} → j ∈ iter f z m → j ∈ iter f z (k ℕ.+ m)
      lemma 0 j∈fm = j∈fm
      lemma (ℕ.suc k) j∈fm = p (lemma k j∈fm)

module _ {n} where

  open import Data.List.Relation.Unary.Any

  ∈-⋃⁺ : ∀{s}{ss : List (Subset n)} → s Mem.∈ ss → ∀ {i} → i ∈ s → i ∈ ⋃ ss
  ∈-⋃⁺ {ss = []} () i∈s
  ∈-⋃⁺ {ss = s ∷ ss} (here refl) i∈s = x∈p∪q⁺ (inj₁ i∈s)
  ∈-⋃⁺ {ss = _ ∷ ss} (there s∈ss) i∈s = x∈p∪q⁺ (inj₂ (∈-⋃⁺ s∈ss i∈s))

  ∈-⋃⁻ : ∀{ss : List (Subset n)}{i} → i ∈ ⋃ ss → ∃ λ s → i ∈ s × s Mem.∈ ss
  ∈-⋃⁻ {[]} i∈ss = contradiction i∈ss ∉⊥
  ∈-⋃⁻ {s ∷ ss} i∈ss with x∈p∪q⁻ _ _ i∈ss
  ∈-⋃⁻ {s ∷ ss} i∈ss | inj₁ i∈s = s , i∈s , here refl
  ∈-⋃⁻ {_ ∷ ss} i∈ss | inj₂ i∈rest with ∈-⋃⁻ {ss} i∈rest
  ... | s , i∈s , s∈ss = s , i∈s , there s∈ss

module _ {p n}{P : Rel (Fin n) p} where
  right-image : Dec₂ P → Fin n → Subset n
  right-image P? i = subset (P? i)

  left-image  : Dec₂ P → Fin n → Subset n
  left-image P? i = subset (flip P? i)

  _◃_ : Subset n → Dec₂ P → Subset n
  s ◃ P? = ⋃ (List.map (right-image P?) (List.filter (_∈? s) (List.allFin _)))

  _▹_ :  Dec₂ P → Subset n → Subset n
  P? ▹ s = ⋃ (List.map (left-image P?) (List.filter (_∈? s) (List.allFin _)))

  _∪▹_ : Dec₂ P → Subset n →  Subset n
  P? ∪▹ s = s ∪ (P? ▹ s)

  ∪▹-monotone : (P? : Dec₂ P) → ∀ {s} → s ⊆ P? ∪▹ s
  ∪▹-monotone P? {s} = p⊆p∪q (P? ▹ s)

  ∈-▹⁺ : ∀ {i s j}(P? : Dec₂ P) → j ∈ s → P i j → i ∈ P? ▹ s
  ∈-▹⁺ {i}{s}{j} P? i∈s pij = ∈-⋃⁺ (∈-map⁺ (left-image P?) (∈-filter⁺ (_∈? s) (∈-allFin _) i∈s))  (∈subset⁺ (flip P? j) pij)

  ∈-▹⁻ : ∀ {i s}(P? : Dec₂ P) → i ∈ P? ▹ s → ∃ λ j → j ∈ s × P i j
  ∈-▹⁻ {i}{s} P? i∈s with ∈-⋃⁻ {ss = List.map (left-image P?) (List.filter (_∈? s) (List.allFin _))} i∈s
  ... | P▹s , i∈P▹s , P▹s∈ss with ∈-map⁻ _ P▹s∈ss
  ... | j , j∈l , eq rewrite eq with ∈-filter⁻  (_∈? s) {xs = List.allFin _} j∈l
  ... | _ , j∈s         = j ,  j∈s , ∈subset⁻ (flip P? j) i∈P▹s

  iter-∪▹ : Subset n → (P? : Dec₂ P) → ℕ → Subset n
  iter-∪▹ z P? = iter (P? ∪▹_) z

  ▹-star : (P? : Dec₂ P) → Fin n → ℕ → Subset n
  ▹-star P? i = iter-∪▹ ⁅ i ⁆ P?

  ▹-plus : (P? : Dec₂ P) → Fin n → ℕ → Subset n
  ▹-plus P? j = iter-∪▹ (left-image P? j) P?

  ∈-▹-star⁺ : (P? : Dec₂ P) → ∀ {i j} → Star P i j → i ∈ ▹-star P? j n
  ∈-▹-star⁺ P? {i}{j} pij = ∈-saturate _ (∪▹-monotone P?) ⁅ j ⁆ (rec Q g (length pij) pij refl)
    where
       length : ∀ {i j} → Star P i j → ℕ
       length ε = 0
       length (_ ◅ r) = 1 ℕ.+ length r

       Q : ℕ → Set _
       Q m = ∀ {i j} → (r : Star P i j) → length r ≡ m → ∃ λ k → i ∈ ▹-star P? j k

       g : ∀ m → Rec _ Q m → Q m
       g .0 ih ε refl = 0 , x∈⁅x⁆ _
       g .(ℕ.suc (length rkj)) ih (pik ◅ rkj) refl with ih rkj refl
       ... | k , i∈fk = 1 ℕ.+ k , x∈p∪q⁺ (inj₂ (∈-▹⁺ P? i∈fk pik))

  ∈-▹-star⁻ : (P? : Dec₂ P) → ∀ {i j} m → i ∈ ▹-star P? j m → Star P i j
  ∈-▹-star⁻ P? {i} {j} ℕ.zero h rewrite x∈⁅y⁆⇒x≡y _ h = ε
  ∈-▹-star⁻ P? {i} {j} (ℕ.suc m) h with x∈p∪q⁻ _ _ h
  ... | inj₁ h₁ = ∈-▹-star⁻ P? m h₁
  ... | inj₂ h₁  with ∈-▹⁻ P? h₁
  ... | k , k∈s , pik = pik ◅ ∈-▹-star⁻ P? m k∈s

  ∈-▹-plus⁺ : (P? : Dec₂ P) → ∀ {i j} → Plus′ P i j → i ∈ ▹-plus P? j n
  ∈-▹-plus⁺ P? {i}{j} pij = ∈-saturate _ (∪▹-monotone P?) (left-image P? j) (rec Q g (length pij) pij refl)
     where
       length : ∀ {i j} → Plus′ P i j → ℕ
       length [ x∼y ] = 0
       length (x∼y ∷ r) = 1 ℕ.+ length r

       Q : ℕ → Set _
       Q m = ∀ {i j} → (r : Plus′ P i j) → length r ≡ m → ∃ λ k → i ∈ ▹-plus P? j k

       g : ∀ m → Rec _ Q m → Q m
       g ℕ.zero ih {i}{j} [ pij ] refl = 0 , ∈subset⁺ (flip P? j) pij
       g (ℕ.suc .(length r)) ih {i}{j} (pik ∷ r) refl with ih r refl
       ... | k , i∈fk = 1 ℕ.+ k , x∈p∪q⁺ (inj₂ (∈-▹⁺ P? i∈fk pik))

  ∈-▹-plus⁻ : (P? : Dec₂ P) → ∀ {i j} m → i ∈ ▹-plus P? j m → Plus′ P i j
  ∈-▹-plus⁻ P? {i} {j} ℕ.zero h = [ ∈subset⁻ (flip P? j) h ]
  ∈-▹-plus⁻ P? {i} {j} (ℕ.suc m) h with x∈p∪q⁻ _ _ h
  ∈-▹-plus⁻ P? {i} {j} (ℕ.suc m) h | inj₁ h₁  = ∈-▹-plus⁻ P? m h₁
  ∈-▹-plus⁻ P? {i} {j} (ℕ.suc m) h | inj₂ h₁  with ∈-▹⁻ P? h₁
  ... | k , k∈s , pik = pik ∷ ∈-▹-plus⁻ P? m k∈s

  -- Derived decidability of closures

  dec-Star : (P? : Dec₂ P) → Dec₂ (Star P)
  dec-Star P? i j with i ∈? ▹-star P? j n
  ... | yes i∈star = yes (∈-▹-star⁻ P? n i∈star)
  ... | no i∉star  = no λ h → contradiction (∈-▹-star⁺ P? h) i∉star

  dec-Plus′ : (P? : Dec₂ P) → Dec₂ (Plus′ P)
  dec-Plus′ P? i j with i ∈? ▹-plus P? j n
  ... | yes i∈plus = yes (∈-▹-plus⁻ P? n i∈plus)
  ... | no i∉plus  = no λ h → contradiction (∈-▹-plus⁺ P? h) i∉plus

  dec-Plus : (P? : Dec₂ P) → Dec₂ (Plus P)
  dec-Plus P? i j with dec-Plus′ P? i j
  ... | yes pij′ = yes (Equivalence.from equivalent ⟨$⟩ pij′)
  ... | no ¬pij′ = no λ pij → ¬pij′ (Equivalence.to equivalent ⟨$⟩ pij)


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

open import Fragment.Equational.Theory

module Fragment.Equational.Model.Synthetic (Θ : Theory) where

open import Fragment.Algebra.Signature
open import Fragment.Algebra.Algebra (Σ Θ)
open import Fragment.Algebra.Free (Σ Θ)
open import Fragment.Algebra.Homomorphism (Σ Θ)
open import Fragment.Algebra.Quotient (Σ Θ)
open import Fragment.Equational.Model.Base Θ
  using (Model; IsModel; Models)
open import Fragment.Setoid.Morphism using (_·_)

open import Level using (Level; _⊔_)
open import Function using (_∘_)

open import Data.Empty using (⊥)
open import Data.Nat using (ℕ)
open import Data.Product using (proj₁; proj₂)
open import Data.Vec using (map)
open import Data.Vec.Relation.Binary.Pointwise.Inductive
  using (Pointwise; []; _∷_)

open import Relation.Binary using (Setoid; IsEquivalence)
import Relation.Binary.PropositionalEquality as PE

private
  variable
    a ℓ : Level

module _ (A : Algebra {a} {ℓ}) where

  infix 4 _≊_

  data _≊_ : ∥ A ∥ → ∥ A ∥ → Set (a ⊔ ℓ) where
    refl    : ∀ {x} → x ≊ x
    sym     : ∀ {x y} → x ≊ y → y ≊ x
    trans   : ∀ {x y z} → x ≊ y → y ≊ z → x ≊ z
    inherit : ∀ {x y} → x =[ A ] y → x ≊ y
    cong    : ∀ {n} → (f : ops (Σ Θ) n)
              → ∀ {xs ys} → Pointwise _≊_ xs ys
              → A ⟦ f ⟧ xs ≊ A ⟦ f ⟧ ys
    axiom   : ∀ {n} → (eq : eqs Θ n) → (θ : Env A n)
              → ∣ inst A θ ∣ (proj₁ (Θ ⟦ eq ⟧ₑ))
                ≊ ∣ inst A θ ∣ (proj₂ (Θ ⟦ eq ⟧ₑ))

  private

    ≊-isEquivalence : IsEquivalence _≊_
    ≊-isEquivalence = record { refl  = refl
                             ; sym   = sym
                             ; trans = trans
                             }

  instance
    ≊-isDenom : IsDenominator A _≊_
    ≊-isDenom = record { isEquivalence = ≊-isEquivalence
                       ; isCompatible  = cong
                       ; isCoarser     = inherit
                       }

  Synthetic : Model
  Synthetic = record { ∥_∥/≈   = ∥ A ∥/ _≊_
                     ; isModel = isModel
                     }
    where open module T = Setoid (∥ A ∥/ _≊_)
          open import Relation.Binary.Reasoning.Setoid (∥ A ∥/ _≊_)

          models : Models (A / _≊_)
          models eq θ = begin
              ∣ inst (A / _≊_) θ ∣ lhs
            ≈⟨ T.sym (lemma {x = lhs}) ⟩
              ∣ (inc A _≊_) ⊙ (inst A θ) ∣ lhs
            ≈⟨ axiom eq θ ⟩
              ∣ (inc A _≊_) ⊙ (inst A θ) ∣ rhs
            ≈⟨ lemma {x = rhs} ⟩
              ∣ inst (A / _≊_) θ ∣ rhs
            ∎
            where lhs = proj₁ (Θ ⟦ eq ⟧ₑ)
                  rhs = proj₂ (Θ ⟦ eq ⟧ₑ)
                  lemma = inst-universal (A / _≊_) θ
                              {h = (inc A _≊_) ⊙ (inst A θ) }
                              (λ x → PE.refl)

          isModel : IsModel (∥ A ∥/ _≊_)
          isModel = record { isAlgebra = A / _≊_ -isAlgebra
                           ; models    = models
                           }

J : ℕ → Model
J = Synthetic ∘ F


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

Properties of nullary relations, i.e. structures on types.

Includes several results from [Notions of Anonymous Existence in Martin-Löf Type Theory](https://lmcs.episciences.org/3217)
by Altenkirch, Coquand, Escardo, Kraus.

-}
module Cubical.Relation.Nullary.Properties where

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

open import Cubical.Data.Empty as ⊥

open import Cubical.Relation.Nullary.Base
open import Cubical.HITs.PropositionalTruncation.Base

private
  variable
    ℓ : Level
    A : Type ℓ

IsoPresDiscrete : ∀ {ℓ ℓ'}{A : Type ℓ} {B : Type ℓ'} → Iso A B
               → Discrete A → Discrete B
IsoPresDiscrete e dA x y with dA (Iso.inv e x) (Iso.inv e y)
... | yes p = subst Dec (λ i → Iso.rightInv e x i ≡ Iso.rightInv e y i)
                        (yes (cong (Iso.fun e) p))
... | no p = subst Dec (λ i → Iso.rightInv e x i ≡ Iso.rightInv e y i)
                   (no λ q → p (sym (Iso.leftInv e (Iso.inv e x))
                     ∙∙ cong (Iso.inv e) q
                     ∙∙ Iso.leftInv e (Iso.inv e y)))

EquivPresDiscrete : ∀ {ℓ ℓ'}{A : Type ℓ} {B : Type ℓ'} → A ≃ B
               → Discrete A → Discrete B
EquivPresDiscrete e = IsoPresDiscrete (equivToIso e)

isProp¬ : (A : Type ℓ) → isProp (¬ A)
isProp¬ A p q i x = isProp⊥ (p x) (q x) i

Stable¬ : Stable (¬ A)
Stable¬ ¬¬¬a a = ¬¬¬a ¬¬a
  where
  ¬¬a = λ ¬a → ¬a a

fromYes : A → Dec A → A
fromYes _ (yes a) = a
fromYes a (no _) = a

discreteDec : (Adis : Discrete A) → Discrete (Dec A)
discreteDec Adis (yes p) (yes p') = decideYes (Adis p p') -- TODO: monad would simply stuff
  where
    decideYes : Dec (p ≡ p') → Dec (yes p ≡ yes p')
    decideYes (yes eq) = yes (cong yes eq)
    decideYes (no ¬eq) = no λ eq → ¬eq (cong (fromYes p) eq)
discreteDec Adis (yes p) (no ¬p) = ⊥.rec (¬p p)
discreteDec Adis (no ¬p) (yes p) = ⊥.rec (¬p p)
discreteDec {A = A} Adis (no ¬p) (no ¬p') = yes (cong no (isProp¬ A ¬p ¬p'))

isPropDec : (Aprop : isProp A) → isProp (Dec A)
isPropDec Aprop (yes a) (yes a') = cong yes (Aprop a a')
isPropDec Aprop (yes a) (no ¬a) = ⊥.rec (¬a a)
isPropDec Aprop (no ¬a) (yes a) = ⊥.rec (¬a a)
isPropDec {A = A} Aprop (no ¬a) (no ¬a') = cong no (isProp¬ A ¬a ¬a')

mapDec : ∀ {B : Type ℓ} → (A → B) → (¬ A → ¬ B) → Dec A → Dec B
mapDec f _ (yes p) = yes (f p)
mapDec _ f (no ¬p) = no (f ¬p)

EquivPresDec : ∀ {ℓ ℓ'}{A : Type ℓ} {B : Type ℓ'} → A ≃ B
          → Dec A → Dec B
EquivPresDec p = mapDec (p .fst) (λ f → f ∘ invEq p)

¬→¬∥∥ : ¬ A → ¬ ∥ A ∥
¬→¬∥∥ ¬p ∣ a ∣ = ¬p a
¬→¬∥∥ ¬p (squash x y i) = isProp⊥ (¬→¬∥∥ ¬p x) (¬→¬∥∥ ¬p y) i

Dec∥∥ : Dec A → Dec ∥ A ∥
Dec∥∥ = mapDec ∣_∣ ¬→¬∥∥

-- we have the following implications
-- X ── ∣_∣ ─→ ∥ X ∥
-- ∥ X ∥ ── populatedBy ─→ ⟪ X ⟫
-- ⟪ X ⟫ ── notEmptyPopulated ─→ NonEmpty X

-- reexport propositional truncation for uniformity
open Cubical.HITs.PropositionalTruncation.Base
  using (∣_∣) public

populatedBy : ∥ A ∥ → ⟪ A ⟫
populatedBy {A = A} a (f , fIsConst) = h a where
  h : ∥ A ∥ → Fixpoint f
  h ∣ a ∣ = f a , fIsConst (f a) a
  h (squash a b i) = 2-Constant→isPropFixpoint f fIsConst (h a) (h b) i

notEmptyPopulated : ⟪ A ⟫ → NonEmpty A
notEmptyPopulated {A = A} pop u = u (fixpoint (pop (h , hIsConst))) where
  h : A → A
  h a = ⊥.elim (u a)
  hIsConst : ∀ x y → h x ≡ h y
  hIsConst x y i = ⊥.elim (isProp⊥ (u x) (u y) i)

-- these implications induce the following for different kinds of stability, gradually weakening the assumption
Dec→Stable : Dec A → Stable A
Dec→Stable (yes x) = λ _ → x
Dec→Stable (no x) = λ f → ⊥.elim (f x)

Stable→PStable : Stable A → PStable A
Stable→PStable st = st ∘ notEmptyPopulated

PStable→SplitSupport : PStable A → SplitSupport A
PStable→SplitSupport pst = pst ∘ populatedBy

-- Although SplitSupport and Collapsible are not properties, their path versions, HSeparated and Collapsible≡, are.
-- Nevertheless they are logically equivalent
SplitSupport→Collapsible : SplitSupport A → Collapsible A
SplitSupport→Collapsible {A = A} hst = h , hIsConst where
  h : A → A
  h p = hst ∣ p ∣
  hIsConst : 2-Constant h
  hIsConst p q i = hst (squash ∣ p ∣ ∣ q ∣ i)

Collapsible→SplitSupport : Collapsible A → SplitSupport A
Collapsible→SplitSupport f x = fixpoint (populatedBy x f)

HSeparated→Collapsible≡ : HSeparated A → Collapsible≡ A
HSeparated→Collapsible≡ hst x y = SplitSupport→Collapsible (hst x y)

Collapsible≡→HSeparated : Collapsible≡ A → HSeparated A
Collapsible≡→HSeparated col x y = Collapsible→SplitSupport (col x y)

-- stability of path space under truncation or path collapsability are necessary and sufficient properties
-- for a a type to be a set.
Collapsible≡→isSet : Collapsible≡ A → isSet A
Collapsible≡→isSet {A = A} col a b p q = p≡q where
  f : (x : A) → a ≡ x → a ≡ x
  f x = col a x .fst
  fIsConst : (x : A) → (p q : a ≡ x) → f x p ≡ f x q
  fIsConst x = col a x .snd
  rem : (p : a ≡ b) → PathP (λ i → a ≡ p i) (f a refl) (f b p)
  rem p j = f (p j) (λ i → p (i ∧ j))
  p≡q : p ≡ q
  p≡q j i = hcomp (λ k → λ { (i = i0) → f a refl k
                           ; (i = i1) → fIsConst b p q j k
                           ; (j = i0) → rem p i k
                           ; (j = i1) → rem q i k }) a

HSeparated→isSet : HSeparated A → isSet A
HSeparated→isSet = Collapsible≡→isSet ∘ HSeparated→Collapsible≡

isSet→HSeparated : isSet A → HSeparated A
isSet→HSeparated setA x y = extract where
  extract : ∥ x ≡ y ∥ → x ≡ y
  extract ∣ p ∣ = p
  extract (squash p q i) = setA x y (extract p) (extract q) i

-- by the above more sufficient conditions to inhibit isSet A are given
PStable≡→HSeparated : PStable≡ A → HSeparated A
PStable≡→HSeparated pst x y = PStable→SplitSupport (pst x y)

PStable≡→isSet : PStable≡ A → isSet A
PStable≡→isSet = HSeparated→isSet ∘ PStable≡→HSeparated

Separated→PStable≡ : Separated A → PStable≡ A
Separated→PStable≡ st x y = Stable→PStable (st x y)

Separated→isSet : Separated A → isSet A
Separated→isSet = PStable≡→isSet ∘ Separated→PStable≡

-- Proof of Hedberg's theorem: a type with decidable equality is an h-set
Discrete→Separated : Discrete A → Separated A
Discrete→Separated d x y = Dec→Stable (d x y)

Discrete→isSet : Discrete A → isSet A
Discrete→isSet = Separated→isSet ∘ Discrete→Separated


postulate
  A : Set
  a : A

data D : A → Set where
  d : (a : A) → D a

f : A → (D a → Set) → Set
f a f = f (d a)

-- Bad error:
-- a != a of type A
-- when checking that the pattern d a has type D a

-- Better error:
-- a != a of type A
-- (because one is a variable and one a defined identifier)
-- when checking that the pattern d a has type D a


module SN.AntiRename where

open import Relation.Unary using (_∈_; _⊆_)

open import Library
open import Terms
open import Substitution
open import SN

mutual

  -- To formulate this, we need heterogeneous SNholes, going from Γ to Δ

  -- unRenameSNh : ∀{a b Γ Δ} (ρ : Δ ≤ Γ) {t : Tm Γ b} {E : ECxt Γ a b} {t' : Tm Γ a} →
  --   SNhole (subst ρ t) (λ t' → subst ρ (E t')) t' → SNhole t E t'
  -- unRenameSNh = TODO

  unRenameSNe : ∀{a Γ Δ} {ρ : Δ ≤ Γ} {t : Tm Γ a}{t'} → IndRen ρ t t' →
                SNe t' → SNe t
  unRenameSNe (var x x₁)     (var y)           = var x
  unRenameSNe (app is is₁)   (elim 𝒏 (appl 𝒖)) = elim (unRenameSNe is 𝒏) (appl (unRenameSN is₁ 𝒖))

  unRenameSN : ∀{a Γ Δ} {ρ : Δ ≤ Γ} {t : Tm Γ a} {t'} → IndRen ρ t t'
    → SN t' → SN t
  -- neutral cases:
  unRenameSN n           (ne 𝒏)       = ne (unRenameSNe n 𝒏)
  -- redex cases:
  unRenameSN is           (exp t⇒ 𝒕)   = exp (unRename⇒1 is t⇒) (unRenameSN (proj₂ (unRename⇒0 is t⇒)) 𝒕)
  -- constructor cases:
  unRenameSN (abs t)      (abs 𝒕)      = abs (unRenameSN t 𝒕)

  unRename⇒0 : ∀{a Γ Δ} {ρ : Δ ≤ Γ} {t : Tm Γ a} {t' : Tm Δ a}{tρ} → IndRen ρ t tρ
              → tρ ⟨ _ ⟩⇒ t' → Σ _ \ s → IndRen ρ s t'
  unRename⇒0 {ρ = ρ} (app {u = u} (abs {t = t} is) is₁)  (β 𝒖)  = _ , prop→Ind ρ (≡.trans (≡.sym (sgs-lifts-term {σ = ρ} {u = u} {t = t}))
                                                                      (≡.cong₂ (λ t₁ u₁ → subst (sgs u₁) t₁) (Ind→prop _ is) (Ind→prop _ is₁)))
  unRename⇒0 (app is is₁)        (cong (appl u) (appl .u) tρ→t') = let s , iss = unRename⇒0 is tρ→t' in app s _ , app iss is₁

  unRename⇒1 : ∀{a Γ Δ} {ρ : Δ ≤ Γ} {t : Tm Γ a} {t' : Tm Δ a}{tρ} → (is : IndRen ρ t tρ)
              → (t⇒ : tρ ⟨ _ ⟩⇒ t') → t ⟨ _  ⟩⇒ proj₁ (unRename⇒0 is t⇒)
  unRename⇒1 (app (abs is) is₁) (β 𝒖) = β (unRenameSN is₁ 𝒖)
  unRename⇒1 (app is is₁)        (cong (appl u) (appl .u) tρ→t') = cong (appl _) (appl _) (unRename⇒1 is tρ→t')

-- Extensionality of SN for function types:
-- If t x ∈ SN then t ∈ SN.

absVarSNe : ∀{Γ a b}{t : Tm (a ∷ Γ) (a →̂ b)} → app t (var (zero)) ∈ SNe → t ∈ SNe
absVarSNe (elim 𝒏 (appl 𝒖)) = 𝒏

absVarSN : ∀{Γ a b}{t : Tm (a ∷ Γ) (a →̂ b)} → app t (var (zero)) ∈ SN → t ∈ SN
absVarSN (ne 𝒖)                                                   = ne (absVarSNe 𝒖)
absVarSN (exp (β {t = t} 𝒖) 𝒕′)                                   = abs (unRenameSN (prop→Ind contract (subst-ext contract-sgs t)) 𝒕′)
absVarSN (exp (cong (appl ._) (appl ._) t⇒) 𝒕′) = exp t⇒ (absVarSN 𝒕′)


------------------------------------------------------------------------
-- Normalisation by evaluation
------------------------------------------------------------------------

import Axiom.Extensionality.Propositional as E
import Level
open import Data.Universe

-- The code makes use of the assumption that propositional equality of
-- functions is extensional.

module README.DependentlyTyped.NBE
  (Uni₀ : Universe Level.zero Level.zero)
  (ext : E.Extensionality Level.zero Level.zero)
  where

open import Data.Empty
open import Data.Product renaming (curry to c)
open import deBruijn.Substitution.Data
open import Function hiding (_∋_) renaming (const to k)
import README.DependentlyTyped.NormalForm as NF
open NF Uni₀ renaming ([_] to [_]n)
import README.DependentlyTyped.Term as Term; open Term Uni₀
import README.DependentlyTyped.Term.Substitution as S; open S Uni₀
import Relation.Binary.PropositionalEquality as P
open import Relation.Nullary using (¬_)

open P.≡-Reasoning

-- The values that are used by the NBE algorithm.

import README.DependentlyTyped.NBE.Value as Value
open Value Uni₀ public

-- Weakening for the values.

import README.DependentlyTyped.NBE.Weakening as Weakening
open Weakening Uni₀ ext public

-- Application.

infix 9 [_]_·̌_

[_]_·̌_ : ∀ {Γ sp₁ sp₂} σ →
         V̌alue Γ (π sp₁ sp₂ , σ) → (v : V̌alue Γ (fst σ)) →
         V̌alue Γ (snd σ /̂ ŝub ⟦̌ v ⟧)
[ _ ] f ·̌ v = proj₁ f ε v

abstract

  -- Lifting can be expressed using žero.

  ∘̂-ŵk-▻̂-žero : ∀ {Γ Δ} (ρ̂ : Γ ⇨̂ Δ) σ →
                ρ̂ ∘̂ ŵk ▻̂[ σ ] ⟦ žero _ (proj₂ σ /̂I ρ̂) ⟧n ≅-⇨̂ ρ̂ ↑̂ σ
  ∘̂-ŵk-▻̂-žero ρ̂ σ = begin
    [ ρ̂ ∘̂ ŵk ▻̂ ⟦ žero _ _ ⟧n ]  ≡⟨ ▻̂-cong P.refl P.refl (ňeutral-to-normal-identity _ (var zero)) ⟩
    [ ρ̂ ∘̂ ŵk ▻̂ ⟦ var zero ⟧  ]  ≡⟨ P.refl ⟩
    [ ρ̂ ↑̂                    ]  ∎

mutual

  -- Evaluation.

  eval : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} →
         Γ ⊢ σ → Sub V̌al ρ̂ → V̌alue Δ (σ /̂ ρ̂)
  eval (var x)   ρ = x /∋ ρ
  eval (ƛ t)     ρ = (eval[ƛ t ] ρ) , eval[ƛ t ] ρ well-behaved
  eval (t₁ · t₂) ρ = eval[ t₁ · t₂ ] ρ

  -- Some abbreviations.

  eval[ƛ_] : ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} →
             Γ ▻ σ ⊢ τ → Sub V̌al ρ̂ → V̌alue-π Δ _ _ (IType-π σ τ /̂I ρ̂)
  eval[ƛ t ] ρ Γ₊ v = eval t (V̌al-subst.wk-subst₊ Γ₊ ρ ▻ v)

  eval[_·_] : ∀ {Γ Δ sp₁ sp₂ σ} {ρ̂ : Γ ⇨̂ Δ} →
              Γ ⊢ (π sp₁ sp₂ , σ) → (t₂ : Γ ⊢ fst σ) → Sub V̌al ρ̂ →
              V̌alue Δ (snd σ /̂ ŝub ⟦ t₂ ⟧ ∘̂ ρ̂)
  eval[_·_] {σ = σ} t₁ t₂ ρ =
    cast ([ σ /I ρ ] eval t₁ ρ ·̌ eval t₂ ρ)
    where
    cast = P.subst (λ v → V̌alue _ (snd σ /̂ ⟦ ρ ⟧⇨ ↑̂ /̂ ŝub v))
                   (≅-Value-⇒-≡ $ P.sym $ eval-lemma t₂ ρ)

  abstract

    -- The ƛ case is well-behaved.

    eval[ƛ_]_well-behaved :
      ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ▻ σ ⊢ τ) (ρ : Sub V̌al ρ̂) →
      W̌ell-behaved _ _ (IType-π σ τ /I ρ) (eval[ƛ t ] ρ)
    eval[ƛ_]_well-behaved {σ = σ} {τ = τ} t ρ Γ₊ v =
      let υ  = IType-π σ τ /I ρ in begin
      [ (⟦̌ υ ∣ eval[ƛ t ] ρ ⟧-π /̂Val ŵk₊ Γ₊) ˢ ⟦̌ v ⟧ ]  ≡⟨ ˢ-cong (/̂Val-cong (P.sym $ eval-lemma-ƛ t ρ) P.refl) P.refl ⟩
      [ (c ⟦ t ⟧ /̂Val ⟦ ρ ⟧⇨ ∘̂ ŵk₊ Γ₊) ˢ ⟦̌ v ⟧       ]  ≡⟨ P.refl ⟩
      [ ⟦ t ⟧ /̂Val (⟦ ρ ⟧⇨ ∘̂ ŵk₊ Γ₊ ▻̂ ⟦̌ v ⟧)         ]  ≡⟨ eval-lemma t _ ⟩
      [ ⟦̌ eval t (V̌al-subst.wk-subst₊ Γ₊ ρ ▻ v) ⟧    ]  ∎

    -- An unfolding lemma.

    eval-· :
      ∀ {Γ Δ sp₁ sp₂ σ} {ρ̂ : Γ ⇨̂ Δ}
      (t₁ : Γ ⊢ π sp₁ sp₂ , σ) (t₂ : Γ ⊢ fst σ) (ρ : Sub V̌al ρ̂) →
      eval[ t₁ · t₂ ] ρ ≅-V̌alue [ σ /I ρ ] eval t₁ ρ ·̌ eval t₂ ρ
    eval-· {σ = σ} t₁ t₂ ρ =
      drop-subst-V̌alue (λ v → snd σ /̂ ⟦ ρ ⟧⇨ ↑̂ /̂ ŝub v)
                       (≅-Value-⇒-≡ $ P.sym $ eval-lemma t₂ ρ)

    -- The evaluator is correct (with respect to the standard
    -- semantics).

    eval-lemma : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢ σ) (ρ : Sub V̌al ρ̂) →
                 ⟦ t ⟧ /Val ρ ≅-Value ⟦̌ eval t ρ ⟧
    eval-lemma (var x)             ρ = V̌al-subst./̂∋-⟦⟧⇨ x ρ
    eval-lemma (ƛ t)               ρ = eval-lemma-ƛ t ρ
    eval-lemma (_·_ {σ = σ} t₁ t₂) ρ = begin
      [ ⟦ t₁ · t₂ ⟧ /Val ρ                           ]  ≡⟨ P.refl ⟩
      [ (⟦ t₁ ⟧ /Val ρ) ˢ (⟦ t₂ ⟧ /Val ρ)            ]  ≡⟨ ˢ-cong (eval-lemma t₁ ρ) (eval-lemma t₂ ρ) ⟩
      [ ⟦̌_⟧ {σ = σ /I ρ} (eval t₁ ρ) ˢ ⟦̌ eval t₂ ρ ⟧ ]  ≡⟨ proj₂ (eval t₁ ρ) ε (eval t₂ ρ) ⟩
      [ ⟦̌ [ σ /I ρ ] eval t₁ ρ ·̌ eval t₂ ρ ⟧         ]  ≡⟨ ⟦̌⟧-cong (P.sym $ eval-· t₁ t₂ ρ) ⟩
      [ ⟦̌ eval[ t₁ · t₂ ] ρ ⟧                        ]  ∎

    private

      eval-lemma-ƛ :
        ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ▻ σ ⊢ τ) (ρ : Sub V̌al ρ̂) →
        ⟦ ƛ t ⟧ /Val ρ ≅-Value ⟦̌ IType-π σ τ /I ρ ∣ eval[ƛ t ] ρ ⟧-π
      eval-lemma-ƛ {σ = σ} {τ = τ} t ρ =
        let υ  = IType-π σ τ /I ρ
            ρ↑ = V̌al-subst.wk-subst₊ (σ / ρ ◅ ε) ρ ▻ v̌ar ⊙ zero

        in begin
        [ c ⟦ t ⟧ /Val ρ          ]  ≡⟨ P.refl ⟩
        [ c (⟦ t ⟧ /̂Val ⟦ ρ ⟧⇨ ↑̂) ]  ≡⟨ curry-cong $ /̂Val-cong (P.refl {x = [ ⟦ t ⟧ ]})
                                                                         (P.sym $ ∘̂-ŵk-▻̂-žero ⟦ ρ ⟧⇨ _) ⟩
        [ c (⟦ t ⟧ /Val ρ↑)       ]  ≡⟨ curry-cong (eval-lemma t ρ↑) ⟩
        [ c ⟦̌ eval t ρ↑ ⟧         ]  ≡⟨ P.sym $ unfold-⟦̌∣⟧-π υ (eval[ƛ t ] ρ) ⟩
        [ ⟦̌ υ ∣ eval[ƛ t ] ρ ⟧-π  ]  ∎

-- Normalisation.

normalise : ∀ {Γ σ} → Γ ⊢ σ → Γ ⊢ σ ⟨ no ⟩
normalise t = řeify _ (eval t V̌al-subst.id)

-- Normalisation is semantics-preserving.

normalise-lemma : ∀ {Γ σ} (t : Γ ⊢ σ) → ⟦ t ⟧ ≅-Value ⟦ normalise t ⟧n
normalise-lemma t = eval-lemma t V̌al-subst.id

-- Some congruence lemmas.

·̌-cong :
  ∀ {Γ₁ sp₁₁ sp₂₁ σ₁}
    {f₁ : V̌alue Γ₁ (π sp₁₁ sp₂₁ , σ₁)} {v₁ : V̌alue Γ₁ (fst σ₁)}
    {Γ₂ sp₁₂ sp₂₂ σ₂}
    {f₂ : V̌alue Γ₂ (π sp₁₂ sp₂₂ , σ₂)} {v₂ : V̌alue Γ₂ (fst σ₂)} →
  σ₁ ≅-IType σ₂ → _≅-V̌alue_ {σ₁ = -, σ₁} f₁ {σ₂ = -, σ₂} f₂ →
  v₁ ≅-V̌alue v₂ →
  [ σ₁ ] f₁ ·̌ v₁ ≅-V̌alue [ σ₂ ] f₂ ·̌ v₂
·̌-cong P.refl P.refl P.refl = P.refl

eval-cong :
  ∀ {Γ₁ Δ₁ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {t₁ : Γ₁ ⊢ σ₁} {ρ₁ : Sub V̌al ρ̂₁}
    {Γ₂ Δ₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {t₂ : Γ₂ ⊢ σ₂} {ρ₂ : Sub V̌al ρ̂₂} →
  t₁ ≅-⊢ t₂ → ρ₁ ≅-⇨ ρ₂ → eval t₁ ρ₁ ≅-V̌alue eval t₂ ρ₂
eval-cong P.refl P.refl = P.refl

normalise-cong :
  ∀ {Γ₁ σ₁} {t₁ : Γ₁ ⊢ σ₁}
    {Γ₂ σ₂} {t₂ : Γ₂ ⊢ σ₂} →
  t₁ ≅-⊢ t₂ → normalise t₁ ≅-⊢n normalise t₂
normalise-cong P.refl = P.refl

abstract

  -- Note that we can /not/ prove that normalise takes semantically
  -- equal terms to identical normal forms, assuming extensionality
  -- and the existence of a universe code which decodes to an empty
  -- type:

  normal-forms-not-unique :
    E.Extensionality Level.zero Level.zero →
    (∃ λ (bot : U₀) → ¬ El₀ bot) →
    ¬ (∀ {Γ σ} (t₁ t₂ : Γ ⊢ σ) →
       ⟦ t₁ ⟧ ≅-Value ⟦ t₂ ⟧ → normalise t₁ ≅-⊢n normalise t₂)
  normal-forms-not-unique ext (bot , empty) hyp = ⊥-elim (x₁≇x₂ x₁≅x₂)
    where
    Γ : Ctxt
    Γ = ε ▻ (⋆ , _) ▻ (⋆ , _) ▻ (el , k bot)

    x₁ : Γ ∋ (⋆ , _)
    x₁ = suc (suc zero)

    x₂ : Γ ∋ (⋆ , _)
    x₂ = suc zero

    x₁≇x₂ : ¬ (ne ⋆ (var x₁) ≅-⊢n ne ⋆ (var x₂))
    x₁≇x₂ ()

    ⟦x₁⟧≡⟦x₂⟧ : ⟦ var x₁ ⟧ ≅-Value ⟦ var x₂ ⟧
    ⟦x₁⟧≡⟦x₂⟧ = P.cong [_] (ext λ γ → ⊥-elim $ empty $ proj₂ γ)

    norm-x₁≅norm-x₂ : normalise (var x₁) ≅-⊢n normalise (var x₂)
    norm-x₁≅norm-x₂ = hyp (var x₁) (var x₂) ⟦x₁⟧≡⟦x₂⟧

    lemma : (x : Γ ∋ (⋆ , _)) → normalise (var x) ≅-⊢n ne ⋆ (var x)
    lemma x = begin
      [ normalise (var x)        ]n  ≡⟨ P.refl ⟩
      [ ne ⋆ (x /∋ V̌al-subst.id) ]n  ≡⟨ ne-cong $ ≅-Value-⋆-⇒-≅-⊢n $ V̌al-subst./∋-id x ⟩
      [ ne ⋆ (var x)             ]n  ∎

    x₁≅x₂ : ne ⋆ (var x₁) ≅-⊢n ne ⋆ (var x₂)
    x₁≅x₂ = begin
      [ ne ⋆ (var x₁)      ]n  ≡⟨ P.sym $ lemma x₁ ⟩
      [ normalise (var x₁) ]n  ≡⟨ norm-x₁≅norm-x₂ ⟩
      [ normalise (var x₂) ]n  ≡⟨ lemma x₂ ⟩
      [ ne ⋆ (var x₂)      ]n  ∎