------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on the Stream type
------------------------------------------------------------------------

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

module Codata.Stream.Properties where

open import Level using (Level)
open import Size
open import Codata.Thunk as Thunk using (Thunk; force)
open import Codata.Stream
open import Codata.Stream.Bisimilarity

open import Data.Nat.Base
open import Data.Nat.GeneralisedArithmetic using (fold; fold-pull)

open import Data.List.Base as List using ([]; _∷_)
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_)
import Data.List.Relation.Binary.Equality.Propositional as Eq
open import Data.Product as Prod using (_,_)
open import Data.Vec.Base as Vec using (_∷_)

open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

private
  variable
    a b c : Level
    A : Set a
    B : Set b
    C : Set c
    i : Size

------------------------------------------------------------------------
-- repeat

lookup-repeat-identity : (n : ℕ) (a : A) → lookup n (repeat a) ≡ a
lookup-repeat-identity zero    a = P.refl
lookup-repeat-identity (suc n) a = lookup-repeat-identity n a

take-repeat-identity : (n : ℕ) (a : A) → take n (repeat a) ≡ Vec.replicate a
take-repeat-identity zero    a = P.refl
take-repeat-identity (suc n) a = P.cong (a Vec.∷_) (take-repeat-identity n a)

splitAt-repeat-identity : (n : ℕ) (a : A) → splitAt n (repeat a) ≡ (Vec.replicate a , repeat a)
splitAt-repeat-identity zero    a = P.refl
splitAt-repeat-identity (suc n) a = P.cong (Prod.map₁ (a ∷_)) (splitAt-repeat-identity n a)

replicate-repeat : ∀ {i} (n : ℕ) (a : A) → i ⊢ List.replicate n a ++ repeat a ≈ repeat a
replicate-repeat zero    a = refl
replicate-repeat (suc n) a = P.refl ∷ λ where .force → replicate-repeat n a

cycle-replicate : ∀ {i} (n : ℕ) (n≢0 : n ≢ 0) (a : A) → i ⊢ cycle (List⁺.replicate n n≢0 a) ≈ repeat a
cycle-replicate {i} n n≢0 a = let as = List⁺.replicate n n≢0 a in begin
  cycle as                           ≡⟨⟩
  as ⁺++ _                           ≈⟨ ⁺++⁺ Eq.≋-refl (λ where .force → cycle-replicate n n≢0 a) ⟩
  as ⁺++ (λ where .force → repeat a) ≈⟨ P.refl ∷ (λ where .force → replicate-repeat (pred n) a) ⟩
  repeat a                           ∎ where open ≈-Reasoning

module _ {a b} {A : Set a} {B : Set b} where

  map-repeat : ∀ (f : A → B) a {i} → i ⊢ map f (repeat a) ≈ repeat (f a)
  map-repeat f a = P.refl ∷ λ where .force → map-repeat f a

  ap-repeat : ∀ (f : A → B) a {i} → i ⊢ ap (repeat f) (repeat a) ≈ repeat (f a)
  ap-repeat f a = P.refl ∷ λ where .force → ap-repeat f a

  ap-repeatˡ : ∀ (f : A → B) as {i} → i ⊢ ap (repeat f) as ≈ map f as
  ap-repeatˡ f (a ∷ as) = P.refl ∷ λ where .force → ap-repeatˡ f (as .force)

  ap-repeatʳ : ∀ (fs : Stream (A → B) ∞) (a : A) {i} → i ⊢ ap fs (repeat a) ≈ map (_$ a) fs
  ap-repeatʳ (f ∷ fs) a = P.refl ∷ λ where .force → ap-repeatʳ (fs .force) a

  map-++ : ∀ {i} (f : A → B) as xs → i ⊢ map f (as ++ xs) ≈ List.map f as ++ map f xs
  map-++ f []       xs = refl
  map-++ f (a ∷ as) xs = P.refl ∷ λ where .force → map-++ f as xs

  map-⁺++ : ∀ {i} (f : A → B) as xs → i ⊢ map f (as ⁺++ xs) ≈ List⁺.map f as ⁺++ Thunk.map (map f) xs
  map-⁺++ f (a ∷ as) xs = P.refl ∷ (λ where .force → map-++ f as (xs .force))

  map-cycle : ∀ {i} (f : A → B) as → i ⊢ map f (cycle as) ≈ cycle (List⁺.map f as)
  map-cycle f as = begin
    map f (cycle as)       ≈⟨ map-⁺++ f as _ ⟩
    List⁺.map f as ⁺++ _   ≈⟨ ⁺++⁺ Eq.≋-refl (λ where .force → map-cycle f as) ⟩
    cycle (List⁺.map f as) ∎ where open ≈-Reasoning

------------------------------------------------------------------------
-- Functor laws

map-identity : ∀ (as : Stream A ∞) → i ⊢ map id as ≈ as
map-identity (a ∷ as) = P.refl ∷ λ where .force → map-identity (as .force)

map-map-fusion : ∀ (f : A → B) (g : B → C) as → i ⊢ map g (map f as) ≈ map (g ∘ f) as
map-map-fusion f g (a ∷ as) = P.refl ∷ λ where .force → map-map-fusion f g (as .force)

------------------------------------------------------------------------
-- splitAt

splitAt-map : ∀ n (f : A → B) xs →
  splitAt n (map f xs) ≡ Prod.map (Vec.map f) (map f) (splitAt n xs)
splitAt-map zero    f xs       = P.refl
splitAt-map (suc n) f (x ∷ xs) =
  P.cong (Prod.map₁ (f x Vec.∷_)) (splitAt-map n f (xs .force))

------------------------------------------------------------------------
-- iterate

lookup-iterate-identity : ∀ n f (a : A) → lookup n (iterate f a) ≡ fold a f n
lookup-iterate-identity zero     f a = P.refl
lookup-iterate-identity (suc n)  f a = begin
  lookup (suc n) (iterate f a) ≡⟨⟩
  lookup n (iterate f (f a))   ≡⟨ lookup-iterate-identity n f (f a) ⟩
  fold (f a) f n               ≡⟨ fold-pull (const ∘′ f) (f a) P.refl (λ _ → P.refl) n ⟩
  f (fold a f n)               ≡⟨⟩
  fold a f (suc n)             ∎ where open P.≡-Reasoning

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.1

repeat-ap-identity = ap-repeatˡ
{-# WARNING_ON_USAGE repeat-ap-identity
"Warning: repeat-ap-identity was deprecated in v1.1.
Please use ap-repeatˡ instead."
#-}

ap-repeat-identity = ap-repeatʳ
{-# WARNING_ON_USAGE ap-repeat-identity
"Warning: ap-repeat-identity was deprecated in v1.1.
Please use ap-repeatʳ instead."
#-}

ap-repeat-commute = ap-repeat
{-# WARNING_ON_USAGE ap-repeat-commute
"Warning: ap-repeat-commute was deprecated in v1.1.
Please use ap-repeat instead."
#-}

map-repeat-commute = map-repeat
{-# WARNING_ON_USAGE map-repeat-commute
"Warning: map-repeat-commute was deprecated in v1.1.
Please use map-repeat instead."
#-}


module PiFrac.Properties where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Maybe
open import PiFrac.Syntax
open import PiFrac.Opsem
open import PiFrac.AuxLemmas
open import PiFrac.NoRepeat
open import PiFrac.Eval
open import PiFrac.Interp
open import PiFrac.Invariants

-- Forward evaluator is reversible
evalIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : ⟦ A ⟧) (v₂ : ⟦ B ⟧)
          → eval c v₁ ≡ (just v₂) → evalᵣₑᵥ c v₂ ≡ (just v₁)
evalIsRev c v₁ v₂ eq with ev {κ = ☐} c v₁
evalIsRev c v₁ v₂ refl | inj₁ (v₂ , rs) with evᵣₑᵥ {κ = ☐} c v₂
... | inj₁ (v₁' , rs') with deterministicᵣₑᵥ* rs' (Rev↦ rs) (λ ()) (λ ()) (λ ())
... | refl = refl
evalIsRev c v₁ v₂ refl | inj₁ (v₂ , rs) | inj₂ (_ , v , _ , _ , neq , rs') with deterministicᵣₑᵥ* rs' (Rev↦ rs) (λ ()) (Lemma₆ neq) (λ ())
... | ()

-- Backward evaluator is reversible
evalᵣₑᵥIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : ⟦ B ⟧) (v₂ : ⟦ A ⟧)
             → evalᵣₑᵥ c v₁ ≡ (just v₂) → eval c v₂ ≡ (just v₁)
evalᵣₑᵥIsRev c v₁ v₂ eq with evᵣₑᵥ {κ = ☐} c v₁
evalᵣₑᵥIsRev c v₁ v₂ refl | inj₁ (v₂ , rs) with ev {κ = ☐} c v₂
... | inj₁ (_ , rs') with deterministic* rs' (Rev↦ᵣₑᵥ rs) (λ ()) (λ ())
... | refl = refl
evalᵣₑᵥIsRev c v₁ v₂ refl | inj₁ (v₂ , rs) | inj₂ rs' with deterministic* rs' (Rev↦ᵣₑᵥ rs) (λ ()) (λ ())
... | ()

-- The abstract machine semantics is equivalent to the big-step semantics
eval≡interp : ∀ {A B} → (c : A ↔ B) → (v : ⟦ A ⟧) → eval c v ≡ interp c v
eval≡interp uniti₊l v = refl
eval≡interp unite₊l (inj₂ v) = refl
eval≡interp swap₊ (inj₁ x) = refl
eval≡interp swap₊ (inj₂ y) = refl
eval≡interp assocl₊ (inj₁ x) = refl
eval≡interp assocl₊ (inj₂ (inj₁ y)) = refl
eval≡interp assocl₊ (inj₂ (inj₂ z)) = refl
eval≡interp assocr₊ (inj₁ (inj₁ x)) = refl
eval≡interp assocr₊ (inj₁ (inj₂ y)) = refl
eval≡interp assocr₊ (inj₂ z) = refl
eval≡interp unite⋆l (tt , v) = refl
eval≡interp uniti⋆l v = refl
eval≡interp swap⋆ (x , y) = refl
eval≡interp assocl⋆ (x , (y , z)) = refl
eval≡interp assocr⋆ ((x , y) , z) = refl
eval≡interp dist (inj₁ x , z) = refl
eval≡interp dist (inj₂ y , z) = refl
eval≡interp factor (inj₁ (x , z)) = refl
eval≡interp factor (inj₂ (y , z)) = refl
eval≡interp id↔ v = refl
eval≡interp (c₁ ⨾ c₂) v with ev {κ = ☐} c₁ v | inspect (ev {κ = ☐} c₁) v
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] with ev {κ = ☐} c₂ v' | inspect (ev {κ = ☐} c₂) v'
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₁ (v'' , rs') | [ eq' ] with ev {κ = ☐} (c₁ ⨾ c₂) v | inspect (ev {κ = ☐} (c₁ ⨾ c₂)) v
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₁ (v'' , rs') | [ eq' ] | inj₁ (u , rs'') | [ eq'' ] rewrite (sym (eval≡interp c₁ v)) | eq | (sym (eval≡interp c₂ v')) | eq' with deterministic* ((↦₃ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⨾ c₂ • ☐) ++↦ (↦₇ ∷ ◾) ++↦ appendκ↦* rs' (λ ()) (λ ()) refl (c₁ ⨾☐• ☐) ++↦ (↦₁₀ ∷ ◾)) rs'' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₁ (v'' , rs') | [ eq' ] | inj₂ rs'' | [ eq'' ] rewrite (sym (eval≡interp c₁ v)) | eq | (sym (eval≡interp c₂ v')) | eq' with deterministic* ((↦₃ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⨾ c₂ • ☐) ++↦ (↦₇ ∷ ◾) ++↦ appendκ↦* rs' (λ ()) (λ ()) refl (c₁ ⨾☐• ☐) ++↦ (↦₁₀ ∷ ◾)) rs'' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₂ rs' | [ eq' ] with ev {κ = ☐} (c₁ ⨾ c₂) v | inspect (ev {κ = ☐} (c₁ ⨾ c₂)) v
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₂ rs' | [ eq' ] | inj₁ (u , rs'') | [ eq'' ] rewrite (sym (eval≡interp c₁ v)) | eq | (sym (eval≡interp c₂ v')) | eq' with deterministic* ((↦₃ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⨾ c₂ • ☐) ++↦ (↦₇ ∷ ◾) ++↦ appendκ↦*⊠ rs' (λ ()) (c₁ ⨾☐• ☐)) rs'' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⨾ c₂) v | inj₁ (v' , rs) | [ eq ] | inj₂ rs' | [ eq' ] | inj₂ rs'' | [ eq'' ] rewrite (sym (eval≡interp c₁ v)) | eq | (sym (eval≡interp c₂ v')) | eq' = refl
eval≡interp (c₁ ⨾ c₂) v | inj₂ rs | [ eq ] with ev {κ = ☐} (c₁ ⨾ c₂) v | inspect (ev {κ = ☐} (c₁ ⨾ c₂)) v
eval≡interp (c₁ ⨾ c₂) v | inj₂ rs | [ eq ] | inj₁ (v'' , rs') | [ eq' ] with deterministic* ((↦₃ ∷ ◾) ++↦ appendκ↦*⊠ rs (λ ()) (☐⨾ c₂ • ☐)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⨾ c₂) v | inj₂ rs | [ eq ] | inj₂ rs' | [ eq' ] rewrite (sym (eval≡interp c₁ v)) | eq = refl
eval≡interp (c₁ ⊕ c₂) (inj₁ x) with ev {κ = ☐} c₁ x | inspect (ev {κ = ☐} c₁) x
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₁ (x' , rs) | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₁ x) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₁ x)
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₁ (x' , rs) | [ eq ] | inj₁ (x'' , rs') | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq with deterministic* ((↦₄ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ (↦₁₁ ∷ ◾)) rs' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₁ (x' , rs) | [ eq ] | inj₂ rs' | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq with deterministic* ((↦₄ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ (↦₁₁ ∷ ◾)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₂ rs | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₁ x) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₁ x)
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₂ rs | [ eq ] | inj₁ (x'' , rs') | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq with deterministic* ((↦₄ ∷ ◾) ++↦ appendκ↦*⊠ rs (λ ()) (☐⊕ c₂ • ☐)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊕ c₂) (inj₁ x) | inj₂ rs | [ eq ] | inj₂ rs' | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq = refl
eval≡interp (c₁ ⊕ c₂) (inj₂ y) with ev {κ = ☐} c₂ y | inspect (ev {κ = ☐} c₂) y
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₁ (y' , rs) | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₂ y) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₂ y)
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₁ (y' , rs) | [ eq ] | inj₁ (y'' , rs') | [ eq' ] rewrite (sym (eval≡interp c₂ y)) | eq with deterministic* ((↦₅ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ (↦₁₂ ∷ ◾)) rs' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₁ (y' , rs) | [ eq ] | inj₂ rs'         | [ eq' ] rewrite (sym (eval≡interp c₂ y)) | eq with deterministic* ((↦₅ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ (↦₁₂ ∷ ◾)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₂ rs        | [ eq ] with ev {κ = ☐} (c₁ ⊕ c₂) (inj₂ y) | inspect (ev {κ = ☐} (c₁ ⊕ c₂)) (inj₂ y)
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₂ rs        | [ eq ] | inj₁ (y'' , rs') | [ eq' ] rewrite (sym (eval≡interp c₂ y)) | eq with deterministic* ((↦₅ ∷ ◾) ++↦ appendκ↦*⊠ rs (λ ()) (c₁ ⊕☐• ☐)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊕ c₂) (inj₂ y) | inj₂ rs        | [ eq ] | inj₂ rs'         | [ eq' ] rewrite (sym (eval≡interp c₂ y)) | eq = refl
eval≡interp (c₁ ⊗ c₂) (x , y) with ev {κ = ☐} c₁ x | inspect (ev {κ = ☐} c₁) x
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] with ev {κ = ☐} c₂ y | inspect (ev {κ = ☐} c₂) y
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₁ (y' , rs') | [ eq' ] with ev {κ = ☐} (c₁ ⊗ c₂) (x , y) | inspect (ev {κ = ☐} (c₁ ⊗ c₂)) (x , y)
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₁ (y' , rs') | [ eq' ] | inj₁ (_ , rs'') | [ eq'' ] rewrite (sym (eval≡interp c₁ x)) | eq | (sym (eval≡interp c₂ y)) | eq' with deterministic* (((↦₆ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐)) ++↦ (↦₈ ∷ ◾) ++↦ appendκ↦* rs' (λ ()) (λ ()) refl ([ c₁ , x' ]⊗☐• ☐) ++↦ (↦₉ ∷ ◾)) rs'' (λ ()) (λ ())
... | refl = refl
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₁ (y' , rs') | [ eq' ] | inj₂ rs''       | [ eq'' ] rewrite (sym (eval≡interp c₁ x)) | eq | (sym (eval≡interp c₂ y)) | eq' with deterministic* (((↦₆ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐)) ++↦ (↦₈ ∷ ◾) ++↦ appendκ↦* rs' (λ ()) (λ ()) refl ([ c₁ , x' ]⊗☐• ☐) ++↦ (↦₉ ∷ ◾)) rs'' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₂ rs'        | [ eq' ] with ev {κ = ☐} (c₁ ⊗ c₂) (x , y) | inspect (ev {κ = ☐} (c₁ ⊗ c₂)) (x , y)
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₂ rs'        | [ eq' ] | inj₁ (y' , rs'') | [ eq'' ] rewrite (sym (eval≡interp c₁ x)) | eq | (sym (eval≡interp c₂ y)) | eq' with deterministic* (((↦₆ ∷ ◾) ++↦ appendκ↦* rs (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐)) ++↦ (↦₈ ∷ ◾) ++↦ appendκ↦*⊠ rs' (λ ()) ([ c₁ , x' ]⊗☐• ☐)) rs'' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₁ (x' , rs) | [ eq ] | inj₂ rs'        | [ eq' ] | inj₂ rs''        | [ eq'' ] rewrite (sym (eval≡interp c₁ x)) | eq | (sym (eval≡interp c₂ y)) | eq' = refl
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₂ rs        | [ eq ] with ev {κ = ☐} (c₁ ⊗ c₂) (x , y) | inspect (ev {κ = ☐} (c₁ ⊗ c₂)) (x , y)
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₂ rs        | [ eq ] | inj₁ (_ , rs') | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq with deterministic* ((↦₆ ∷ ◾) ++↦ appendκ↦*⊠ rs (λ ()) (☐⊗[ c₂ , y ]• ☐)) rs' (λ ()) (λ ())
... | ()
eval≡interp (c₁ ⊗ c₂) (x , y) | inj₂ rs        | [ eq ] | inj₂ rs''      | [ eq' ] rewrite (sym (eval≡interp c₁ x)) | eq = refl
eval≡interp (ηₓ v) tt = refl
eval≡interp (εₓ v) (v' , ↻) with v ≟ v'
... | yes refl = refl
... | no  _    = refl

-- !c is the inverse computation of c
interp! : ∀ {A B} (c : A ↔ B) (a : ⟦ A ⟧) (b : ⟦ B ⟧) → interp c a ≡ just b → interp (! c) b ≡ just a
interp! unite₊l (inj₂ y) .y refl = refl
interp! uniti₊l y .(inj₂ y) refl = refl
interp! swap₊ (inj₁ x) .(inj₂ x) refl = refl
interp! swap₊ (inj₂ y) .(inj₁ y) refl = refl
interp! assocl₊ (inj₁ x) .(inj₁ (inj₁ x)) refl = refl
interp! assocl₊ (inj₂ (inj₁ y)) .(inj₁ (inj₂ y)) refl = refl
interp! assocl₊ (inj₂ (inj₂ z)) .(inj₂ z) refl = refl
interp! assocr₊ (inj₁ (inj₁ x)) .(inj₁ x) refl = refl
interp! assocr₊ (inj₁ (inj₂ y)) .(inj₂ (inj₁ y)) refl = refl
interp! assocr₊ (inj₂ z) .(inj₂ (inj₂ z)) refl = refl
interp! unite⋆l (tt , v) .v refl = refl
interp! uniti⋆l v .(tt , v) refl = refl
interp! swap⋆ (x , y) .(y , x) refl = refl
interp! assocl⋆ (x , y , z) .((x , y) , z) refl = refl
interp! assocr⋆ ((x , y) , z) .(x , y , z) refl = refl
interp! dist (inj₁ x , z) .(inj₁ (x , z)) refl = refl
interp! dist (inj₂ y , z) .(inj₂ (y , z)) refl = refl
interp! factor (inj₁ (x , z)) .(inj₁ x , z) refl = refl
interp! factor (inj₂ (y , z)) .(inj₂ y , z) refl = refl
interp! id↔ v .v refl = refl
interp! (c₁ ⨾ c₂) a c eq with interp c₁ a | inspect (interp c₁) a
... | just b  | [ eq₁ ] with interp c₂ b | inspect (interp c₂) b
... | just c' | [ eq₂ ] with eq
... | refl rewrite interp! c₂ b c eq₂ | interp! c₁ a b eq₁ = refl
interp! (c₁ ⊕ c₂) (inj₁ x) b eq with interp c₁ x | inspect (interp c₁) x
... | just x' | [ eqx ] with b
... | inj₁ _ with eq
... | refl rewrite interp! c₁ x x' eqx = refl
interp! (c₁ ⊕ c₂) (inj₂ y) b eq with interp c₂ y | inspect (interp c₂) y
... | just y' | [ eqy ] with b
... | inj₂ _ with eq
... | refl rewrite interp! c₂ y y' eqy = refl
interp! (c₁ ⊗ c₂) (x , y) (x' , y') eq with interp c₁ x | inspect (interp c₁) x | interp c₂ y | inspect (interp c₂) y
... | just x'' | [ eqx ] | just y'' | [ eqy ] with eq
... | refl rewrite interp! c₁ x x' eqx | interp! c₂ y y' eqy = refl
interp! (ηₓ v) tt .(v , ↻) refl with v ≟ v
... | yes refl = refl
... | no  neq  = ⊥-elim (neq refl)
interp! (εₓ v) (v' , ↻) b eq with v ≟ v'
... | yes refl = refl
interp! (εₓ _) (v' , ↻) b () | no neq


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

module Data.ByteString.Primitive.Int where

open import Agda.Builtin.Nat using (Nat)

{-# FOREIGN GHC import qualified Data.Int #-}
postulate
  Int : Set
  Int64 : Set
  IntToℕ : Int → Nat
  ℕToInt : Nat → Int
  int64Toℕ : Int64 → Nat
  ℕToInt64 : Nat → Int64
{-# COMPILE GHC Int = type (Prelude.Int) #-}
{-# COMPILE GHC Int64 = type (Data.Int.Int64) #-}
{-# COMPILE GHC IntToℕ = (Prelude.fromIntegral) #-}
{-# COMPILE GHC ℕToInt = (Prelude.fromIntegral) #-}
{-# COMPILE GHC int64Toℕ = (Prelude.fromIntegral) #-}
{-# COMPILE GHC ℕToInt64 = (Prelude.fromIntegral) #-}


------------------------------------------------------------------------
-- Coinductive higher lenses with erased "proofs"
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

import Equality.Path as P

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

open P.Derived-definitions-and-properties eq

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

import Colimit.Sequential.Very-erased eq as CS
open import Equality.Decidable-UIP equality-with-J using (Constant)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Equivalence.Erased.Cubical eq as EEq using (_≃ᴱ_)
open import Equivalence.Erased.Contractible-preimages.Cubical eq
  using (_⁻¹ᴱ_)
open import Erased.Cubical eq
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional.Erased eq as T
  using (∥_∥ᴱ; ∣_∣)
import H-level.Truncation.Propositional.Non-recursive.Erased eq as N
open import H-level.Truncation.Propositional.One-step eq as O
  using (∣_∣; ∥_∥¹-out-^; ∥_∥¹-in-^; ∣_,_∣-in-^)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher.Erased eq as Higher
import Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant eq
  as V
open import Lens.Non-dependent.Higher.Coherently.Coinductive eq
import Lens.Non-dependent.Higher.Coinductive eq as C
import Lens.Non-dependent.Higher.Coinductive.Small eq as S

private
  variable
    a b p : Level
    A B   : Type a
    n     : ℕ

------------------------------------------------------------------------
-- The lemma ∥∥ᴱ→≃

private

  -- A lemma used in the implementation of ∥∥ᴱ→≃.
  --
  -- This definition is erased because its implementation makes use of
  -- code related to O.∥_∥¹ (a HIT with a non-erased higher
  -- constructor).

  @0 ∥∥ᴱ→≃-lemma :
    Block "∥∥ᴱ→≃-lemma" →
    (f₀ : A → B) →
    (∃ λ (f₊ : ∀ n → ∥ A ∥¹-out-^ (1 + n) → B) →
       (∀ x → f₊ zero ∣ x ∣ ≡ f₀ x) ×
       (∀ n x → f₊ (suc n) ∣ x ∣ ≡ f₊ n x)) ≃
    (∃ λ (f₊ : ∀ n → ∥ A ∥¹-in-^ (1 + n) → B) →
       (∀ x → f₊ zero ∣ x ∣ ≡ f₀ x) ×
       (∀ n x → f₊ (suc n) ∣ n , x ∣-in-^ ≡ f₊ n x))
  ∥∥ᴱ→≃-lemma ⊠ _ =
    inverse $
    Σ-cong {k₁ = equivalence}
      (∀-cong ext λ n →
       →-cong₁ ext (inverse $ O.∥∥¹-out-^≃∥∥¹-in-^ (suc n))) λ f →
    ∃-cong λ _ → ∀-cong ext λ n →
    Π-cong-contra ext (O.∥∥¹-out-^≃∥∥¹-in-^ (suc n)) λ x →
    ≡⇒≃ $ cong (λ y → f (suc n) y ≡
                      f n (_≃_.to (O.∥∥¹-out-^≃∥∥¹-in-^ (suc n)) x)) $
    sym $ O.∣∣≡∣,∣-in-^ (1 + n)

-- Functions from ∥ A ∥ᴱ can be expressed as coherently constant
-- functions from A with erased "proofs" (assuming univalence).

∥∥ᴱ→≃ :
  Block "∥∥ᴱ→≃" →
  {A : Type a} {B : Type b} →
  @0 Univalence (a ⊔ b) →
  (∥ A ∥ᴱ → B)
    ≃
  (∃ λ (f : A → B) → Erased (C.Coherently-constant f))
∥∥ᴱ→≃ bl {A = A} {B = B} univ =
  (∥ A ∥ᴱ → B)                                                 ↝⟨ →-cong ext T.∥∥ᴱ≃∥∥ᴱ F.id ⟩

  (N.∥ A ∥ᴱ → B)                                               ↝⟨ CS.universal-property ⟩

  (∃ λ (f₀ : A → B) →
     Erased (∃ λ (f₊ : ∀ n → ∥ A ∥¹-out-^ (1 + n) → B) →
               (∀ x → f₊ zero ∣ x ∣ ≡ f₀ x) ×
               (∀ n x → f₊ (suc n) ∣ x ∣ ≡ f₊ n x)))           ↝⟨ ∃-cong (λ f → Erased-cong (∥∥ᴱ→≃-lemma bl f)) ⟩

  (∃ λ (f₀ : A → B) →
     Erased (∃ λ (f₊ : ∀ n → ∥ A ∥¹-in-^ (1 + n) → B) →
               (∀ x → f₊ zero ∣ x ∣ ≡ f₀ x) ×
               (∀ n x → f₊ (suc n) ∣ n , x ∣-in-^ ≡ f₊ n x)))  ↝⟨ ∃-cong (λ f → Erased-cong (inverse $
                                                                  C.Coherently-constant′≃ bl)) ⟩

  (∃ λ (f : A → B) → Erased (C.Coherently-constant′ f))        ↝⟨ ∃-cong (λ f → Erased-cong (inverse $
                                                                  C.Coherently-constant≃Coherently-constant′ bl univ)) ⟩□
  (∃ λ (f : A → B) → Erased (C.Coherently-constant f))         □

-- A "computation" rule for ∥∥ᴱ→≃.

@0 cong-from-∥∥ᴱ→≃-truncation-is-proposition :
  (bl : Block "∥∥ᴱ→≃")
  {A : Type a} {B : Type b}
  (univ : Univalence (a ⊔ b)) →
  {f : A → B} {c : C.Coherently-constant f}
  {x y : A} {p : ∣ x ∣ ≡ ∣ y ∣} →
  cong (_≃_.from (∥∥ᴱ→≃ bl univ) (f , [ c ])) p ≡
  c .property x y
cong-from-∥∥ᴱ→≃-truncation-is-proposition
  bl {A = A} univ {f = f} {c = c} {x = x} {y = y} {p = p} =
  cong (_≃_.from (∥∥ᴱ→≃ bl univ) (f , [ c ])) p                         ≡⟨⟩

  cong (_≃_.from CS.universal-property (f , [ g bl ]) ∘
        _≃_.to T.∥∥ᴱ≃∥∥ᴱ)
    p                                                                   ≡⟨ sym $ cong-∘ _ _ _ ⟩

  (cong (_≃_.from CS.universal-property (f , [ g bl ])) $
   cong (_≃_.to T.∥∥ᴱ≃∥∥ᴱ) p)                                           ≡⟨ cong (cong _) $ mono₁ 1 N.∥∥ᴱ-proposition _ _ ⟩

  cong (_≃_.from CS.universal-property (f , [ g bl ]))
    (N.∥∥ᴱ-proposition N.∣ x ∣ N.∣ y ∣)                                 ≡⟨⟩

  cong (_≃_.from CS.universal-property (f , [ g bl ]))
    (trans (sym (CS.∣∣₊≡∣∣₀ x))
       (trans (cong CS.∣_∣₊ (O.∣∣-constant x y))
          (CS.∣∣₊≡∣∣₀ y)))                                              ≡⟨ trans (cong-trans _ _ _) $
                                                                           cong₂ trans
                                                                             (cong-sym _ _)
                                                                             (trans (cong-trans _ _ _) $
                                                                              cong (flip trans _) $
                                                                              cong-∘ _ _ _) ⟩
  trans
    (sym $ cong (_≃_.from CS.universal-property (f , [ g bl ]))
             (CS.∣∣₊≡∣∣₀ x))
    (trans
       (cong (_≃_.from CS.universal-property (f , [ g bl ]) ∘ CS.∣_∣₊)
          (O.∣∣-constant x y))
       (cong (_≃_.from CS.universal-property (f , [ g bl ]))
          (CS.∣∣₊≡∣∣₀ y)))                                              ≡⟨ cong₂ trans
                                                                             (cong sym CS.rec-∣∣₊≡∣∣₀)
                                                                             (cong (trans _) CS.rec-∣∣₊≡∣∣₀) ⟩
  trans (sym $ proj₁ (proj₂ (g bl)) x)
    (trans (cong (proj₁ (g bl) 0) (O.∣∣-constant x y))
       (proj₁ (proj₂ (g bl)) y))                                        ≡⟨ lemma bl ⟩∎

  c .property x y                                                       ∎
  where
  g : ∀ _ → _
  g bl =
    _≃_.from (∥∥ᴱ→≃-lemma bl _) $
    _≃_.to (C.Coherently-constant′≃ bl) $
    _≃_.to (C.Coherently-constant≃Coherently-constant′ bl univ) c

  lemma :
    ∀ bl →
    trans (sym $ proj₁ (proj₂ (g bl)) x)
      (trans (cong (proj₁ (g bl) 0) (O.∣∣-constant x y))
         (proj₁ (proj₂ (g bl)) y)) ≡
    c .property x y
  lemma bl@⊠ =
    trans (sym $ proj₁ (proj₂ (g bl)) x)
      (trans (cong (proj₁ (g bl) 0) (O.∣∣-constant x y))
         (proj₁ (proj₂ (g bl)) y))                                ≡⟨⟩

    trans (sym $ refl _)
      (trans (cong (O.rec′ f (c .property)) (O.∣∣-constant x y))
         (refl _))                                                ≡⟨ trans (cong₂ trans sym-refl (trans-reflʳ _)) $
                                                                     trans-reflˡ _ ⟩

    cong (O.rec′ f (c .property)) (O.∣∣-constant x y)             ≡⟨ O.rec-∣∣-constant ⟩∎

    c .property x y                                               ∎

------------------------------------------------------------------------
-- Coherently-constant

-- Coherently constant type-valued functions.

Coherently-constant :
  {A : Type a} → (A → Type p) → Type (a ⊔ lsuc p)
Coherently-constant P =
  ∃ λ (f : ∀ x y → P x → P y) →
  Erased (∃ λ (c : C.Coherently-constant P) →
          ∀ x y → f x y ≡ subst id (c .property x y))

-- Coherently-constant is pointwise equivalent (with erased proofs) to
-- V.Coherently-constant (assuming univalence).

Coherently-constant≃ᴱCoherently-constant :
  {A : Type a} {P : A → Type p} →
  @0 Univalence (a ⊔ lsuc p) →
  @0 Univalence p →
  Coherently-constant P ≃ᴱ V.Coherently-constant P
Coherently-constant≃ᴱCoherently-constant
  {a = a} {p = p} {A = A} {P = P} univ′ univ =
  block λ bl →

  Coherently-constant P                                                 ↔⟨⟩

  (∃ λ (P-const : ∀ x y → P x → P y) →
   Erased (
   ∃ λ (c : C.Coherently-constant P) →
   ∀ x y →
   P-const x y ≡ subst id (c .property x y)))                           ↔⟨ (∃-cong λ P-const → Erased-cong (
                                                                            ∃-cong λ c → ∀-cong ext λ x → ∀-cong ext λ y →
                                                                            ≡⇒≃ $ cong (P-const x y ≡_) (
      subst id (c .property x y)                                            ≡⟨ cong (subst id) $ sym $
                                                                                cong-from-∥∥ᴱ→≃-truncation-is-proposition bl univ′ ⟩
      subst id
        (cong (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
           (T.truncation-is-proposition ∣ x ∣ ∣ y ∣))                       ≡⟨ (⟨ext⟩ λ _ → sym $
                                                                                subst-∘ _ _ _) ⟩∎
      subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
        (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)                           ∎))) ⟩

  (∃ λ (P-const : ∀ x y → P x → P y) →
   Erased (
   ∃ λ (c : C.Coherently-constant P) →
   ∀ x y →
   P-const x y ≡
   subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
     (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)))                        ↔⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ →
                                                                            Eq.extensionality-isomorphism bad-ext F.∘
                                                                            (∀-cong ext λ _ → Eq.extensionality-isomorphism bad-ext))) ⟩
  (∃ λ (P-const : ∀ x y → P x → P y) →
   Erased (
   ∃ λ (c : C.Coherently-constant P) →
   P-const ≡
   λ x y →
   subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
     (T.truncation-is-proposition ∣ x ∣ ∣ y ∣)))                        ↔⟨ (∃-cong λ P-const → Erased-cong (
                                                                            ∃-cong λ c → ≡⇒≃ $ cong (P-const ≡_) $ sym $
                                                                            ⟨ext⟩ λ x → ⟨ext⟩ λ y →
                                                                            cong₂ (λ (f : P y → P y) (g : P x → P x) →
                                                                                f ∘
                                                                                subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
                                                                                (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
                                                                                g)
                                                                              (cong _≃_.to $
                                                                               trans (cong ≡⇒≃ $ cong-refl (_$ y)) $
                                                                               ≡⇒↝-refl)
                                                                              (cong _≃_.from $
                                                                               trans (cong ≡⇒≃ $ cong-refl (_$ x)) $
                                                                               ≡⇒↝-refl))) ⟩
  (∃ λ (P-const : ∀ x y → P x → P y) →
   Erased (
   ∃ λ (c : C.Coherently-constant P) →
   P-const ≡
   λ x y →
   ≡⇒→ (cong (_$ y) (refl P)) ∘
   subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (P , [ c ]))
     (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
   _≃_.from (≡⇒≃ (cong (_$ x) (refl P)))))                              ↝⟨ (∃-cong λ P-const → inverse $
                                                                            EEq.drop-⊤-left-Σ-≃ᴱ-Erased
                                                                              (EEq.other-singleton-with-Π-≃ᴱ-≃ᴱ-⊤ ext univ)) ⟩
  (∃ λ (P-const : ∀ x y → P x → P y) →
   ∃ λ ((Q , P≃) : ∃ λ (Q : A → Type p) → ∀ x → P x ≃ᴱ Q x) →
   Erased (
   ∃ λ (c : C.Coherently-constant Q) →
   P-const ≡
   λ x y →
   _≃ᴱ_.from (P≃ y) ∘
   subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (Q , [ c ]))
     (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
   _≃ᴱ_.to (P≃ x)))                                                     ↔⟨ (∃-cong λ _ →
                                                                            Σ-assoc F.∘
                                                                            (∃-cong λ _ → ∃-comm) F.∘
                                                                            inverse Σ-assoc F.∘
                                                                            (∃-cong λ _ → Erased-Σ↔Σ)) ⟩
  (∃ λ (P-const : ∀ x y → P x → P y) →
   ∃ λ ((Q , c) : ∃ λ (Q : A → Type p) →
                  Erased (C.Coherently-constant Q)) →
   ∃ λ (P≃ : ∀ x → P x ≃ᴱ Q x) →
   Erased (P-const ≡
           λ x y →
           _≃ᴱ_.from (P≃ y) ∘
           subst (_≃_.from (∥∥ᴱ→≃ bl univ′) (Q , c))
             (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
           _≃ᴱ_.to (P≃ x)))                                             ↔⟨ (∃-cong λ _ →
                                                                            Σ-cong (inverse $ ∥∥ᴱ→≃ bl univ′) λ _ → Eq.id) ⟩
  (∃ λ (P-const : ∀ x y → P x → P y) →
   ∃ λ (Q : ∥ A ∥ᴱ → Type p) →
   ∃ λ (P≃ : ∀ x → P x ≃ᴱ Q ∣ x ∣) →
   Erased (P-const ≡
           λ x y →
           _≃ᴱ_.from (P≃ y) ∘
           subst Q (T.truncation-is-proposition ∣ x ∣ ∣ y ∣) ∘
           _≃ᴱ_.to (P≃ x)))                                             ↔⟨⟩

  V.Coherently-constant′ P                                              ↝⟨ inverse V.Coherently-constant≃ᴱCoherently-constant′ ⟩□

  V.Coherently-constant P                                               □

------------------------------------------------------------------------
-- The lens type family

-- Coinductive lenses.

Lens : Type a → Type b → Type (lsuc (a ⊔ b))
Lens A B = ∃ λ (get : A → B) → Coherently-constant (get ⁻¹ᴱ_)

-- Some derived definitions.

module Lens {A : Type a} {B : Type b} (l : Lens A B) where

  -- A getter.

  get : A → B
  get = proj₁ l

  -- One can convert from any "preimage" (with an erased proof) of the
  -- getter to any other.

  get⁻¹ᴱ-const : (b₁ b₂ : B) → get ⁻¹ᴱ b₁ → get ⁻¹ᴱ b₂
  get⁻¹ᴱ-const b₁ b₂ = proj₁ (proj₂ l) b₁ b₂

  -- A setter.

  set : A → B → A
  set a b =                      $⟨ get⁻¹ᴱ-const (get a) b ⟩
    (get ⁻¹ᴱ get a → get ⁻¹ᴱ b)  ↝⟨ _$ (a , [ refl _ ]) ⟩
    get ⁻¹ᴱ b                    ↝⟨ proj₁ ⟩□
    A                            □

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter : Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = Lens.get
    ; set = Lens.set
    }

-- Lens A B is equivalent to V.Lens A B (with erased proofs, assuming
-- univalence).

Lens≃ᴱLens :
  Block "Lens≃ᴱLens" →
  {A : Type a} {B : Type b} →
  @0 Univalence (lsuc (a ⊔ b)) →
  @0 Univalence (a ⊔ b) →
  Lens A B ≃ᴱ V.Lens A B
Lens≃ᴱLens ⊠ {A = A} {B = B} univ′ univ =
  (∃ λ (get : A → B) → Coherently-constant (get ⁻¹ᴱ_))    ↝⟨ (∃-cong λ _ →
                                                              Coherently-constant≃ᴱCoherently-constant univ′ univ) ⟩□
  (∃ λ (get : A → B) → V.Coherently-constant (get ⁻¹ᴱ_))  □

-- The right-to-left direction of the equivalence preserves getters
-- and setters.

from-Lens≃ᴱLens-preserves-getters-and-setters :
  (bl : Block "Lens≃ᴱLens")
  {A : Type a} {B : Type b}
  (@0 univ′ : Univalence (lsuc (a ⊔ b)))
  (@0 univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-→ A B
    (_≃ᴱ_.from (Lens≃ᴱLens bl univ′ univ))
from-Lens≃ᴱLens-preserves-getters-and-setters ⊠ _ _ l =
    refl _
  , ⟨ext⟩ λ a → ⟨ext⟩ λ b →
    proj₁ (get⁻¹ᴱ-const (get a) b (a , [ refl (get a) ]))  ∎
  where
  open V.Lens l

-- In erased contexts the equivalence preserves getters and setters.
--
-- (I do not know if this result can be proved in non-erased
-- contexts.)

@0 Lens≃ᴱLens-preserves-getters-and-setters :
  (bl : Block "Lens≃ᴱLens")
  {A : Type a} {B : Type b}
  (@0 univ′ : Univalence (lsuc (a ⊔ b)))
  (@0 univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_≃ᴱ_.logical-equivalence (Lens≃ᴱLens bl univ′ univ))
Lens≃ᴱLens-preserves-getters-and-setters bl univ′ univ =
  Preserves-getters-and-setters-⇔-inverse
    {f = _≃ᴱ_.logical-equivalence
           (inverse $ Lens≃ᴱLens bl univ′ univ)} $
  Preserves-getters-and-setters-→-↠-⇔
    (_≃_.surjection (EEq.≃ᴱ→≃ $ inverse $ Lens≃ᴱLens bl univ′ univ))
    (from-Lens≃ᴱLens-preserves-getters-and-setters bl univ′ univ)

-- Lens A B is equivalent to Higher.Lens A B (with erased proofs,
-- assuming univalence).

Lens≃ᴱHigher-lens :
  Block "Lens≃ᴱHigher-Lens" →
  {A : Type a} {B : Type b} →
  @0 Univalence (lsuc (a ⊔ b)) →
  @0 Univalence (a ⊔ b) →
  Lens A B ≃ᴱ Higher.Lens A B
Lens≃ᴱHigher-lens bl {A = A} {B = B} univ′ univ =
  Lens A B         ↝⟨ Lens≃ᴱLens bl univ′ univ ⟩
  V.Lens A B       ↝⟨ V.Lens≃ᴱHigher-lens bl univ ⟩□
  Higher.Lens A B  □

-- In erased contexts the equivalence preserves getters and setters.

@0 Lens≃ᴱHigher-lens-preserves-getters-and-setters :
  (bl : Block "Lens≃ᴱHigher-lens")
  {A : Type a} {B : Type b}
  (@0 univ′ : Univalence (lsuc (a ⊔ b)))
  (@0 univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_≃ᴱ_.logical-equivalence (Lens≃ᴱHigher-lens bl univ′ univ))
Lens≃ᴱHigher-lens-preserves-getters-and-setters bl univ′ univ =
  Preserves-getters-and-setters-⇔-∘
    {f = _≃ᴱ_.logical-equivalence $ V.Lens≃ᴱHigher-lens bl univ}
    {g = _≃ᴱ_.logical-equivalence $ Lens≃ᴱLens bl univ′ univ}
    (V.Lens≃ᴱHigher-lens-preserves-getters-and-setters bl univ)
    (Lens≃ᴱLens-preserves-getters-and-setters bl univ′ univ)

------------------------------------------------------------------------
-- H-levels

-- If P has h-level n (pointwise), then Coherently-constant P has
-- h-level n (assuming univalence).

H-level-Coherently-constant :
  {A : Type a} {P : A → Type p} →
  @0 Univalence (lsuc (a ⊔ p)) →
  @0 Univalence (a ⊔ lsuc p) →
  @0 Univalence p →
  ((a : A) → H-level n (P a)) →
  H-level n (Coherently-constant P)
H-level-Coherently-constant {n = n} univ₁ univ₂ univ₃ h =
  Σ-closure n
    (Π-closure ext n λ _ →
     Π-closure ext n λ _ →
     Π-closure ext n λ _ →
     h _) λ _ →
  H-level-Erased n (
  Σ-closure n
    (S.H-level-Coinductive-Coherently-constant
       univ₁ univ₂ univ₃ h) λ _ →
  Π-closure ext n λ _ →
  Π-closure ext n λ _ →
  H-level.⇒≡ n $
  Π-closure ext n λ _ →
  h _)

-- If A and B have h-level n given the assumption that the other type
-- is inhabited, then Lens A B has h-level n (assuming univalence).

lens-preserves-h-level :
  {A : Type a} {B : Type b} →
  @0 Univalence (lsuc (a ⊔ b)) →
  @0 Univalence (a ⊔ b) →
  ∀ n → (B → H-level n A) → (A → H-level n B) →
  H-level n (Lens A B)
lens-preserves-h-level univ₁ univ₂ n hA hB =
  Σ-closure n
    (Π-closure ext n λ a →
     hB a) λ _ →
  H-level-Coherently-constant univ₁ univ₁ univ₂ λ b →
  Σ-closure n (hA b) λ a →
  H-level-Erased n (
  H-level.⇒≡ n (hB a))

-- If the domain of a lens is inhabited and has h-level n, then the
-- codomain also has h-level n (in erased contexts, assuming
-- univalence).

@0 h-level-respects-lens-from-inhabited :
  {A : Type a} {B : Type b} →
  Univalence (lsuc (a ⊔ b)) →
  Univalence (a ⊔ b) →
  ∀ n → Lens A B → A → H-level n A → H-level n B
h-level-respects-lens-from-inhabited univ′ univ n =
  Higher.h-level-respects-lens-from-inhabited n ∘
  _≃ᴱ_.to (Lens≃ᴱHigher-lens ⊠ univ′ univ)

-- If A has positive h-level n, then Lens A B also has h-level n (in
-- erased contexts, assuming univalence).

@0 lens-preserves-h-level-of-domain :
  {A : Type a} {B : Type b} →
  Univalence (lsuc (a ⊔ b)) →
  Univalence (a ⊔ b) →
  ∀ n → H-level (1 + n) A → H-level (1 + n) (Lens A B)
lens-preserves-h-level-of-domain univ′ univ n hA =
  H-level.[inhabited⇒+]⇒+ n λ l →
  lens-preserves-h-level univ′ univ (1 + n) (λ _ → hA) λ a →
  h-level-respects-lens-from-inhabited univ′ univ _ l a hA


{- Copyright © 1992–2002 The University of Glasgow
Copyright © 2015 Benjamin Barenblat

Licensed under the Apache License, Version 2.0 (the ‘License’); you may not use
this file except in compliance with the License.  You may obtain a copy of the
License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software distributed
under the License is distributed on an ‘AS IS’ BASIS, WITHOUT WARRANTIES OR
CONDITIONS OF ANY KIND, either express or implied.  See the License for the
specific language governing permissions and limitations under the License. -}

module B.Prelude.Monad where

import Category.Monad
import Data.List
import Data.Maybe
open import Function using (const)

open Category.Monad
  using (RawMonad)
  public

open Category.Monad.RawMonad ⦃...⦄
  using (_>>=_; _>>_; return)
  public

instance
  Monad-List : ∀ {ℓ} → RawMonad (Data.List.List {ℓ})
  Monad-List = Data.List.monad

  Monad-Maybe : ∀ {ℓ} → RawMonad (Data.Maybe.Maybe {ℓ})
  Monad-Maybe = Data.Maybe.monad

  Monad-Function : ∀ {ℓ} {r : Set ℓ} → RawMonad (λ s → (r → s))
  Monad-Function {r} = record { return = const {r}
                              ; _>>=_ = λ f k → λ r → k (f r) r }


{-# OPTIONS --rewriting #-}

module GSeTT.GSeTT where
  open import GSeTT.Syntax
  open import GSeTT.Rules
  import GSeTT.CwF-structure
  import GSeTT.Dec-Type-Checking
  import GSeTT.Uniqueness-Derivations
  open import GSeTT.Typed-Syntax


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

module Categories.Adjoint.Properties where

open import Level
open import Data.Product using (Σ; _,_; -,_; proj₂; uncurry)
open import Function using (_$_)

open import Categories.Adjoint using (_⊣_; Adjoint; Hom-NI′⇒Adjoint)
open import Categories.Adjoint.RAPL public
open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Product using (_⁂_; _⁂ⁿⁱ_)
open import Categories.Category.Construction.Comma using (CommaObj; Comma⇒; _↙_)
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Hom
open import Categories.Functor.Construction.Constant
open import Categories.Functor.Construction.LiftSetoids
open import Categories.Functor.Properties
open import Categories.Functor.Continuous
open import Categories.Functor.Cocontinuous
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism; _≃_; _ⓘₕ_; _ⓘˡ_; module ≃)
open import Categories.NaturalTransformation.NaturalIsomorphism.Properties
open import Categories.Monad
open import Categories.Monad.Duality
open import Categories.Comonad
open import Categories.Morphism.Universal
open import Categories.Yoneda
import Categories.Yoneda.Properties as YP

import Categories.Diagram.Colimit as Col
import Categories.Diagram.Duality as Duality

import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D E J : Category o ℓ e

-- if the left adjoint functor is a partial application of bifunctor, then it uniquely
-- determines a bifunctor compatible with the right adjoint functor.
module _ {C : Category o ℓ e}
         (L : Bifunctor C E D) {R : ∀ (X : Category.Obj E) → Functor D C}
         (LR : ∀ (X : Category.Obj E) → appʳ L X ⊣ R X) where
  private
    module C    = Category C
    module D    = Category D
    module E    = Category E
    module L    = Functor L
    module R X  = Functor (R X)
    module LR X = Adjoint (LR X)
    open C

    F′ : ∀ {A X B Y} f g → R.F₀ A X ⇒ R.F₀ B Y
    F′ {A} {X} {B} {Y} f g = LR.Ladjunct B (LR.counit.η A Y D.∘ L.F₁ (R.F₁ A g , f))
    --  R.F₁ B (LR.counit.η A Y) ∘ R.F₁ B (L.F₁ (R.F₁ A g , f)) ∘ LR.unit.η B (R.F₀ A X)

    commute′ : ∀ {A B X} (f : A E.⇒ B) → LR.counit.η A X D.∘ L.F₁ (F′ f D.id , E.id) D.≈ LR.counit.η B X D.∘ L.F₁ (C.id , f)
    commute′ {A} {B} {X} f = begin
      LR.counit.η A X D.∘ L.F₁ (F′ f D.id , E.id) ≈⟨ LR.RLadjunct≈id A ⟩
      LR.counit.η B X D.∘ L.F₁ (R.F₁ B D.id , f)  ≈⟨ refl ⟩∘⟨ L.F-resp-≈ (R.identity B , E.Equiv.refl) ⟩
      LR.counit.η B X D.∘ L.F₁ (C.id , f)         ∎
      where open D.HomReasoning

    open HomReasoning

    decompose₁ : ∀ {A B X Y} {f : A E.⇒ B} {g : X D.⇒ Y} → F′ f g ≈ R.F₁ A g ∘ F′ f D.id
    decompose₁ {A} {B} {X} {Y} {f} {g} = begin
      F′ f g
        ≈⟨ R.F-resp-≈ A (D.∘-resp-≈ʳ [ L ]-decompose₁) ⟩∘⟨refl ⟩
      R.F₁ A (LR.counit.η B Y D.∘ L.F₁ (R.F₁ B g , E.id) D.∘ L.F₁ (C.id , f)) ∘ LR.unit.η A (R.F₀ B X)
        ≈⟨ R.F-resp-≈ A (pullˡ (LR.counit.commute B g)) ⟩∘⟨refl ⟩
      R.F₁ A ((g D.∘ LR.counit.η B X) D.∘ L.F₁ (C.id , f)) ∘ LR.unit.η A (R.F₀ B X)
        ≈˘⟨ R.F-resp-≈ A (pushʳ (D.∘-resp-≈ʳ (L.F-resp-≈ (R.identity B , E.Equiv.refl)))) ⟩∘⟨refl ⟩
      R.F₁ A (g D.∘ LR.counit.η B X D.∘ L.F₁ (R.F₁ B D.id , f)) ∘ LR.unit.η A (R.F₀ B X)
        ≈⟨ R.homomorphism A ⟩∘⟨refl ⟩
      (R.F₁ A g ∘ R.F₁ A (LR.counit.η B X D.∘ L.F₁ (R.F₁ B D.id , f))) ∘ LR.unit.η A (R.F₀ B X)
        ≈⟨ assoc ⟩
      R.F₁ A g ∘ F′ f D.id
        ∎
      where open MR D

    decompose₂ : ∀ {A B X Y} {f : A E.⇒ B} {g : X D.⇒ Y} → F′ f g ≈ F′ f D.id ∘ R.F₁ B g
    decompose₂ {A} {B} {X} {Y} {f} {g} = begin
      F′ f g
        ≈⟨ R.F-resp-≈ A (D.∘-resp-≈ʳ [ L ]-decompose₂) ⟩∘⟨refl ⟩
      R.F₁ A (LR.counit.η B Y D.∘ L.F₁ (C.id , f) D.∘ L.F₁ (R.F₁ B g , E.id)) ∘ LR.unit.η A (R.F₀ B X)
        ≈˘⟨ R.F-resp-≈ A (pushˡ (D.∘-resp-≈ʳ (L.F-resp-≈ (R.identity B , E.Equiv.refl)))) ⟩∘⟨refl ⟩
      R.F₁ A ((LR.counit.η B Y D.∘ L.F₁ (R.F₁ B D.id , f)) D.∘ L.F₁ (R.F₁ B g , E.id)) ∘ LR.unit.η A (R.F₀ B X)
        ≈⟨ R.homomorphism A ⟩∘⟨refl ⟩
      (R.F₁ A (LR.counit.η B Y D.∘ L.F₁ (R.F₁ B D.id , f)) ∘ R.F₁ A (L.F₁ (R.F₁ B g , E.id))) ∘ LR.unit.η A (R.F₀ B X)
        ≈˘⟨ MR.pushʳ C (LR.unit.commute A (R.F₁ B g)) ⟩
      R.F₁ A (LR.counit.η B Y D.∘ L.F₁ (R.F₁ B D.id , f)) ∘ LR.unit.η A (R.F₀ B Y) ∘ R.F₁ B g
        ≈˘⟨ assoc ⟩
      F′ f D.id ∘ R.F₁ B g
        ∎
      where open MR D

    swap : ∀ {A B X Y} {f : A E.⇒ B} {g : X D.⇒ Y} → R.F₁ A g ∘ F′ f D.id ≈ F′ f D.id ∘ R.F₁ B g
    swap = trans (⟺ decompose₁) decompose₂

    commute″ : ∀ {X Y Z A} {f : Y E.⇒ Z} {g : X E.⇒ Y} → F′ (f E.∘ g) (D.id {A}) ≈ F′ g D.id ∘ F′ f D.id
    commute″ {X} {Y} {Z} {A} {f} {g} = begin
      F′ (f E.∘ g) D.id
        ≈⟨ R.F-resp-≈ X (D.∘-resp-≈ʳ (L.F-resp-≈ (R.identity Z , E.Equiv.refl))) ⟩∘⟨refl ⟩
      R.F₁ X (LR.counit.η Z A D.∘ L.F₁ (C.id , f E.∘ g)) ∘ LR.unit.η X (R.F₀ Z A)
        ≈⟨ R.F-resp-≈ X (D.∘-resp-≈ʳ (Functor.homomorphism (appˡ L (R.F₀ Z A)))) ⟩∘⟨refl ⟩
      R.F₁ X (LR.counit.η Z A D.∘ L.F₁ (C.id , f) D.∘ L.F₁ (C.id , g)) ∘ LR.unit.η X (R.F₀ Z A)
        ≈˘⟨ R.F-resp-≈ X (MR.pushˡ D (commute′ f)) ⟩∘⟨refl ⟩
      R.F₁ X ((LR.counit.η Y A D.∘ L.F₁ (F′ f D.id , E.id)) D.∘ L.F₁ (C.id , g)) ∘ LR.unit.η X (R.F₀ Z A)
        ≈˘⟨ R.F-resp-≈ X (MR.pushʳ D [ L ]-commute) ⟩∘⟨refl ⟩
      R.F₁ X (LR.counit.η Y A D.∘ L.F₁ (C.id , g) D.∘ L.F₁ (F′ f D.id , E.id)) ∘ LR.unit.η X (R.F₀ Z A)
        ≈˘⟨ R.F-resp-≈ X D.assoc ⟩∘⟨refl ⟩
      R.F₁ X ((LR.counit.η Y A D.∘ L.F₁ (C.id , g)) D.∘ L.F₁ (F′ f D.id , E.id)) ∘ LR.unit.η X (R.F₀ Z A)
        ≈⟨ R.homomorphism X ⟩∘⟨refl ⟩
      (R.F₁ X (LR.counit.η Y A D.∘ L.F₁ (C.id , g)) ∘ R.F₁ X (L.F₁ (F′ f D.id , E.id))) ∘ LR.unit.η X (R.F₀ Z A)
        ≈˘⟨ MR.pushʳ C (LR.unit.commute X (F′ f D.id)) ⟩
      R.F₁ X (LR.counit.η Y A D.∘ L.F₁ (C.id , g)) ∘ LR.unit.η X (R.F₀ Y A) ∘ F′ f D.id
        ≈˘⟨ R.F-resp-≈ X (D.∘-resp-≈ʳ (L.F-resp-≈ (R.identity Y , E.Equiv.refl))) ⟩∘⟨ refl ⟩∘⟨ refl ⟩
      R.F₁ X (LR.counit.η Y A D.∘ L.F₁ (R.F₁ Y D.id , g)) ∘ LR.unit.η X (R.F₀ Y A) ∘ F′ f D.id
        ≈˘⟨ assoc ⟩
      F′ g D.id ∘ F′ f D.id
        ∎

  induced-bifunctorʳ : Bifunctor E.op D C
  induced-bifunctorʳ = record
    { F₀           = uncurry R.F₀
    ; F₁           = uncurry F′
    ; identity     = λ where
      {e , d} →
        let open MR D
        in begin
          F′ E.id D.id
            ≈⟨ R.F-resp-≈ e (D.∘-resp-≈ʳ (L.F-resp-≈ (R.identity e , E.Equiv.refl))) ⟩∘⟨ refl ⟩
          R.F₁ e (LR.counit.η e d D.∘ L.F₁ (C.id , E.id)) ∘ LR.unit.η e (R.F₀ e d)
            ≈⟨ R.F-resp-≈ e (elimʳ L.identity) ⟩∘⟨ refl ⟩
          R.F₁ e (LR.counit.η e d) ∘ LR.unit.η e (R.F₀ e d)
            ≈⟨ LR.zag e ⟩
          C.id
            ∎
    ; homomorphism = λ where
      {A , X} {B , Y} {W , Z} {f , h} {g , i} →
        let open MR C
        in begin
          F′ (f E.∘ g) (i D.∘ h)
            ≈⟨ decompose₁ ⟩
          R.F₁ W (i D.∘ h) ∘ F′ (f E.∘ g) D.id
            ≈˘⟨ center⁻¹ (⟺ (R.homomorphism W)) (⟺ commute″) ⟩
          R.F₁ W i ∘ (R.F₁ W h ∘ F′ g D.id) ∘ F′ f D.id
            ≈˘⟨ center (⟺ swap) ⟩
          (R.F₁ W i ∘ F′ g D.id) ∘ R.F₁ B h ∘ F′ f D.id
            ≈˘⟨ decompose₁ ⟩∘⟨ decompose₁ ⟩
          F′ g i ∘ F′ f h
            ∎
    ; F-resp-≈     = λ where
      {A , X} {B , Y} (eq , eq′) →
        ∘-resp-≈ˡ (R.F-resp-≈ B (D.∘-resp-≈ʳ (L.F-resp-≈ (R.F-resp-≈ A eq′ , eq))))
    }

-- LAPC: left adjoint preserves colimits.
module _ {L : Functor C D} {R : Functor D C} (L⊣R : L ⊣ R) (F : Functor J C) where
  private
    module F = Functor F
    open Col

  lapc : Colimit F → Colimit (L ∘F F)
  lapc col = Duality.coLimit⇒Colimit D (rapl (Adjoint.op L⊣R) F.op (Duality.Colimit⇒coLimit C col))

-- adjoint functors induce monads and comonads
module _ {L : Functor C D} {R : Functor D C} (L⊣R : L ⊣ R) where
  private
    module C = Category C
    module D = Category D
    module L = Functor L
    module R = Functor R
    open Adjoint L⊣R

  rapl′ : ∀ {o ℓ e} → Continuous o ℓ e R
  rapl′ lim = rapl L⊣R _ lim , Mor.≅.refl C

  lapc′ : ∀ {o ℓ e} → Cocontinuous o ℓ e L
  lapc′ col = lapc L⊣R _ col , Mor.≅.refl D

  adjoint⇒monad : Monad C
  adjoint⇒monad = record
    { F         = R ∘F L
    ; η         = unit
    ; μ         = record
      { η           = μ′.η
      ; commute     = μ′.commute
      ; sym-commute = μ′.sym-commute
      }
    ; assoc     = [ R ]-resp-square (counit.commute _)
    ; sym-assoc = [ R ]-resp-square (counit.sym-commute _)
    ; identityˡ = λ {X} → begin
      μ′.η X ∘ R.F₁ (L.F₁ (unit.η X)) ≈⟨ [ R ]-resp-∘ zig ⟩
      R.F₁ D.id                       ≈⟨ R.identity ⟩
      C.id                            ∎
    ; identityʳ = zag
    }
    where open C
          open HomReasoning
          μ′ : NaturalTransformation (R ∘F (L ∘F R) ∘F L) (R ∘F Categories.Functor.id ∘F L)
          μ′ = R ∘ˡ counit ∘ʳ L
          module μ′ = NaturalTransformation μ′

module _ {L : Functor C D} {R : Functor D C} (L⊣R : L ⊣ R) where
  open Adjoint L⊣R

  adjoint⇒comonad : Comonad D
  adjoint⇒comonad = coMonad⇒Comonad D (adjoint⇒monad op)

-- adjoint functors are the same as universal morphisms
module _ {R : Functor D C} where
  private
    module C = Category C
    module D = Category D
    module R = Functor R

  adjoint⇒universalMorphisms : ∀ {L : Functor C D} → L ⊣ R → ∀ (X : C.Obj) → UniversalMorphism X R
  adjoint⇒universalMorphisms {L} L⊣R X = record
    { initial = record
      { ⊥        = record { f = unit.η X }
      ; !        =
        let open C.HomReasoning
        in record { commute = LRadjunct≈id ○ ⟺ C.identityʳ }
      ; !-unique = λ {A} g →
        let open D.HomReasoning
        in -, (begin
          Radjunct (f A)            ≈⟨ Radjunct-resp-≈ (C.Equiv.sym (C.Equiv.trans (commute g) (C.identityʳ {f = f A}))) ⟩
          Radjunct (Ladjunct (h g)) ≈⟨ RLadjunct≈id ⟩
          h g                       ∎)
      }
    }
    where module L = Functor L
          open Adjoint L⊣R
          open Comma⇒
          open CommaObj

  universalMophisms⇒adjoint : (∀ (X : C.Obj) → UniversalMorphism X R) → Σ (Functor C D) (λ L → L ⊣ R)
  universalMophisms⇒adjoint umors = L , record
    { unit   = ntHelper record
      { η       = λ c → f (umors.⊥ c)
      ; commute = λ i → let open C.HomReasoning in ⟺ (commute (⊥X⇒⊥Y i) ○ C.identityʳ )
      }
    ; counit = ntHelper record
      { η       = ε
      ; commute = λ {X Y} i →
        let open C.HomReasoning
            open MR C
        in proj₂ $ umors.!-unique₂ (R.F₀ X)
           {record { f = R.F₁ i }}
           (record
           { h       = ε Y D.∘ L₁ (R.F₁ i)
           ; commute = begin
             R.F₁ (ε Y D.∘ L₁ (R.F₁ i)) C.∘ f (⊥Rd X)          ≈⟨ R.homomorphism ⟩∘⟨refl ⟩
             (R.F₁ (ε Y) C.∘ R.F₁ (L₁ (R.F₁ i))) C.∘ f (⊥Rd X) ≈⟨ pullʳ (commute (⊥X⇒⊥Y (R.F₁ i)) ○ C.identityʳ) ⟩
             R.F₁ (ε Y) C.∘ f (⊥Rd Y) C.∘ R.F₁ i               ≈⟨ cancelˡ (commute (⊥Rd⇒id Y) ○ C.identityˡ) ⟩
             R.F₁ i                                            ≈˘⟨ C.identityʳ ⟩
             R.F₁ i C.∘ C.id                                   ∎
           })
           (record
           { h       = i D.∘ ε X
           ; commute = begin
             R.F₁ (i D.∘ ε X) C.∘ f (⊥Rd X)        ≈⟨ R.homomorphism ⟩∘⟨refl ⟩
             (R.F₁ i C.∘ R.F₁ (ε X)) C.∘ f (⊥Rd X) ≈⟨ cancelʳ (commute (⊥Rd⇒id X) ○ C.identityˡ) ⟩
             R.F₁ i                                ≈˘⟨ C.identityʳ ⟩
             R.F₁ i C.∘ C.id                       ∎
           })
      }
    ; zig    = λ {c} →
      let open C.HomReasoning
          open MR C
          α = f (umors.⊥ c)
      in proj₂ $ umors.!-unique₂ c
         {record { f = α }}
         (record
         { h       = ε (L₀ c) D.∘ L₁ α
         ; commute = begin
           R.F₁ (ε (L₀ c) D.∘ L₁ α) C.∘ α           ≈⟨ R.homomorphism ⟩∘⟨refl ⟩
           (R.F₁ (ε (L₀ c)) C.∘ R.F₁ (L₁ α)) C.∘ α  ≈⟨ pullʳ (commute (⊥X⇒⊥Y α) ○ C.identityʳ) ⟩
           R.F₁ (ε (L₀ c)) C.∘ f (⊥Rd (L₀ c)) C.∘ α ≈⟨ cancelˡ (commute (⊥Rd⇒id (L₀ c)) ○ C.identityˡ) ⟩
           α                                        ≈˘⟨ C.identityʳ ⟩
           α C.∘ C.id                               ∎
         })
         (record
         { h       = D.id
         ; commute = C.∘-resp-≈ˡ R.identity ○ id-comm-sym
         })
    ; zag    = λ {d} → C.Equiv.trans (commute (⊥Rd⇒id d)) C.identityˡ
    }
    where module umors X = UniversalMorphism (umors X)
          open CommaObj
          open Comma⇒

          commaObj∘g : ∀ {X Y} → X C.⇒ Y → CommaObj (const! X) R
          commaObj∘g {X} {Y} g = record { f = f (umors.⊥ Y) C.∘ g }

          ⊥X⇒⊥Y : ∀ {X Y} (g : X C.⇒ Y) → (X ↙ R) [ umors.⊥ X , commaObj∘g g ]
          ⊥X⇒⊥Y {X} {Y} g = umors.! X {commaObj∘g g}

          L₀ : ∀ X → D.Obj
          L₀ X         = β (umors.⊥ X)
          L₁ : ∀ {X Y} → X C.⇒ Y → β (umors.⊥ X) D.⇒ β (umors.⊥ Y)
          L₁ {X} {Y} g = h (⊥X⇒⊥Y g)
          L : Functor C D
          L            = record
            { F₀           = L₀
            ; F₁           = L₁
            ; identity     = λ {X} → proj₂ $ umors.!-unique X $
              record { commute = elimˡ R.identity ○ ⟺ C.identityʳ ○ ⟺ C.identityʳ }
            ; homomorphism = λ {X Y Z} {i j} → proj₂ $ umors.!-unique₂ X (umors.! X) $
              record { commute = begin
                R.F₁ (h (umors.! Y) D.∘ h (umors.! X)) C.∘ f (umors.⊥ X)
                  ≈⟨ (C.∘-resp-≈ˡ R.homomorphism) ○ C.assoc ⟩
                R.F₁ (h (umors.! Y)) C.∘ R.F₁ (h (umors.! X)) C.∘ f (umors.⊥ X)
                  ≈⟨ (C.∘-resp-≈ʳ (commute (⊥X⇒⊥Y i) ○ C.identityʳ)) ○ C.sym-assoc ⟩
                (R.F₁ (h (umors.! Y)) C.∘ f (umors.⊥ Y)) C.∘ i
                  ≈⟨ pushˡ (commute (⊥X⇒⊥Y j) ○ C.identityʳ) ⟩
                f (umors.⊥ Z) C.∘ j C.∘ i
                  ≈˘⟨ C.identityʳ ⟩
                (f (umors.⊥ Z) C.∘ j C.∘ i) C.∘ C.id
                  ∎ }
            ; F-resp-≈     = λ {X} eq → proj₂ $ umors.!-unique₂ X (umors.! X) $
              record { commute = commute (umors.! X) ○ C.∘-resp-≈ˡ (C.∘-resp-≈ʳ (⟺ eq)) }
            }
            where open C.HomReasoning
                  open MR C
          module L = Functor L

          ⊥Rd    : (d : D.Obj) → CommaObj (const! (R.F₀ d)) R
          ⊥Rd d    = umors.⊥ (R.F₀ d)
          ⊥Rd⇒id : (d : D.Obj) →  (R.F₀ d ↙ R) [ ⊥Rd d , record { f = C.id } ]
          ⊥Rd⇒id d = umors.! (R.F₀ d) {record { f = C.id }}
          ε      : ∀ d → L₀ (R.F₀ d) D.⇒ d
          ε d      = h (⊥Rd⇒id d)

-- adjoint functors of a functor are isomorphic
module _ (L : Functor C D) where
  open YP C

  R≃R′ : ∀ {R R′} → L ⊣ R → L ⊣ R′ → R ≃ R′
  R≃R′ {R} {R′} L⊣R L⊣R′ = yoneda-NI R R′ (unlift-≃ Hom[-,R-]≃Hom[-,R′-])
    where module ⊣₁ = Adjoint L⊣R
          module ⊣₂ = Adjoint L⊣R′
          Hom[-,R-]≃Hom[-,R′-] : ⊣₁.Hom[-,R-]′ ≃ ⊣₂.Hom[-,R-]′
          Hom[-,R-]≃Hom[-,R′-] = ≃.trans (≃.sym ⊣₁.Hom-NI) ⊣₂.Hom-NI

module _ {R : Functor D C} where

  L≃L′ : ∀ {L L′} → L ⊣ R → L′ ⊣ R → L ≃ L′
  L≃L′ L⊣R L′⊣R = NaturalIsomorphism.op L′≃Lᵒᵖ
    where module ⊣₁ = Adjoint L⊣R
          module ⊣₂ = Adjoint L′⊣R
          L′≃Lᵒᵖ = R≃R′ (Functor.op R) ⊣₂.op ⊣₁.op

-- adjoint functors are preserved by natural isomorphisms
module _ {L L′ : Functor C D} {R R′ : Functor D C} where
  private
    module C  = Category C
    module D  = Category D
    module L  = Functor L
    module L′ = Functor L′
    module R  = Functor R
    module R′ = Functor R′

  ⊣×≃⇒⊣ : L ⊣ R → L ≃ L′ → R ≃ R′ → L′ ⊣ R′
  ⊣×≃⇒⊣ L⊣R L≃L′ R≃R′ = Hom-NI′⇒Adjoint (≃.trans (LiftSetoids _ _  ⓘˡ Hom[L′-,-]≃Hom[L-,-])
                                        (≃.trans Hom-NI
                                                 (LiftSetoids _ _  ⓘˡ Hom[-,R-]≃Hom[-,R′-])))
    where open Adjoint L⊣R
          Hom[L′-,-]≃Hom[L-,-] : Hom[ D ][-,-] ∘F (L′.op ⁂ idF) ≃ Hom[ D ][-,-] ∘F (L.op ⁂ idF)
          Hom[L′-,-]≃Hom[L-,-] = Hom[ D ][-,-] ⓘˡ (NaturalIsomorphism.op L≃L′ ⁂ⁿⁱ ≃.refl)
          Hom[-,R-]≃Hom[-,R′-] : Hom[ C ][-,-] ∘F (idF ⁂ R) ≃ Hom[ C ][-,-] ∘F (idF ⁂ R′)
          Hom[-,R-]≃Hom[-,R′-] = Hom[ C ][-,-] ⓘˡ (≃.refl ⁂ⁿⁱ R≃R′)


postulate
  F G : (Set → Set) → Set
  !_  : Set → Set

infix 2 F
infix 1 !_

syntax F (λ X → Y) = X , Y
syntax G (λ X → Y) = Y , X

-- This parsed when default fixity was 'unrelated', but with
-- an actual default fixity (of any strength) in place it really
-- should not.
Foo : Set
Foo = ! X , X


open import Prelude
open import Data.Nat using (_≤?_)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Vec using (Vec; _∷_; [])

open import RW.Language.RTerm
open import RW.Language.FinTerm
open import RW.Language.RTermUtils
open import RW.Utils.Monads

module RW.Language.GoalGuesser (maxH : ℕ) where

  open Monad {{...}}

  ----------------
  -- Housekeeping

  private
    cast-RBinApp : {A B : Set} → (A → B) → RBinApp A → RBinApp B
    cast-RBinApp f (n , a , b) = n , replace-A (ovar ∘ f) a , replace-A (ovar ∘ f) b

    RBinApp02⊥ : RBinApp (Fin zero) → RBinApp ⊥
    RBinApp02⊥ = cast-RBinApp (λ ())

    symmetric : {A : Set} → RBinApp A → RBinApp A
    symmetric (n , a , b) = n , b , a

  -----------------
  -- Term subsitution

  -- Given a RBinApp representing a type (t₁ ▵ t₂), will return a
  -- non-deterministic substitution of t₂ for t₁ in a given goal g.
  -- If no substitution could be performed, the empty list will be returned.
  _[_] : {A : Set}{{eqA : Eq A}} → RTerm A → RTerm A × RTerm A → NonDet (RTerm A)
  g [ ty1 , ty2 ] = map p2 (filter p1 (substRTermAux g ty1 ty2))
    where
      -- Non-deterministic term substitution. Possibly empty substitution.
      -- Since we're only interested in the situations where a single substitution is performed,
      -- we also return a boolean flag indicating whether or not we already had a substitution.
      substRTermAux : {A : Set}{{ eqA : Eq A }} → RTerm A → RTerm A → RTerm A → NonDet (Bool × RTerm A)
      substRTermAux {A} {{eqA}} t m n with t ≟-RTerm m
      ...| yes _ = return (true , n)
      ...| no  _ = substStep t m n
        where
          mutual
            substStep : RTerm A → RTerm A → RTerm A → NonDet (Bool × RTerm A)
            substStep (ovar x) _ _ = return (false , ovar x)
            substStep (ivar n) _ _ = return (false , ivar n)
            substStep (rlit l) _ _ = return (false , rlit l)
            substStep (rlam t) m n = substRTermAux t m n >>= return ∘ (λ p → p1 p , rlam (p2 p))
            substStep (rapp a as) m n = substStep* as m n >>= return ∘ (λ p → p1 p , rapp a (p2 p))

            -- For the list scenario, in the inductive step, we need to substitute m for n in x,
            -- and return either the result of such substitution or the result of substituting
            -- m for n recursively in la. Do not forget that _++_ is mplus for the list monad.
            substStep* : List (RTerm A) → RTerm A → RTerm A → NonDet (Bool × List (RTerm A))
            substStep* [] _ _         = return (false , [])
            substStep* (x ∷ la) m n
              = substRTermAux x m n >>= λ x' → return (p1 x' , (p2 x' ∷ la))
                                            ++ (substStep* la m n >>= return ∘ (λ p → p1 p , x ∷ p2 p))

  -- Given a term and a type ty with n variables, will search for n subterms of t
  -- in a non-deterministic fashion, and will instantiate them as parameters to ty.
  {-# TERMINATING #-}
  apply : {n : ℕ} → RTerm ⊥ → RBinApp (Fin n) → NonDet (RTerm ⊥)
  -- If we have no more variables to instantiate on our type,
  -- we can proceed to substitute.
  apply {n = zero} g (_ , ty1 , ty2)
    = g [ Fin2RTerm⊥ ty1 , Fin2RTerm⊥ ty2 ]

  -- If not, we simply call with a recursively smaller n
  apply {n = suc n} g t = inst g t >>= apply g
    where
      -- Easy way of discarding the last variable of a Fin n.
      -- Mainly, we map Fin (1 + n) to 1 + Fin n.
      thin : {n : ℕ} → Fin (suc n) → Maybe (Fin n)
      thin {zero} _       = nothing
      thin {suc n} fz     = just fz
      thin {suc n} (fs x) with thin x
      ...| nothing = nothing
      ...| just x' = just (fs x')

      -- Given a closed term t, returns a substitution σ defined
      -- by σ(n+1) = t, σ(k, k ≤ n) = var k.
      ▵_ : {n : ℕ} → RTerm ⊥ → Fin (suc n) → RTerm (Fin n)
      ▵_ {n} t x with thin x
      ...| nothing = replace-A (λ ()) t
      ...| just x' = ovar x'

      {-# TERMINATING #-}
      mk-inst-f : {n : ℕ} → RTerm ⊥ → NonDet (Fin (suc n) → RTerm (Fin n))
      mk-inst-f (ovar ())
      mk-inst-f (ivar n) = return (▵ (ivar n))
      mk-inst-f (rlit l) = return (▵ (rlit l))
      mk-inst-f (rlam t) with height (rlam t) ≤? maxH
      ...| yes _ = return (▵ (rlam t)) ++ mk-inst-f t
      ...| no  _ = mk-inst-f t
      mk-inst-f (rapp n ts) with height (rapp n ts) ≤? maxH
      ...| yes _ = return (▵ (rapp n ts)) ++ concat (mapM mk-inst-f ts)
      ...| no  _ = concat (mapM mk-inst-f ts)

      -- Given a term t and a type with (n+1) variables, instantiate the last variable
      -- from the type with a non-deterministic subterm of t, returns the resulting type.
      inst : {n : ℕ} → RTerm ⊥ → RBinApp (Fin (suc n)) → NonDet (RBinApp (Fin n))
      inst {n} t (r , ty1 , ty2) = mk-inst-f {n} t >>= λ f → return (r , replace-A f ty1 , replace-A f ty2)

  -- TODO: Use vectors instead of lists...

  -- Given a goal (a ▵ b) and a list of types L, try to find intermediate goals g₁⋯gₙ such
  -- that ∀n . tyₙ ∈ L ⇒ tyₙ : gₙ₋₁ → gₙ , where g₀ = a and gₖ = b.
  divideGoal : RBinApp ⊥ → List (Σ ℕ (RBinApp ∘ Fin)) → Maybe (List (RTerm ⊥))
  divideGoal (gh , g1 , g2) l = sfHead (filter chainIsValid (stepGoals g1 l))
    where
      chainIsValid : List (RTerm ⊥) → Bool
      chainIsValid [] = false
      chainIsValid (x ∷ []) with x ≟-RTerm g2
      ...| yes _ = true
      ...| no  _ = false
      chainIsValid (x ∷ l) = chainIsValid l

      sfHead : {A : Set} → List A → Maybe A
      sfHead [] = nothing
      sfHead (x ∷ _) = just x

      -- Given a list of types, will return a possible list of goals that
      -- could be discharged by those types.
      stepGoals : RTerm ⊥ → List (Σ ℕ (RBinApp ∘ Fin)) → NonDet (List (RTerm ⊥))
      stepGoals g []       = return (g ∷ [])
      stepGoals g ((nₜ , t) ∷ ts) = apply g t ++ apply g (symmetric t)
                                >>= (λ g' → stepGoals g' ts
                                >>= return ∘ (_∷_ g))

  module Test where

    goal : RTerm ⊥
    goal = rapp (rdef (quote _≡_))
      (rapp (rdef (quote _+_)) (ivar 0 ∷ ivar 1 ∷ []) ∷
       rapp (rdef (quote _+_))
       (ivar 0 ∷
        rapp (rdef (quote _+_)) (ivar 1 ∷ rapp (rcon (quote zero)) [] ∷ [])
        ∷ [])
       ∷ [])

    binGoal : RBinApp ⊥
    binGoal = rdef (quote _≡_)
            , rapp (rdef (quote _+_)) (ivar 0 ∷ ivar 1 ∷ [])
            , rapp (rdef (quote _+_)) (ivar 0 ∷ (rapp (rdef (quote _+_)) (ivar 1 ∷ (rapp (rcon (quote zero)) []) ∷ []) ∷ []))

    +-ri : RBinApp (Fin 1)
    +-ri = rdef (quote _≡_)
         , rapp (rdef (quote _+_)) (ovar fz ∷ rapp (rcon (quote zero)) [] ∷ [])
         , ovar fz

    +-a : RBinApp (Fin 3)
    +-a = rdef (quote _≡_)
        , rapp (rdef (quote _+_)) (rapp (rdef (quote _+_)) (ovar (fs $ fs fz) ∷ ovar (fs fz) ∷ []) ∷ ovar fz ∷ [])
        , rapp (rdef (quote _+_)) (ovar (fs $ fs fz) ∷ rapp (rdef (quote _+_)) (ovar (fs fz) ∷ ovar fz ∷ []) ∷ [])

    tylist : List (Σ ℕ (RBinApp ∘ Fin))
    tylist = (1 , +-ri) ∷ (3 , +-a) ∷ []


{- 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
-}

module Haskell.Modules.ToBool where

open import Data.Bool hiding (not)
import      Function
import      Relation.Nullary                as RN
import      Relation.Nullary.Decidable.Core as RNDC

record ToBool {a}(A : Set a) : Set a where
  field
    toBool : A → Bool
open ToBool {{ ... }} public

not : ∀ {b} {B : Set b} ⦃ _ : ToBool B ⦄ → B → Bool
not b = Data.Bool.not (toBool b)

instance
  ToBool-Bool : ToBool Bool
  ToBool-Bool = record { toBool = Function.id }

  ToBool-Dec : ∀{a}{A : Set a} → ToBool (RN.Dec A)
  ToBool-Dec = record { toBool = RNDC.⌊_⌋ }


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

open import Relation.Binary using (Rel ; Preorder ; IsPreorder)

import Data.Nat as ℕ
import Data.Nat.Induction as ℕ
import Data.Nat.Properties as ℕ
import Relation.Binary.Construct.On as On

open import Model.RGraph as RG using (RGraph)
open import Source.Size as S using (Δ ; Ω)
open import Source.Size.Substitution.Universe using (⟨_⟩ ; Sub⊢ᵤ)
open import Util.HoTT.HLevel
open import Util.Induction.WellFounded as WFInd using (Acc ; acc ; WellFounded)
open import Util.Prelude

import Source.Size.Substitution.Canonical as SC
import Source.Size.Substitution.Universe as S

open S.Ctx
open S.Size
open S.Sub
open S.Sub⊢ᵤ
open S.Var
open S._<_ hiding (<-trans)

infix 4 _<_ _≤_

private
  variable
    i j k : ℕ

{-
This is an encoding of the set of ordinals

  ℕ ∪ { ω + i | i ∈ ℕ }

i.e. of the ordinals below ω*2.
-}
data Size : Set where
  zero+ : (i : ℕ) → Size
  ∞+ : (i : ℕ) → Size

variable
  n m o : Size

nat : ℕ → Size
nat = zero+

abstract
  zero+-inj : zero+ i ≡ zero+ j → i ≡ j
  zero+-inj refl = refl

  zero+-≡-canon : (p : zero+ i ≡ zero+ j) → p ≡ cong zero+ (zero+-inj p)
  zero+-≡-canon refl = refl

  ∞+-inj : ∞+ i ≡ ∞+ j → i ≡ j
  ∞+-inj refl = refl

  ∞+-≡-canon : (p : ∞+ i ≡ ∞+ j) → p ≡ cong ∞+ (∞+-inj p)
  ∞+-≡-canon refl = refl

  Size-IsSet : IsSet Size
  Size-IsSet {zero+ i} {zero+ j} p refl
    = trans (zero+-≡-canon p) (cong (cong zero+) (ℕ.≡-irrelevant _ _))
  Size-IsSet {∞+ i} {∞+ j} p refl
    = trans (∞+-≡-canon p) (cong (cong ∞+) (ℕ.≡-irrelevant _ _))

data _<_ : (n m : Size) → Set where
  zero+ : (i<j : i ℕ.< j) → zero+ i < zero+ j
  ∞+ : (i<j : i ℕ.< j) → ∞+ i < ∞+ j
  zero<∞ : zero+ i < ∞+ j

data _≤_ (n m : Size) : Set where
  reflexive : n ≡ m → n ≤ m
  <→≤ : n < m → n ≤ m

pattern ≤-refl = reflexive refl

abstract
  <-trans : n < m → m < o → n < o
  <-trans (zero+ i<j) (zero+ j<k) = zero+ (ℕ.<-trans i<j j<k)
  <-trans (zero+ i<j) zero<∞ = zero<∞
  <-trans (∞+ i<j) (∞+ j<k) = ∞+ (ℕ.<-trans i<j j<k)
  <-trans zero<∞ (∞+ i<j) = zero<∞

  ≤→<→< : n ≤ m → m < o → n < o
  ≤→<→< ≤-refl m<o = m<o
  ≤→<→< (<→≤ n<m) m<o = <-trans n<m m<o

  <→≤→< : n < m → m ≤ o → n < o
  <→≤→< n<m ≤-refl = n<m
  <→≤→< n<m (<→≤ m<o) = <-trans n<m m<o

  ≤-trans : n ≤ m → m ≤ o → n ≤ o
  ≤-trans n≤m ≤-refl = n≤m
  ≤-trans n≤m (<→≤ m<o) = <→≤ (≤→<→< n≤m m<o)

⟦zero⟧ ⟦∞⟧ : Size
⟦zero⟧ = zero+ 0
⟦∞⟧ = ∞+ 0

⟦suc⟧ : Size → Size
⟦suc⟧ (zero+ i) = zero+ (suc i)
⟦suc⟧ (∞+ i) = ∞+ (suc i)

abstract
  ⟦zero⟧<⟦suc⟧ : ⟦zero⟧ < ⟦suc⟧ n
  ⟦zero⟧<⟦suc⟧ {zero+ i} = zero+ (ℕ.s≤s ℕ.z≤n)
  ⟦zero⟧<⟦suc⟧ {∞+ i} = zero<∞

  ⟦zero⟧<⟦∞⟧ : ⟦zero⟧ < ⟦∞⟧
  ⟦zero⟧<⟦∞⟧ = zero<∞

  ⟦suc⟧<⟦suc⟧ : n < m → ⟦suc⟧ n < ⟦suc⟧ m
  ⟦suc⟧<⟦suc⟧ (zero+ i<j) = zero+ (ℕ.s≤s i<j)
  ⟦suc⟧<⟦suc⟧ (∞+ i<j) = ∞+ (ℕ.s≤s i<j)
  ⟦suc⟧<⟦suc⟧ zero<∞ = zero<∞

  ⟦suc⟧<⟦∞⟧ : n < ⟦∞⟧ → ⟦suc⟧ n < ⟦∞⟧
  ⟦suc⟧<⟦∞⟧ zero<∞ = zero<∞

  <⟦suc⟧ : n < ⟦suc⟧ n
  <⟦suc⟧ {zero+ i} = zero+ (ℕ.s≤s ℕ.≤-refl)
  <⟦suc⟧ {∞+ i} = ∞+ (ℕ.s≤s ℕ.≤-refl)

Size< : Size → Set
Size< n = ∃[ m ] (m < n)

mutual
  ⟦_⟧Δ′ : S.Ctx → Set
  ⟦ [] ⟧Δ′ = ⊤
  ⟦ Δ ∙ n ⟧Δ′ = Σ[ δ ∈ ⟦ Δ ⟧Δ′ ] (Size< (⟦ n ⟧n′ δ))

  ⟦_⟧x′ : S.Var Δ → ⟦ Δ ⟧Δ′ → Size
  ⟦ zero ⟧x′ (δ , n , _) = n
  ⟦ suc x ⟧x′ (δ , _ , _) = ⟦ x ⟧x′ δ

  ⟦_⟧n′ : S.Size Δ → ⟦ Δ ⟧Δ′ → Size
  ⟦ var x ⟧n′ = ⟦ x ⟧x′
  ⟦ ∞ ⟧n′ _ = ⟦∞⟧
  ⟦ zero ⟧n′ _ = ⟦zero⟧
  ⟦ suc n ⟧n′ = ⟦suc⟧ ∘ ⟦ n ⟧n′

abstract
  ⟦wk⟧ : ∀ (n m : S.Size Δ) {δ} → ⟦ S.wk {n = n} m ⟧n′ δ ≡ ⟦ m ⟧n′ (proj₁ δ)
  ⟦wk⟧ n (var x) = refl
  ⟦wk⟧ n ∞ = refl
  ⟦wk⟧ n zero = refl
  ⟦wk⟧ n (suc m) = cong ⟦suc⟧ (⟦wk⟧ n m)

  ⟦<⟧ₓ : ∀ (x : S.Var Δ) {δ}
    → ⟦ x ⟧x′ δ < ⟦ S.bound x ⟧n′ δ
  ⟦<⟧ₓ {Δ ∙ n} zero {δ , m , m<n} = subst (m <_) (sym (⟦wk⟧ n n)) m<n
  ⟦<⟧ₓ {Δ ∙ n} (suc x) {δ , m , m<n}
    = subst (⟦ x ⟧x′ δ <_) (sym (⟦wk⟧ n (S.bound x))) (⟦<⟧ₓ x)

  ⟦<⟧ : ∀ {n m : S.Size Δ} {δ}
    → n S.< m
    → ⟦ n ⟧n′ δ < ⟦ m ⟧n′ δ
  ⟦<⟧ (var {x = x} refl) = ⟦<⟧ₓ x
  ⟦<⟧ zero<suc = ⟦zero⟧<⟦suc⟧
  ⟦<⟧ zero<∞ = ⟦zero⟧<⟦∞⟧
  ⟦<⟧ (suc<suc n<m) = ⟦suc⟧<⟦suc⟧ (⟦<⟧ n<m)
  ⟦<⟧ (suc<∞ n<m) = ⟦suc⟧<⟦∞⟧ (⟦<⟧ n<m)
  ⟦<⟧ (S.<-trans n<m m<o) = <-trans (⟦<⟧ n<m) (⟦<⟧ m<o)
  ⟦<⟧ <suc = <⟦suc⟧

  <-irrefl : ¬ n < n
  <-irrefl {zero+ i} (zero+ i<i) = ℕ.<⇒≢ i<i refl
  <-irrefl {∞+ i} (∞+ i<i) = ℕ.<⇒≢ i<i refl

  ≤-antisym : n ≤ m → m ≤ n → n ≡ m
  ≤-antisym ≤-refl m≤n = refl
  ≤-antisym (<→≤ n<m) m≤n = ⊥-elim (<-irrefl (<→≤→< n<m m≤n))

  <-IsProp : IsProp (n < m)
  <-IsProp (zero+ i<j) (zero+ i<j₁) = cong zero+ (ℕ.<-irrelevant _ _)
  <-IsProp (∞+ i<j) (∞+ i<j₁) = cong ∞+ (ℕ.<-irrelevant _ _)
  <-IsProp zero<∞ zero<∞ = refl

  ≤-IsProp : IsProp (n ≤ m)
  ≤-IsProp (reflexive p) (reflexive q) = cong reflexive (Size-IsSet _ _)
  ≤-IsProp ≤-refl (<→≤ q) = ⊥-elim (<-irrefl q)
  ≤-IsProp (<→≤ p) ≤-refl = ⊥-elim (<-irrefl p)
  ≤-IsProp (<→≤ p) (<→≤ q) = cong <→≤ (<-IsProp p q)

  Size<-≡⁺ : (m k : Size< n) → proj₁ m ≡ proj₁ k → m ≡ k
  Size<-≡⁺ (m , _) (k , _) refl = cong (m ,_) (<-IsProp _ _)

  Size<-IsSet : ∀ {n} → IsSet (Size< n)
  Size<-IsSet = Σ-IsSet Size-IsSet λ _ → IsOfHLevel-suc 1 <-IsProp

  ⟦Δ⟧-IsSet : ∀ Δ → IsSet ⟦ Δ ⟧Δ′
  ⟦Δ⟧-IsSet [] = ⊤-IsSet
  ⟦Δ⟧-IsSet (Δ ∙ n) = Σ-IsSet (⟦Δ⟧-IsSet Δ) λ _ → Size<-IsSet

⟦Δ⟧-HSet : S.Ctx → HSet 0ℓ
⟦Δ⟧-HSet Δ = HLevel⁺ _ (⟦Δ⟧-IsSet Δ)

abstract
  ⟦Δ∙n⟧-≡⁺ : ∀ Δ (n : S.Size Δ) {δ δ′ : ⟦ Δ ⟧Δ′} {m m′ : Size}
    → (m<n : m < ⟦ n ⟧n′ δ)
    → (m′<n : m′ < ⟦ n ⟧n′ δ′)
    → δ ≡ δ′
    → m ≡ m′
    → (δ , m , m<n) ≡ (δ′ , m′ , m′<n)
  ⟦Δ∙n⟧-≡⁺  Δ n {δ} _ _ refl eq₂
    = cong (δ ,_) (Size<-≡⁺ _ _ eq₂)

  zero+-<ℕ-acc→<-acc : Acc ℕ._<_ i → Acc _<_ (zero+ i)
  zero+-<ℕ-acc→<-acc (acc rs) = acc λ where
    (zero+ i) (zero+ i<j) → zero+-<ℕ-acc→<-acc (rs i i<j)

  zero+-acc : Acc _<_ (zero+ i)
  zero+-acc = zero+-<ℕ-acc→<-acc (ℕ.<-wellFounded _)

  ∞+-<ℕ-acc→<-acc : Acc ℕ._<_ i → Acc _<_ (∞+ i)
  ∞+-<ℕ-acc→<-acc (acc rs) = acc λ where
    (∞+ i) (∞+ i<j) → ∞+-<ℕ-acc→<-acc (rs i i<j)
    (zero+ i) zero<∞ → zero+-acc

  ∞+-acc : Acc _<_ (∞+ i)
  ∞+-acc = ∞+-<ℕ-acc→<-acc (ℕ.<-wellFounded _)

  <-wf : WellFounded _<_
  <-wf m = acc λ where
    _ (zero+ i<j) → zero+-acc
    _ (∞+ i<j) → ∞+-acc
    _ zero<∞ → zero+-acc

open WFInd.Build <-wf public using () renaming
  ( wfInd to <-ind
  ; wfRec to <-rec
  ; wfInd-unfold to <-ind-unfold
  ; wfRec-unfold to <-rec-unfold
  ; wfInd-ind to <-ind-ind
  ; wfIndΣ to <-indΣ
  ; wfIndΣ-unfold to <-indΣ-unfold
  ; wfIndΣ′ to <-indΣ′
  )

<-ind-ind₂ = WFInd.wfInd-ind₂ <-wf

mutual
  ⟦_⟧σ′ : ∀ {σ} → σ ∶ Δ ⇒ᵤ Ω → ⟦ Δ ⟧Δ′ → ⟦ Ω ⟧Δ′
  ⟦ Id ⟧σ′ δ = δ
  ⟦ comp σ τ ⟧σ′ δ = ⟦ τ ⟧σ′ (⟦ σ ⟧σ′ δ)
  ⟦ Wk ⟧σ′ (δ , m) = δ
  ⟦ Lift {n = n} σ refl ⟧σ′ (δ , m , m<n)
    = ⟦ σ ⟧σ′ δ , m , subst (m <_) (⟦sub⟧ σ n) m<n
  ⟦ Sing {n = n} n<m ⟧σ′ δ = δ , ⟦ n ⟧n′ δ , ⟦<⟧ n<m
  ⟦ Skip ⟧σ′ ((δ , m , m<n) , k , k<m) = δ , k , <-trans k<m m<n

  abstract
    ⟦subV′⟧ : ∀ {σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) (x : S.Var Ω) {δ}
      → ⟦ S.subV′ σ x ⟧n′ δ ≡ ⟦ x ⟧x′ (⟦ ⊢σ ⟧σ′ δ)
    ⟦subV′⟧ Id x = refl
    ⟦subV′⟧ (comp {σ = σ} {τ = τ} ⊢σ ⊢τ) x
      = trans (⟦sub′⟧ ⊢σ (S.subV′ τ x)) (⟦subV′⟧ ⊢τ x)
    ⟦subV′⟧ Wk x = refl
    ⟦subV′⟧ (Lift ⊢σ refl) zero {δ , m} = refl
    ⟦subV′⟧ (Lift {σ = σ} {n = n} ⊢σ refl) (suc x) {δ , m}
      rewrite ⟦wk⟧ (S.sub σ n) (S.subV′ σ x) {δ , m}
      = ⟦subV′⟧ ⊢σ x
    ⟦subV′⟧ (Sing n<m) zero = refl
    ⟦subV′⟧ (Sing n<m) (suc x) = refl
    ⟦subV′⟧ Skip zero = refl
    ⟦subV′⟧ Skip (suc x) = refl

    ⟦sub′⟧ : ∀ {σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) (n : S.Size Ω) {δ}
      → ⟦ S.sub′ σ n ⟧n′ δ ≡ ⟦ n ⟧n′ (⟦ ⊢σ ⟧σ′ δ)
    ⟦sub′⟧ σ (var x) = ⟦subV′⟧ σ x
    ⟦sub′⟧ σ ∞ = refl
    ⟦sub′⟧ σ zero = refl
    ⟦sub′⟧ σ (suc n) = cong ⟦suc⟧ (⟦sub′⟧ σ n)

    ⟦sub⟧ :  ∀ {σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) (n : S.Size Ω) {δ}
      → ⟦ S.sub σ n ⟧n′ δ ≡ ⟦ n ⟧n′ (⟦ ⊢σ ⟧σ′ δ)
    ⟦sub⟧ {σ = σ} ⊢σ n {δ}
      = trans (cong (λ k → ⟦ k ⟧n′ δ) (sym (S.sub′≡sub σ n))) (⟦sub′⟧ ⊢σ n)

abstract
  ⟦subV⟧ : ∀ {σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) (x : S.Var Ω) {δ}
    → ⟦ S.subV σ x ⟧n′ δ ≡ ⟦ x ⟧x′ (⟦ ⊢σ ⟧σ′ δ)
  ⟦subV⟧ {σ = σ} ⊢σ x {δ}
    = trans (cong (λ k → ⟦ k ⟧n′ δ) (sym (S.subV′≡subV σ x))) (⟦subV′⟧ ⊢σ x)

  ⟦⟧σ-param : ∀ {σ} (p q : σ ∶ Δ ⇒ᵤ Ω) {δ}
    → ⟦ p ⟧σ′ δ ≡ ⟦ q ⟧σ′ δ
  ⟦⟧σ-param Id Id = refl
  ⟦⟧σ-param (comp p p′) (comp q q′)
    = trans (⟦⟧σ-param p′ q′) (cong (⟦ q′ ⟧σ′) (⟦⟧σ-param p q))
  ⟦⟧σ-param Wk Wk = refl
  ⟦⟧σ-param {Ω = Ω ∙ m} (Lift p refl) (Lift q m≡n[σ]₁)
    rewrite S.Size-IsSet m≡n[σ]₁ refl
    = ⟦Δ∙n⟧-≡⁺ Ω m _ _ (⟦⟧σ-param p q) refl
  ⟦⟧σ-param {Δ = Δ} {σ = Sing {m = m} n} (Sing n<m) (Sing n<m₁)
    = ⟦Δ∙n⟧-≡⁺ Δ m (⟦<⟧ n<m) (⟦<⟧ n<m₁) refl refl
  ⟦⟧σ-param Skip Skip = refl

⟦_⟧Δ : S.Ctx → RGraph
⟦ Δ ⟧Δ = record
  { ObjHSet = ⟦Δ⟧-HSet Δ
  ; eqHProp = λ _ _ → ⊤-HProp
  }

Sizes : RGraph
Sizes = record
  { ObjHSet = HLevel⁺ Size Size-IsSet
  ; eqHProp = λ _ _ → ⊤-HProp
  }

⟦_⟧n : ∀ {Δ} (n : S.Size Δ) → ⟦ Δ ⟧Δ RG.⇒ Sizes
⟦ n ⟧n = record
  { fobj = ⟦ n ⟧n′
  }

⟦_⟧σ : ∀ {Δ Ω σ} → σ ∶ Δ ⇒ᵤ Ω → ⟦ Δ ⟧Δ RG.⇒ ⟦ Ω ⟧Δ
⟦ σ ⟧σ = record
  { fobj = ⟦ σ ⟧σ′
  }

data _≤′_ : (n m : Size) → Set where
  zero+ : (i≤j : i ℕ.≤ j) → zero+ i ≤′ zero+ j
  ∞+ : (i≤j : i ℕ.≤ j) → ∞+ i ≤′ ∞+ j
  zero<∞ : zero+ i ≤′ ∞+ j

abstract
  ≤→≤′ : n ≤ m → n ≤′ m
  ≤→≤′ {zero+ i} ≤-refl = zero+ ℕ.≤-refl
  ≤→≤′ {∞+ i} ≤-refl = ∞+ ℕ.≤-refl
  ≤→≤′ (<→≤ (zero+ i<j)) = zero+ (ℕ.<⇒≤ i<j)
  ≤→≤′ (<→≤ (∞+ i<j)) = ∞+ (ℕ.<⇒≤ i<j)
  ≤→≤′ (<→≤ zero<∞) = zero<∞

  ≤′→≤ : n ≤′ m → n ≤ m
  ≤′→≤ (zero+ i≤j) with ℕ.≤⇒≤′ i≤j
  ... | ℕ.≤′-refl = ≤-refl
  ... | ℕ.≤′-step i≤′j = <→≤ (zero+ (ℕ.s≤s (ℕ.≤′⇒≤ i≤′j)))
  ≤′→≤ (∞+ i≤j) with ℕ.≤⇒≤′ i≤j
  ... | ℕ.≤′-refl = ≤-refl
  ... | ℕ.≤′-step i≤′j = <→≤ (∞+ (ℕ.s≤s (ℕ.≤′⇒≤ i≤′j)))
  ≤′→≤ zero<∞ = <→≤ zero<∞

  0≤n : ⟦zero⟧ ≤ n
  0≤n {zero+ zero} = ≤-refl
  0≤n {zero+ (suc i)} = <→≤ (zero+ (ℕ.s≤s ℕ.z≤n))
  0≤n {∞+ i} = <→≤ zero<∞

  n<m→Sn≤m : n < m → ⟦suc⟧ n ≤ m
  n<m→Sn≤m (zero+ (ℕ.s≤s i≤j)) = ≤′→≤ (zero+ (ℕ.s≤s i≤j))
  n<m→Sn≤m (∞+ (ℕ.s≤s i≤j)) = ≤′→≤ (∞+ (ℕ.s≤s i≤j))
  n<m→Sn≤m zero<∞ = <→≤ zero<∞

  Sn≤m→n<m : ⟦suc⟧ n ≤ m → n < m
  Sn≤m→n<m ≤-refl = <⟦suc⟧
  Sn≤m→n<m (<→≤ Sn<m) = <-trans <⟦suc⟧ Sn<m


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Correctness of differentiation (Lemma 3.10 and Theorem 3.11).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity
import Parametric.Change.Specification as Specification
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue
import Parametric.Change.Evaluation as ChangeEvaluation
import Parametric.Change.Derive as Derive
import Parametric.Change.Implementation as Implementation

module Parametric.Change.Correctness
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (nil-base : ChangeTerm.NilStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (⟦nil-base⟧ : ChangeValue.NilStructure Const ⟦_⟧Base ΔBase)
    (meaning-⊕-base : ChangeEvaluation.ApplyStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base nil-base ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧)
    (meaning-⊝-base : ChangeEvaluation.DiffStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base nil-base ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧)
    (meaning-onil-base : ChangeEvaluation.NilStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base nil-base ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧)
    {{validity-structure : Validity.Structure ⟦_⟧Base}}
    (derive-const : Derive.Structure Const ΔBase)
    (implementation-structure : Implementation.Structure
      Const ⟦_⟧Base ⟦_⟧Const ΔBase
      ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧ derive-const)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base {{validity-structure}}
open Specification.Structure Const ⟦_⟧Base ⟦_⟧Const
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase apply-base diff-base nil-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
open ChangeEvaluation.Structure
  ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base nil-base
  ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
  meaning-⊕-base meaning-⊝-base meaning-onil-base
open Derive.Structure Const ΔBase derive-const
open Implementation.Structure implementation-structure
-- The denotational properties of the `derive` transformation.
-- In particular, the main theorem about it producing the correct
-- incremental behavior.

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

-- Extension point: A proof that change evaluation for a
-- primitive is related to the value of incrementalizing
-- this primitive.
Structure : Set
Structure = ∀ {τ} (c : Const τ) →
  nil₍ τ ₎ ⟦ c ⟧Const ≈₍ τ ₎ ⟦ derive-const c ⟧Term ∅

module Structure (derive-const-correct : Structure) where
  deriveVar-correct : ∀ {τ Γ} (x : Var Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ x ⟧ΔVar ρ dρ ≈₍ τ ₎ ⟦ deriveVar x ⟧ (alternate ρ ρ′)
  deriveVar-correct this (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = dv≈dv′
  deriveVar-correct (that x) (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = deriveVar-correct x ρ dρ dρ′ dρ≈dρ′

  derive-const-env-irrelevant : ∀ {Γ τ} (c : Const τ) → (ρ : ⟦ ΔContext Γ ⟧) → ⟦ weaken ∅≼Γ (derive-const c) ⟧Term ρ ≡
      ⟦ derive-const c ⟧Term ∅
  derive-const-env-irrelevant {Γ} c ρ =
    trans
      (weaken-sound {Γ₁≼Γ₂ = (∅≼Γ {ΔContext Γ})} (derive-const c) ρ)
      (cong ⟦ derive-const c ⟧Term (⟦∅≼Γ⟧-∅ ρ))
  -- We provide: A variant of Lemma 3.10 for arbitrary contexts.
  derive-correct : ∀ {τ Γ} (t : Term Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ t ⟧Δ ρ dρ ≈₍ τ ₎ ⟦ derive t ⟧ (alternate ρ ρ′)

  derive-correct {τ} {Γ} (const c) ρ dρ ρ′ dρ≈ρ′ =
    subst (implements τ (nil₍ τ ₎ ⟦ c ⟧Const))
      (sym (derive-const-env-irrelevant c (alternate ρ ρ′)))
      (derive-const-correct c)
  derive-correct (var x) ρ dρ ρ′ dρ≈ρ′ =
    deriveVar-correct x ρ dρ ρ′ dρ≈ρ′
  derive-correct (app {σ} {τ} s t) ρ dρ ρ′ dρ≈ρ′
   = subst (λ ⟦t⟧ → ⟦ app s t ⟧Δ ρ dρ ≈₍ τ ₎ (⟦ derive s ⟧Term (alternate ρ ρ′)) ⟦t⟧ (⟦ derive t ⟧Term (alternate ρ ρ′))) (⟦fit⟧ t ρ ρ′)
       (derive-correct {σ ⇒ τ} s ρ dρ ρ′ dρ≈ρ′
          (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ) (⟦ derive t ⟧ (alternate ρ ρ′)) (derive-correct {σ} t ρ dρ ρ′ dρ≈ρ′))

  derive-correct (abs {σ} {τ} t) ρ dρ ρ′ dρ≈ρ′ =
    λ w dw w′ dw≈w′ →
      derive-correct t (w • ρ) (dw • dρ) (w′ • ρ′) (dw≈w′ • dρ≈ρ′)

  derive-correct-closed : ∀ {τ} (t : Term ∅ τ) →
    ⟦ t ⟧Δ ∅ ∅ ≈₍ τ ₎ ⟦ derive t ⟧ ∅

  derive-correct-closed t = derive-correct t ∅ ∅ ∅ ∅

  -- And we proof Theorem 3.11, finally.
  main-theorem : ∀ {σ τ}
    {f : Term ∅ (σ ⇒ τ)} {s : Term ∅ σ} {ds : Term ∅ (ΔType σ)} →
    {dv : Δ₍ σ ₎ (⟦ s ⟧ ∅)} {erasure : dv ≈₍ σ ₎ (⟦ ds ⟧ ∅)} →

    ⟦ app f (s ⊕₍ σ ₎ ds) ⟧ ≡ ⟦ app f s ⊕₍ τ ₎ app (app (derive f) s) ds ⟧

  main-theorem {σ} {τ} {f} {s} {ds} {dv} {erasure} =
    let
      g  = ⟦ f ⟧ ∅
      Δg = ⟦ f ⟧Δ ∅ ∅
      Δg′ = ⟦ derive f ⟧ ∅
      v  = ⟦ s ⟧ ∅
      dv′ = ⟦ ds ⟧ ∅
      u  = ⟦ s ⊕₍ σ ₎ ds ⟧ ∅
      -- Δoutput-term = app (app (derive f) x) (y ⊝ x)
    in
      ext {A = ⟦ ∅ ⟧Context} (λ { ∅ →
      begin
        g u
      ≡⟨ cong g (sym (meaning-⊕ {t = s} {Δt = ds})) ⟩
        g (v ⟦⊕₍ σ ₎⟧ dv′)
      ≡⟨ cong g (sym (carry-over {σ} dv erasure)) ⟩
        g (v ⊞₍ σ ₎ dv)
      ≡⟨ corollary-closed {σ} {τ} f v dv ⟩
        g v ⊞₍ τ ₎ call-change {σ} {τ} Δg v dv
      ≡⟨ carry-over {τ} (call-change {σ} {τ} Δg v dv)
           (derive-correct-closed f v dv dv′ erasure) ⟩
        g v ⟦⊕₍ τ ₎⟧ Δg′ v dv′
      ≡⟨ meaning-⊕ {t = app f s} {Δt = app (app (derive f) s) ds} ⟩
        ⟦ app f s ⊕₍ τ ₎ app (app (derive f) s) ds ⟧ ∅
      ∎}) where open ≡-Reasoning


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Unit {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Introductions.Universe
open import Definition.LogicalRelation.Irrelevance

open import Tools.Unit
open import Tools.Product

-- Validity of the Unit type.
Unitᵛ : ∀ {Γ l} ([Γ] : ⊩ᵛ Γ) → Γ ⊩ᵛ⟨ l ⟩ Unit / [Γ]
Unitᵛ [Γ] ⊢Δ [σ] = Unitᵣ (idRed:*: (Unitⱼ ⊢Δ)) , λ _ x₂ → id (Unitⱼ ⊢Δ)

-- Validity of the Unit type as a term.
Unitᵗᵛ : ∀ {Γ} ([Γ] : ⊩ᵛ Γ)
    → Γ ⊩ᵛ⟨ ¹ ⟩ Unit ∷ U / [Γ] / Uᵛ [Γ]
Unitᵗᵛ [Γ] ⊢Δ [σ] = let ⊢Unit  = Unitⱼ ⊢Δ
                        [Unit] = Unitᵣ (idRed:*: (Unitⱼ ⊢Δ))
                    in  Uₜ Unit (idRedTerm:*: ⊢Unit) Unitₙ (≅ₜ-Unitrefl ⊢Δ) [Unit]
                    ,   (λ x x₁ → Uₜ₌ Unit Unit (idRedTerm:*: ⊢Unit) (idRedTerm:*: ⊢Unit) Unitₙ Unitₙ
                                      (≅ₜ-Unitrefl ⊢Δ) [Unit] [Unit] (id (Unitⱼ ⊢Δ)))

-- Validity of star.
starᵛ : ∀ {Γ l} ([Γ] : ⊩ᵛ Γ)
      → Γ ⊩ᵛ⟨ l ⟩ star ∷ Unit / [Γ] / Unitᵛ [Γ]
starᵛ [Γ] ⊢Δ [σ] =
  Unitₜ star (idRedTerm:*: (starⱼ ⊢Δ)) starₙ
    , (λ _ x₁ → Unitₜ₌ (starⱼ ⊢Δ) (starⱼ ⊢Δ))

-- Validity of η-unit.
η-unitᵛ : ∀ {Γ l e e'} ([Γ] : ⊩ᵛ Γ)
  ([Unit] : Γ ⊩ᵛ⟨ l ⟩ Unit / [Γ])
  ([e] : Γ ⊩ᵛ⟨ l ⟩ e ∷ Unit / [Γ] / [Unit])
  ([e'] : Γ ⊩ᵛ⟨ l ⟩ e' ∷ Unit / [Γ] / [Unit])
  → Γ ⊩ᵛ⟨ l ⟩ e ≡ e' ∷ Unit / [Γ] / [Unit]
η-unitᵛ {Γ} {l} {e} {e'} [Γ] [Unit] [e] [e'] {Δ} {σ} ⊢Δ [σ] =
  let J = proj₁ ([Unit] ⊢Δ [σ])
      [σe] = proj₁ ([e] ⊢Δ [σ])
      [σe'] = proj₁ ([e'] ⊢Δ [σ])
      UnitJ : Δ ⊩⟨ l ⟩ Unit
      UnitJ = Unitᵣ (idRed:*: (Unitⱼ ⊢Δ))
      [σe] = irrelevanceTerm J UnitJ [σe]
      [σe'] = irrelevanceTerm J UnitJ [σe']
      ⊢σe = escapeTerm UnitJ [σe]
      ⊢σe' = escapeTerm UnitJ [σe']
  in  irrelevanceEqTerm UnitJ J (Unitₜ₌ ⊢σe ⊢σe')


{-# OPTIONS --copatterns #-}
module InstantiatedRecordModuleNoCopattern where

module M (A : Set1) where

open M      -- underapplied open
open M Set  -- fully applied open

record R : Set2 where
  constructor inn
  field
    out : Set1

r : R
r = inn Set

open R r  -- fully applied open

bla = out

-- This is an ill-formed copattern:
-- field of instantiated record module is not a projection!!
wrong : R
out wrong = Set

-- InstantiatedRecordModuleNoCopattern.agda:23,1-16
-- Not a valid projection for a copattern: out
-- when checking that the clause out wrong = Set has type R


-- Deriving TreeEncoding. Note: only for non-dependent datatypes.

module Tactic.Deriving.TreeEncoding where

open import Prelude
open import Tactic.Reflection
open import Tactic.Deriving
open import Tactic.Reflection
open import Tactic.Reflection.Quote
open import Data.TreeRep
open import Container.Traversable

private
  mapIx : ∀ {a b} {A : Set a} {B : Set b} → (Nat → A → B) → List A → List B
  mapIx f []       = []
  mapIx f (x ∷ xs) = f 0 x ∷ mapIx (f ∘ suc) xs

  -- encode (ci x₁ .. xn) = node i (treeEncode x₁) .. (treeEncode xn)
  encodeClause : Nat → Nat → Name → TC Clause
  encodeClause np i c = do
    args ← drop np <$> argTel c
    let xs = reverse (mapIx const args)
    return (clause [ vArg (con c (map (var "x" <$_) args)) ]
                   (con₂ (quote node)
                         (lit (nat i))
                         (quoteList (map (λ i → def₁ (quote treeEncode) (var i [])) xs))))

  quoteListP : List Pattern → Pattern
  quoteListP = foldr (λ p ps → con₂ (quote List._∷_) p ps) (con₀ (quote List.[]))

  qAp : Term → Term → Term
  qAp f x = def₂ (quote _<*>′_) f x

  -- decode (node i x₁ .. xn) = ⦇ cᵢ (treeDecode x₁) .. (treeDecode xn) ⦈
  decodeClause : Nat → Nat → Name → TC Clause
  decodeClause np i c = do
    args ← drop np <$> argTel c
    let xs = reverse (mapIx const args)
    pure (clause [ vArg (con₂ (quote node) (lit (nat i)) (quoteListP (map (λ _ → var "x") args))) ]
                 (foldl qAp (con₁ (quote just) (con₀ c))
                            (map (λ i → def₁ (quote treeDecode) (var i [])) xs)))

  encodeClauses : Name → TC (List Clause)
  encodeClauses d = do
    cs ← getConstructors d
    np ← getParameters d
    traverse id (mapIx (encodeClause np) cs)

  decodeClauses : Name → TC (List Clause)
  decodeClauses d = do
    cs ← getConstructors d
    np ← getParameters d
    cs ← traverse id (mapIx (decodeClause np) cs)
    pure (cs ++ clause (vArg (var "_") ∷ []) (con₀ (quote nothing)) ∷ [])

  proofClause : Nat → Nat → Name → TC Clause
  proofClause np i c = do
    args ← drop np <$> argTel c
    let xs = reverse (mapIx const args)
    pure (clause [ vArg (con c (map (var "x" <$_) args)) ]
                 (foldl (λ eq eq₁ → def₂ (quote _=*=′_) eq eq₁)
                        (con₀ (quote refl))
                        (map (λ i → def₁ (quote isTreeEmbedding) (var i [])) xs)))

  proofClauses : Name → TC (List Clause)
  proofClauses d = do
    cs ← getConstructors d
    np ← getParameters d
    traverse id (mapIx (proofClause np) cs)

  makeProjection : Name → Clause → Clause
  makeProjection f (clause ps b)      = clause (vArg (proj f) ∷ ps) b
  makeProjection f (absurd-clause ps) = absurd-clause (vArg (proj f) ∷ ps)

  instanceClauses : Name → TC (List Clause)
  instanceClauses d = do
    enc ← encodeClauses d
    dec ← decodeClauses d
    prf ← proofClauses d
    pure (map (makeProjection (quote TreeEncoding.treeEncode)) enc ++
          map (makeProjection (quote TreeEncoding.treeDecode)) dec ++
          map (makeProjection (quote TreeEncoding.isTreeEmbedding)) prf)

deriveTreeEncoding : Name → Name → TC ⊤
deriveTreeEncoding iname dname = do
  declareDef (iArg iname) =<< instanceType dname (quote TreeEncoding)
  defineFun iname =<< instanceClauses dname

-- unquoteDecl EncodeList = deriveTreeEncoding EncodeList (quote List)


module Issue124 where

module A where
  data A : Set where
    c : A

module B where
  data B : Set where
    c : B

module C where
  open A public
  open B public

open C

f : B → B
f c = c


module Issue4267.A0 where

record RA0 : Set₁ where
  field
    A : Set


-- A module which imports every Web.Semantic module.

module Web.Semantic.Everything where

import Web.Semantic.DL.ABox
import Web.Semantic.DL.ABox.Interp
import Web.Semantic.DL.ABox.Interp.Meet
import Web.Semantic.DL.ABox.Interp.Morphism
import Web.Semantic.DL.ABox.Model
import Web.Semantic.DL.ABox.Skolemization
import Web.Semantic.DL.Category
import Web.Semantic.DL.Category.Composition
import Web.Semantic.DL.Category.Morphism
import Web.Semantic.DL.Category.Object
import Web.Semantic.DL.Category.Properties
import Web.Semantic.DL.Category.Properties.Composition
import Web.Semantic.DL.Category.Properties.Composition.Assoc
import Web.Semantic.DL.Category.Properties.Composition.LeftUnit
import Web.Semantic.DL.Category.Properties.Composition.Lemmas
import Web.Semantic.DL.Category.Properties.Composition.RespectsEquiv
import Web.Semantic.DL.Category.Properties.Composition.RespectsWiring
import Web.Semantic.DL.Category.Properties.Composition.RightUnit
import Web.Semantic.DL.Category.Properties.Equivalence
import Web.Semantic.DL.Category.Properties.Tensor
import Web.Semantic.DL.Category.Properties.Tensor.AssocNatural
import Web.Semantic.DL.Category.Properties.Tensor.Coherence
import Web.Semantic.DL.Category.Properties.Tensor.Functor
import Web.Semantic.DL.Category.Properties.Tensor.Isomorphisms
import Web.Semantic.DL.Category.Properties.Tensor.Lemmas
import Web.Semantic.DL.Category.Properties.Tensor.RespectsEquiv
import Web.Semantic.DL.Category.Properties.Tensor.RespectsWiring
import Web.Semantic.DL.Category.Properties.Tensor.SymmNatural
import Web.Semantic.DL.Category.Properties.Tensor.UnitNatural
import Web.Semantic.DL.Category.Tensor
import Web.Semantic.DL.Category.Unit
import Web.Semantic.DL.Category.Wiring
import Web.Semantic.DL.Concept
import Web.Semantic.DL.Concept.Model
import Web.Semantic.DL.Concept.Skolemization
import Web.Semantic.DL.FOL
import Web.Semantic.DL.FOL.Model
import Web.Semantic.DL.Integrity
import Web.Semantic.DL.Integrity.Closed
import Web.Semantic.DL.Integrity.Closed.Alternate
import Web.Semantic.DL.Integrity.Closed.Properties
import Web.Semantic.DL.KB
import Web.Semantic.DL.KB.Model
import Web.Semantic.DL.KB.Skolemization
import Web.Semantic.DL.Role
import Web.Semantic.DL.Role.Model
import Web.Semantic.DL.Role.Skolemization
import Web.Semantic.DL.Sequent
import Web.Semantic.DL.Sequent.Model
import Web.Semantic.DL.Signature
import Web.Semantic.DL.TBox
import Web.Semantic.DL.TBox.Interp
import Web.Semantic.DL.TBox.Interp.Morphism
import Web.Semantic.DL.TBox.Minimizable
import Web.Semantic.DL.TBox.Model
import Web.Semantic.DL.TBox.Skolemization


{-# OPTIONS --safe #-}

module Cubical.Categories.Additive where

open import Cubical.Categories.Additive.Base public
open import Cubical.Categories.Additive.Properties public
open import Cubical.Categories.Additive.Quotient public


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

module Generics.Mu where

open import Generics.Prelude hiding (lookup)
open import Generics.Telescope
open import Generics.Desc

private
  variable
    P   : Telescope ⊤
    V I : ExTele P
    p   : ⟦ P ⟧tel tt
    ℓ   : Level
    n   : ℕ

⟦_⟧IndArgω : ConDesc P V I → (⟦ P , I ⟧xtel → Setω) → ⟦ P , V ⟧xtel → Setω
⟦ var f    ⟧IndArgω X (p , v) = X (p , f (p , v))
⟦ π (n , ai) S C ⟧IndArgω X (p , v) = (s : < relevance ai > S (p , v)) → ⟦ C ⟧IndArgω X (p , v , s)
⟦ A ⊗ B    ⟧IndArgω X pv      = ⟦ A ⟧IndArgω X pv ×ω ⟦ B ⟧IndArgω X pv

⟦_⟧Conω : ConDesc P V I → (⟦ P , I ⟧xtel → Setω) → ⟦ P , V & I ⟧xtel → Setω
⟦ var f ⟧Conω X (p , v , i) = Liftω (i ≡ f (p , v))
⟦ π (n , ai) S C ⟧Conω X (p , v , i) = Σω (< relevance ai > S _) λ s → ⟦ C ⟧Conω X (p , (v , s) , i)
⟦ A ⊗ B ⟧Conω X (p , v , i) = ⟦ A ⟧IndArgω X (p , v) ×ω ⟦ B ⟧Conω X (p , v , i)

⟦_⟧Dataω : DataDesc P I n → (⟦ P , I ⟧xtel → Setω) → ⟦ P , I ⟧xtel → Setω
⟦_⟧Dataω {n = n} D X (p , i) = Σω (Fin n) λ k → ⟦ lookupCon D k ⟧Conω X (p , tt , i)

data μ (D : DataDesc P I n) (pi : ⟦ P , I ⟧xtel) : Setω where
  ⟨_⟩ : ⟦ D ⟧Dataω (μ D) pi → μ D pi


-- No top-level module

f : Set₁
f = Set


------------------------------------------------------------------------------
-- Testing the translation of scheme's instances
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Instance where

-- A schema
-- Current translation: ∀ p q x. app(p,x) → app(q,x).
postulate
  D      : Set
  schema : (A B : D → Set) → ∀ {x} → A x → B x

-- Using the current translation, the ATPs can prove an instance of
-- the schema.
postulate
  d         : D
  A B       : D → Set
  instanceC : A d → B d
{-# ATP prove instanceC schema #-}


------------------------------------------------------------------------
-- A breadth-first backend which uses the derivative operator
------------------------------------------------------------------------

module TotalParserCombinators.BreadthFirst where

open import Data.List
open import Data.List.Membership.Propositional
open import Data.Product
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (_↔_; module Inverse)
open import Relation.Binary.HeterogeneousEquality as H
  using () renaming (_≅_ to _≅H_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import TotalParserCombinators.Congruence using (_≅P_; _∎)
import TotalParserCombinators.Congruence.Sound as CS
open import TotalParserCombinators.Derivative as D using (D)
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics
open import TotalParserCombinators.Simplification as S using (simplify)

------------------------------------------------------------------------
-- A parametrised backend

-- The function f is applied before the derivative.

module Parse
  {Tok}
  (f : ∀ {R xs} → Parser Tok R xs → ∃ λ xs′ → Parser Tok R xs′)
  (f-correct : ∀ {R xs} (p : Parser Tok R xs) → proj₂ (f p) ≅P p)
  where

  -- The parsing function.

  parse : ∀ {R xs} → Parser Tok R xs → List Tok → List R
  parse {xs = xs} p []      = xs
  parse           p (t ∷ s) = parse (D t $ proj₂ $ f p) s

  -- A variant of f-correct.

  f-correct′ : ∀ {R xs} (p : Parser Tok R xs) → proj₂ (f p) ≅ p
  f-correct′ = CS.sound ∘ f-correct

  -- The backend is sound with respect to the semantics.

  sound : ∀ {R xs x} {p : Parser Tok R xs} (s : List Tok) →
          x ∈ parse p s → x ∈ p · s
  sound []      x∈p = I.sound _ x∈p
  sound (t ∷ s) x∈p =
    Inverse.to (f-correct′ _) ⟨$⟩ D.sound _ (sound s x∈p)

  -- The backend is complete with respect to the semantics.

  complete : ∀ {R xs x} {p : Parser Tok R xs} (s : List Tok) →
             x ∈ p · s → x ∈ parse p s
  complete []      x∈p = I.complete x∈p
  complete (t ∷ s) x∈p =
    complete s $ D.complete $ Inverse.from (f-correct′ _) ⟨$⟩ x∈p

  -- The backend does not introduce any unneeded ambiguity.
  --
  -- The proof complete is a left inverse of sound, so the (finite) type
  -- x ∈ parse p s contains at most as many proofs as x ∈ p · s. In
  -- other words, the output of parse p s can only contain n copies of x
  -- if there are at least n distinct parse trees in x ∈ p · s.

  complete∘sound : ∀ {R xs x} s
                   (p : Parser Tok R xs) (x∈p : x ∈ parse p s) →
                   complete s (sound s x∈p) ≡ x∈p
  complete∘sound []      p x∈p = I.complete∘sound p x∈p
  complete∘sound (t ∷ s) p x∈p
    rewrite Inverse.left-inverse-of (f-correct′ p)
              (D.sound (proj₂ (f p)) (sound s x∈p))
          | D.complete∘sound (proj₂ (f p)) (sound s x∈p) =
    complete∘sound s (D t $ proj₂ $ f p) x∈p

  -- The backend does not remove any ambiguity.
  --
  -- The proof complete is a right inverse of sound, which implies that
  -- the (finite) type x ∈ parse p s contains at least as many proofs as
  -- x ∈ p · s. In other words, if the output of parse p s contains n
  -- copies of x, then there are at most n distinct parse trees in
  -- x ∈ p · s.

  sound∘complete : ∀ {R xs x} {p : Parser Tok R xs}
                   (s : List Tok) (x∈p : x ∈ p · s) →
                   sound s (complete s x∈p) ≡ x∈p
  sound∘complete []      x∈p = I.sound∘complete x∈p
  sound∘complete (t ∷ s) x∈p
    rewrite sound∘complete s $
                  D.complete $ Inverse.from (f-correct′ _) ⟨$⟩ x∈p
          | D.sound∘complete $ Inverse.from (f-correct′ _) ⟨$⟩ x∈p
    = Inverse.right-inverse-of (f-correct′ _) x∈p

  -- The backend is correct.

  correct : ∀ {R xs x s} {p : Parser Tok R xs} →
            x ∈ p · s ↔ x ∈ parse p s
  correct {s = s} {p} = record
    { to         = P.→-to-⟶ $ complete s
    ; from       = P.→-to-⟶ $ sound s
    ; inverse-of = record
      { left-inverse-of  = sound∘complete s
      ; right-inverse-of = complete∘sound s p
      }
    }

------------------------------------------------------------------------
-- Specific instantiations

-- Parsing without simplification.

parse : ∀ {Tok R xs} → Parser Tok R xs → List Tok → List R
parse = Parse.parse -,_ _∎

parse-correct : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
                x ∈ p · s ↔ x ∈ parse p s
parse-correct = Parse.correct -,_ _∎

-- Parsing with simplification.

parse-with-simplification :
  ∀ {Tok R xs} → Parser Tok R xs → List Tok → List R
parse-with-simplification = Parse.parse (λ p → -, simplify p) S.correct

parse-with-simplification-correct :
  ∀ {Tok R xs x s} {p : Parser Tok R xs} →
  x ∈ p · s ↔ x ∈ parse-with-simplification p s
parse-with-simplification-correct = Parse.correct _ S.correct

------------------------------------------------------------------------
-- An observation

-- The worst-case complexity of parse (without simplification) is /at
-- least/ exponential in the size of the input string. There is a
-- (finite) parser p whose derivative is p ∣ p (for any token). The
-- n-th derivative thus contains (at least) 2^n outermost occurrences
-- of _∣_, and these occurrences have to be traversed to compute the
-- initial bag of the n-th derivative.

parse-inefficient :
  ∀ {Tok R} → ∃ λ (p : Parser Tok R []) → ∀ t → D t p ≅H p ∣ p
parse-inefficient {R = R} =
  (fail {R = R} >>= (λ _ → fail) , λ t → H.refl)


module RTP where
  open import RTN public

{-
  data Bool : Set where
    False : Bool
    True : Bool
-}

  postulate
    Int    : Set
    String : Set
    Float  : Set
    Char   : Set

  {-# BUILTIN FLOAT Float #-}
  {-# BUILTIN STRING String #-}
  {-# BUILTIN CHAR Char #-}

  -- postulate primShowBool : Bool -> String
  postulate primShowInt : Int -> String
  postulate primShowChar : Char -> String

  postulate primStringAppend : String -> String -> String
  postulate primStringReverse : String -> String

  -- postulate primStringToList : String -> List Char
  -- postulate primStringFromList

-- Int stuff
  postulate primIntZero : Int
  postulate primIntOne : Int
  postulate primIntSucc : Int -> Int
  postulate primNatToInt : Nat -> Int
  postulate primIntToNat : Int -> Nat
  postulate primIntAdd : Int -> Int -> Int
  postulate primIntSub : Int -> Int -> Int
  postulate primIntMul : Int -> Int -> Int
  postulate primIntDiv : Int -> Int -> Int
  postulate primIntMod : Int -> Int -> Int


------------------------------------------------------------------------------
-- We do not know how erase a proof term in the translation
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module NotErasedProofTerm where

postulate
  D    : Set
  _≡_  : D → D → Set
  _≤_  : D → D → Set
  zero : D
  succ : D → D

data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

thm : ∀ n → N n → (∀ k → k ≤ k) → n ≡ n
thm n Nn h = prf
  where
  -- The internal type of prf is

  --  ∀ (n : D) (Nn : N n) (h : ∀ k → k ≤ k) → ...

  -- Apia can erase the proof term Nn, but it cannot erase the proof
  -- term h.

  postulate prf : n ≡ n
  {-# ATP prove prf #-}