{-# OPTIONS --cubical --no-import-sorts #-}

module MoreLogic.Reasoning where -- hProp logic

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)
open import Cubical.Data.Sigma renaming (_×_ to infixr 4 _×_)

-- "implicational" reaoning

-- infix  3 _◼ᵖ
-- infixr 2 _⇒ᵖ⟨_⟩_
--
-- _⇒ᵖ⟨_⟩_ : ∀{ℓ ℓ' ℓ''} {Q : hProp ℓ'} {R : hProp ℓ''} → (P : hProp ℓ) → [ P ⇒ Q ] → [ Q ⇒ R ] → [ P ⇒ R ]
-- _ ⇒ᵖ⟨ pq ⟩ qr = qr ∘ pq
--
-- _◼ᵖ : ∀{ℓ} (A : hProp ℓ) → [ A ] → [ A ]
-- _ ◼ᵖ = λ x → x

infix  3 _◼
infixr 2 _⇒⟨_⟩_

infix  3 _◼ᵖ
infixr 2 ⇒ᵖ⟨⟩-syntax -- _⇒ᵖ⟨_⟩_

infix  3 _∎ᵖ
infixr 2 ⇔⟨⟩-syntax -- _⇔⟨_⟩_

⇔⟨⟩-syntax : ∀{ℓ ℓ' ℓ''} → (P : hProp ℓ'') → (((Q , R) , _) : Σ[ (Q , R) ∈ hProp ℓ' × hProp ℓ ] [ Q ⇔ R ]) → [ P ⇔ Q ] → Σ[ (P , R) ∈ hProp ℓ'' × hProp ℓ ] [ P ⇔ R ]
⇔⟨⟩-syntax P ((Q , R) , q⇔r) p⇔q .fst = P , R -- x⇔y ∙ y⇔z
⇔⟨⟩-syntax P ((Q , R) , q⇔r) p⇔q .snd .fst = fst q⇔r ∘ fst p⇔q
⇔⟨⟩-syntax P ((Q , R) , q⇔r) p⇔q .snd .snd = snd p⇔q ∘ snd q⇔r

syntax ⇔⟨⟩-syntax P QRq⇔r p⇔q = P ⇔⟨ p⇔q ⟩ QRq⇔r

_∎ᵖ : ∀{ℓ} → (P : hProp ℓ) → Σ[ (Q , R) ∈ hProp ℓ × hProp ℓ ] [ Q ⇔ R ]
_∎ᵖ P .fst        = P , P
_∎ᵖ P .snd .fst x = x
_∎ᵖ P .snd .snd x = x

⇒ᵖ⟨⟩-syntax : ∀{ℓ ℓ' ℓ''} → (P : hProp ℓ'') → (((Q , R) , _) : Σ[ (Q , R) ∈ hProp ℓ' × hProp ℓ ] [ Q ⇒ R ]) → [ P ⇒ Q ] → Σ[ (P , R) ∈ hProp ℓ'' × hProp ℓ ] [ P ⇒ R ]
⇒ᵖ⟨⟩-syntax P ((Q , R) , q⇔r) p⇔q .fst = P , R -- x⇔y ∙ y⇔z
⇒ᵖ⟨⟩-syntax P ((Q , R) , q⇒r) p⇒q .snd = q⇒r ∘ p⇒q

_◼ᵖ : ∀{ℓ} → (P : hProp ℓ) → Σ[ (Q , R) ∈ hProp ℓ × hProp ℓ ] [ Q ⇒ R ]
_◼ᵖ P .fst   = P , P
_◼ᵖ P .snd x = x

syntax ⇒ᵖ⟨⟩-syntax P QRq⇒r p⇒q = P ⇒ᵖ⟨ p⇒q ⟩ QRq⇒r

_⇒⟨_⟩_ : ∀{ℓ ℓ' ℓ''} {Q : Type ℓ'} {R : Type ℓ''} → (P : Type ℓ) → (P → Q) → (Q → R) → (P → R)
_ ⇒⟨ p⇒q ⟩ q⇒r = q⇒r ∘ p⇒q

_◼ : ∀{ℓ} (A : Type ℓ) → A → A
_ ◼ = λ x → x

-- ⊎⇒⊔ : ∀ {ℓ ℓ'} (P : hProp ℓ) (Q : hProp ℓ') → [ P ] ⊎ [ Q ] → [ P ⊔ Q ]
-- ⊎⇒⊔ P Q (inl x) = inlᵖ x
-- ⊎⇒⊔ P Q (inr x) = inrᵖ x
--
-- case[_⊔_]_return_of_ : ∀ {ℓ ℓ'} (P : hProp ℓ) (Q : hProp ℓ')
--                   → (z : [ P ⊔ Q ])
--                   → (R : [ P ⊔ Q ] → hProp ℓ'')
--                   → (S : (x : [ P ] ⊎ [ Q ]) → [ R (⊎⇒⊔ P Q x) ] )
--                   → [ R z ]
-- case[_⊔_]_return_of_ P Q z R S = ⊔-elim P Q R (λ p → S (inl p)) (λ q → S (inr q)) z

{- NOTE: in the CHANGELOG.md of the v1.3 non-cubical standard library, it is explained:

* Previously all equational reasoning combinators (e.g. `_≈⟨_⟩_`, `_≡⟨_⟩_`, `_≤⟨_⟩_`)
  were defined in the following style:
  ```agda
  infixr 2 _≡⟨_⟩_

  _≡⟨_⟩_ : ∀ x {y z : A} → x ≡ y → y ≡ z → x ≡ z
  _ ≡⟨ x≡y ⟩ y≡z = trans x≡y y≡z
  ```
  The type checker therefore infers the RHS of the equational step from the LHS + the
  type of the proof. For example for `x ≈⟨ x≈y ⟩ y ∎` it is inferred that `y ∎`
  must have type `y IsRelatedTo y` from `x : A` and `x≈y : x ≈ y`.

* There are two problems with this. Firstly, it means that the reasoning combinators are
  not compatible with macros (i.e. tactics) that attempt to automatically generate proofs
  for `x≈y`. This is because the reflection machinary does not have access to the type of RHS
  as it cannot be inferred. In practice this meant that the new reflective solvers
  `Tactic.RingSolver` and `Tactic.MonoidSolver` could not be used inside the equational
  reasoning. Secondly the inference procedure itself is slower as described in this
  [exchange](https://lists.chalmers.se/pipermail/agda/2016/009090.html)
  on the Agda mailing list.

* Therefore, as suggested on the mailing list, the order of arguments to the combinators
  have been reversed so that instead the type of the proof is inferred from the LHS + RHS.
  ```agda
  infixr -2 step-≡

  step-≡ : ∀ x {y z : A} → y ≡ z → x ≡ y → x ≡ z
  step-≡ y≡z x≡y = trans x≡y y≡z

  syntax step-≡ x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z
  ```
  where the `syntax` declaration is then used to recover the original order of the arguments.
  This change enables the use of macros and anecdotally speeds up type checking by a
  factor of 5.

-} -- TODO: that might be "correct" the way to implement these reasoning operators


module Basic.Axiomatic.Total where

open import Data.Bool hiding (not; if_then_else_; _∧_)
open import Data.Vec hiding ([_]; _++_; split)
open import Function
open import Relation.Binary.PropositionalEquality
open import Data.Product renaming (map to prodMap)
open import Data.Nat
open import Relation.Nullary
open import Data.Empty
import Level as L

open import Utils.Decidable
open import Basic.AST
open import Basic.BigStep

{-
Total axiomatic correctness (The first part of chapter 6.4).
For general notes on axiomatic correctness see Partial.agda
The most interesting part is here is the proof of completeness (exercise 6.33).
-}

_∧_ :
  ∀ {α β γ}{A : Set α}
  → (A → Set β)
  → (A → Set γ)
  → (A → Set _)
_∧_ f g x = f x × g x

_==>_ :
  ∀ {α β γ}{A : Set α}
  → (A → Set β)
  → (A → Set γ)
  → Set _
_==>_ f g = ∀ {x} → f x → g x

infixr 4 _,_
data 〈_〉_〈_〉 {n} : (State n → Set) → St n → (State n → Set) → Set₁ where

  skip :
           ∀ {P}
    → -----------------
      〈 P 〉 skip 〈 P 〉

  ass :
                        ∀ {x a P}
    → ----------------------------------------------
      〈 (λ s → P (s [ x ]≔ ⟦ a ⟧ᵉ s)) 〉 x := a 〈 P 〉

  _,_ :
             ∀ {P Q R S₁ S₂} →
      〈 P 〉 S₁ 〈 Q 〉 → 〈 Q 〉 S₂ 〈 R 〉
    → --------------------------------
            〈 P 〉 S₁ , S₂ 〈 R 〉

  if :
                          ∀ {P Q b S₁ S₂} →
      〈 (T ∘ ⟦ b ⟧ᵉ) ∧ P 〉 S₁ 〈 Q 〉 → 〈 (F ∘ ⟦ b ⟧ᵉ) ∧ P 〉 S₂ 〈 Q 〉
    → --------------------------------------------------------------
                  〈 P 〉 if b then S₁ else S₂ 〈 Q 〉

  {-
  This is the only difference between the partial and total system.
  The definition is exactly the same as in the book.
  -}
  while :
       ∀ {b S}
     → (P : ℕ → State n → Set)
     → (∀ n → P (suc n) ==> (T ∘ ⟦ b ⟧ᵉ))
     → (P 0 ==> (F ∘ ⟦ b ⟧ᵉ))
     → (∀ n → 〈 P (suc n) 〉 S 〈 P n 〉)
    → ---------------------------------
      〈 (λ s → ∃ λ n → P n s) 〉 while b do S 〈 P 0 〉

  cons :
                ∀ {P' Q' P Q S} →
      P ==> P' → 〈 P' 〉 S 〈 Q' 〉 → Q' ==> Q
    → -----------------------------------------
                 〈 P 〉 S 〈 Q 〉

-- Weakest precondition
------------------------------------------------------------
wp : ∀ {n} → St n → (State n → Set) → State n → Set
wp S Q s = ∃ λ s' → ⟨ S , s ⟩⟱ s' × Q s'

-- Soundness
------------------------------------------------------------

{-
This is more complicated than the soundess proof for the partial system,
because we have to construct an actual big-step derivation.

In the "if" case we have to evaluate the branch condition to
see whether we should return an "if-true" or an "if-false"  derivation.

In the "while" case we recurse on the natural number "measure" of the loop,
building an appropriately sized derivation for the loop
-}

sound : ∀ {n}{S : St n}{P Q} → 〈 P 〉 S 〈 Q 〉 → (P ==> wp S Q)
sound skip ps = _ , skip , ps

sound ass ps =  _ , ass , ps
sound (p , p₁) ps with sound p ps
... | s'  , runp  , qs' with sound p₁ qs'
... | s'' , runp₁ , qs'' = s'' , (runp , runp₁) , qs''

sound (if {b = b} p p₁) {s} ps with ⟦ b ⟧ᵉ s | inspect ⟦ b ⟧ᵉ s
... | true  | [ b≡true  ] =
  let Tb = ≡true→T b≡true
  in prodMap id
       (λ x₁ → (if-true Tb (proj₁ x₁)) , (proj₂ x₁))
       (sound p {s} (Tb , ps))

... | false | [ b≡false ] =
  let Fb = ≡false→F b≡false
  in prodMap id
       (λ x₁ → (if-false Fb (proj₁ x₁)) , (proj₂ x₁))
       (sound p₁ {s} (Fb , ps))

sound (while{b = b}{S = S} P pre post decr) {s} (start , ps) = go s start ps
  where
    go : ∀ s n → P n s → wp (while b do S) (P 0) s
    go s zero    ps = s , while-false (post ps) , ps
    go s (suc n) ps with sound (decr n) ps
    ... | s' , runS , ps' with go s' n ps'
    ... | s'' , runW , ps'' = s'' , while-true (pre n ps) runS runW , ps''

sound (cons x p x₁) ps with sound p (x ps)
... | s' , runp , qs' = s' , runp , x₁ qs'

-- Completeness
------------------------------------------------------------

complete : ∀ {n}(S : St n){P Q} → (P ==> wp S Q) → 〈 P 〉 S 〈 Q 〉

complete (x := exp) {P}{Q} f = cons go ass id
  where go : P ==> (λ s → Q (s [ x ]≔ ⟦ exp ⟧ᵉ s))
        go {s} ps with f ps
        go ps | ._ , ass , qs' = qs'

complete skip {P}{Q} f = cons go skip id
  where go : P ==> Q
        go {s} ps with f ps
        go ps | x , skip , qs' = qs'

complete (S , S₁){P}{Q} f  = complete S {P} {wp S₁ Q} go , complete S₁ id
  where go : P ==> wp S (wp S₁ Q)
        go {s} ps with f ps
        go {s} ps | s' , (run , run₂) , qs' = _ , run , s' , run₂ , qs'

complete (if b then S else S₁){P}{Q} f =
  if (complete S {(T ∘ ⟦ b ⟧ᵉ) ∧ P} {Q} go1) (complete S₁ {(F ∘ ⟦ b ⟧ᵉ) ∧ P} {Q} go2)
  where go1 : ((T ∘ ⟦ b ⟧ᵉ) ∧ P) ==> wp S Q
        go1 {s} (pb , ps) with f ps
        go1 (pb , ps) | s' , if-true pb' run , qs' = s' , run , qs'
        go1 (pb , ps) | s' , if-false pb' run , qs' with trans (sym (F→≡false pb')) (T→≡true pb)
        ... | ()

        go2 : ((F ∘ ⟦ b ⟧ᵉ) ∧ P) ==> wp S₁ Q
        go2 {s} (pb , ps) with f ps
        go2 (pb , ps) | s' , if-true pb' run , qs' with trans (sym $ F→≡false pb) (T→≡true pb')
        ... | ()
        go2 (pb , ps) | s' , if-false pb' run , qs' = s' , run , qs'

{-
This is the interesting part. I needed to do quite a bit of thinking to get this right.

So, we'd like to construct a proof of total corectness given the validity of a Hoare triple.

We're much less constrained here than in pretty much all of the other proofs, because our objective
is to construct a suitable P *predicate* for the loop body. Recall the axiom for "while"

  while :
       ∀ {b S}
     → (P : ℕ → State n → Set)
     → (∀ n → P (suc n) ==> (T ∘ ⟦ b ⟧ᵉ))
     → (P 0 ==> (F ∘ ⟦ b ⟧ᵉ))
     → (∀ n → 〈 P (suc n) 〉 S 〈 P n 〉)
    → ---------------------------------
      〈 (λ s → ∃ λ n → P n s) 〉 while b do S 〈 P 0 〉
-}
complete {n}(while b do S){P}{Q} f = cons pre-loop loop post-loop
  where

    {-
    P must decrease on each iteration, and P 0 must imply that the loop has finished, and
    P (suc n) must imply that the loop's still running.

    The only sensible choice for the decreasing loop variant is the length of the derivation
    of the loop:
    -}

    loop-size : ∀ {n b s s'}{S : St n} → ⟨ while b do S , s ⟩⟱ s' → ℕ
    loop-size (while-true x runS runW) = suc (loop-size runW)
    loop-size (while-false x)          = zero

    {- And now the loop predicate can be defined as: -}

    P' : ℕ → State n → Set
    P' n s = ∃₂ λ s' (runW : ⟨ while b do S , s ⟩⟱ s') → (loop-size runW ≡ n) × Q s'

    {- The construction of the loop body proof is slightly complicated by the fact that if we want
       to recurse on the measure "n" argument, then we have to unfold the loop derivation two layers
       deep (because the successor case for indction on "n" implies "(suc (suc n))" value for the
       derivation length -}

    body : ∀ n → 〈 P' (suc n) 〉 S 〈 P' n 〉
    body n = complete S (go n)
      where
        go : ∀ n → P' (suc n) ==> wp S (P' n)
        go zero (x , while-false x₁ , () , qs')
        go zero (s''' , while-true x₁ runW (while-true x₂ runW₁ runW₂) , () , qs')
        go (suc n₂) (x , while-false x₁ , () , qs')
        go (suc n₂) (s' , while-true x₁ runW (while-false x₂) , () , qs')

        go zero (s' , while-true x₁ runW (while-false x₂) , psize , qs') =
          s' , runW , s' , while-false x₂ , refl , qs'

        go (suc n) {s1} (slast , while-true pb1 runS1 (while-true pb2 runS2 runW2) , psize1 , qslast)
          with go n (slast , while-true pb2 runS2 runW2 , cong pred psize1 , qslast)
        ... | s2 , runS3 , s3 , runW3 , psize3 , q3 =
          _ , runS1 , s3 , (while-true pb2 runS3 runW3) , cong suc psize3 , q3

    pre-loop : P ==> (λ s → ∃ λ n → P' n s)
    pre-loop {s} ps with f ps
    ... | s' , runW , qs' = loop-size runW , s' , runW , refl , qs'

    post-loop : P' 0 ==> Q
    post-loop (s' , while-false pb , psize , qs') = qs'
    post-loop (s' , while-true pb x₁ x₂ , () , qs')

    loop : 〈 (λ s → ∃ λ n → P' n s) 〉 while b do S 〈 P' 0 〉
    loop = while P' pre post body
      where
        pre : ∀ n → P' (suc n) ==> (T ∘ ⟦ b ⟧ᵉ)
        pre n (s' , while-true pb _ _ , _) = pb
        pre n (s' , while-false _ , () , qs')

        post : P' 0 ==> (F ∘ ⟦ b ⟧ᵉ)
        post (s' , while-true pb runS runW , () , qs')
        post (s' , while-false pb , refl , qs') = pb


------------------------------------------------------------------------
-- Booleans
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

module Examples.Bool where

open import Codata.Musical.Notation
open import Data.Bool
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import Grammar.Infinite using (Grammar)
import Pretty
open import Renderer

module _ where

  open Grammar.Infinite

  bool : Grammar Bool
  bool = true  <$ string′ "true"
       ∣ false <$ string′ "false"

open Pretty

bool-printer : Pretty-printer bool
bool-printer true  = left  (<$ text)
bool-printer false = right (<$ text)

test₁ : render 4 (bool-printer true) ≡ "true"
test₁ = refl

test₂ : render 0 (bool-printer false) ≡ "false"
test₂ = refl


-- Andreas, 2019-02-03, issue #3541:
-- Treat indices like parameters in positivity check.

data Works (A : Set) : Set where
  nest : Works (Works A) → Works A

data Foo : Set → Set where
  foo : ∀{A} → Foo (Foo A) → Foo A

-- Should pass.


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

module Generics.HasDesc where

open import Data.String.Base

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

import Generics.Accessibility as Accessibility

private
  variable
    P  : Telescope ⊤
    I  : ExTele P
    pi : ⟦ P , I ⟧xtel

record HasDesc {ℓ} (A : Indexed P I ℓ) : Setω where
  A′ : ⟦ P , I ⟧xtel → Set ℓ
  A′ = uncurry P I A

  field
    {n} : ℕ
    D   : DataDesc P I n

    names : Vec String n

    constr : ⟦ D ⟧Data A′ pi → A′ pi
    split  : A′ pi → ⟦ D ⟧Data A′ pi

    constr∘split : (x : A′ pi          ) → constr (split x) ≡  x
    split∘constr : (x : ⟦ D ⟧Data A′ pi) → split (constr x) ≡ω x

  open Accessibility A D split public

  field wf : (x : A′ pi) → Acc x

  split-injective : ∀ {pi} {x y : A′ pi} → split x ≡ω split y → x ≡ y
  split-injective {x = x} {y} sx≡sy = begin
    x                ≡⟨ sym (constr∘split x) ⟩
    constr (split x) ≡⟨ congω constr sx≡sy   ⟩
    constr (split y) ≡⟨ constr∘split y       ⟩
    y                ∎ where open ≡-Reasoning


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

open import Polynomial.Parameters

module Polynomial.NormalForm.Construction
  {a ℓ}
  (coeffs : RawCoeff a ℓ)
  where

open import Relation.Nullary         using (Dec; yes; no)
open import Level                    using (lift; lower; _⊔_)
open import Data.Unit                using (tt)
open import Data.List                using (_∷_; []; List; foldr)
open import Data.Nat            as ℕ using (ℕ; suc; zero)
open import Data.Nat.Properties      using (z≤′n)
open import Data.Product             using (_×_; _,_; map₁; curry; uncurry)
open import Data.Maybe               using (just; nothing)
open import Data.Bool                using (if_then_else_; true; false)

open import Function

open import Polynomial.NormalForm.InjectionIndex
open import Polynomial.NormalForm.Definition coeffs

open RawCoeff coeffs

----------------------------------------------------------------------
-- Construction
--
-- Because the polynomial is stored in a canonical form, we use a
-- normalising cons operator to construct the coefficient lists.
----------------------------------------------------------------------

-- Decision procedure for Zero
zero? : ∀ {n} → (p : Poly n) → Dec (Zero p)
zero? (Σ _ Π _) = no (λ z → z)
zero? (Κ x Π _) with Zero-C x
... | true = yes tt
... | false = no (λ z → z)
{-# INLINE zero? #-}

-- Exponentiate the first variable of a polynomial
infixr 8 _⍓*_ _⍓+_
_⍓*_ : ∀ {n} → Coeff n * → ℕ → Coeff n *
_⍓+_ : ∀ {n} → Coeff n + → ℕ → Coeff n +

[] ⍓* _ = []
(∹ xs) ⍓* i = ∹ xs ⍓+ i

coeff (head (xs ⍓+ i)) = coeff (head xs)
pow (head (xs ⍓+ i)) = pow (head xs) ℕ.+ i
tail (xs ⍓+ i) = tail xs

infixr 5 _∷↓_
_∷↓_ : ∀ {n} → PowInd (Poly n) → Coeff n * → Coeff n *
x Δ i ∷↓ xs = case zero? x of
  λ { (yes p) → xs ⍓* suc i
    ; (no ¬p) → ∹ _≠0 x {¬p} Δ i & xs
    }
{-# INLINE _∷↓_ #-}

-- Inject a polynomial into a larger polynomoial with more variables
_Π↑_ : ∀ {n m} → Poly n → (suc n ≤′ m) → Poly m
(xs Π i≤n) Π↑ n≤m = xs Π (≤′-step i≤n ⟨ ≤′-trans ⟩ n≤m)
{-# INLINE _Π↑_ #-}

infixr 4 _Π↓_
_Π↓_ : ∀ {i n} → Coeff i * → suc i ≤′ n → Poly n
[]                        Π↓ i≤n = Κ 0# Π z≤′n
(∹ x ≠0 Δ zero  & []  ) Π↓ i≤n = x Π↑ i≤n
(∹ x    Δ zero  & ∹ xs) Π↓ i≤n = Σ (x Δ zero  & ∹ xs) Π i≤n
(∹ x    Δ suc j & xs  ) Π↓ i≤n = Σ (x Δ suc j & xs) Π i≤n
{-# INLINE _Π↓_ #-}

--------------------------------------------------------------------------------
-- These folds allow us to abstract over the proofs later: we try to avoid
-- using ∷↓ and Π↓ directly anywhere except here, so if we prove that this fold
-- acts the same on a normalised or non-normalised polynomial, we can prove th
-- same about any operation which uses it.
PolyF : ℕ → Set a
PolyF i = Poly i × Coeff i *

Fold : ℕ → Set a
Fold i = PolyF i → PolyF i

para : ∀ {i} → Fold i → Coeff i + → Coeff i *
para f (x ≠0 Δ i & []) = case f (x , []) of λ { (y , ys) → y Δ i ∷↓ ys }
para f (x ≠0 Δ i & ∹ xs) = case f (x , para f xs) of λ { (y , ys) → y Δ i ∷↓ ys }

poly-map : ∀ {i} → (Poly i → Poly i) → Coeff i + → Coeff i *
poly-map f = para (λ { (x , y) → (f x , y)})
{-# INLINE poly-map #-}


module Everything where

import Library

import Terms
import Substitution
import SN
import SN.AntiRename
import Reduction
import SAT3
import DeclSN
import Soundness


module Proof.Setup where

import LF
import IIRD
import IIRDr
import DefinitionalEquality
import Identity

open LF
open IIRD
open IIRDr
open DefinitionalEquality
open Identity

-- Given a code for a general IIRD we should give a code for a restricted IIRD.
ε : {I : Set}{D : I -> Set1} -> OPg I D -> OPr I D
ε {I}{D} (ι < j | e >') = \i -> σ (j == i) \p -> ι (subst₁ D p e)
ε        (σ A γ)        = \i -> σ A   \a -> ε (γ a) i
ε        (δ A j γ)      = \i -> δ A j \g -> ε (γ g) i

G→H : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
           (a : Gu γ U T) ->
           Hu (ε γ) U T (Gi γ U T a)
G→H (ι < i | e >') U T ★         = < refl | ★ >
G→H (σ A γ)        U T < a | b > = < a | G→H (γ a) U T b >
G→H (δ A i γ)      U T < g | b > = < g | G→H (γ (T « i × g »)) U T b >

H→G : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
    (i : I) -> Hu (ε γ) U T i -> Gu γ U T
H→G (ι < j | e >') U T i < p | ★ > = ★
H→G (σ A γ)        U T i < a | b > = < a | H→G (γ a) U T i b >
H→G (δ A j γ)      U T i < g | b > = < g | H→G (γ (T « j × g »)) U T i b >

-- We can turn an inductive argument of the general IIRD to an inductive
-- argument of the restricted version.

H→G∘G→H-identity : {I : Set}{D : I -> Set1}
                   (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                   (a : Gu γ U T) ->
                   H→G γ U T (Gi γ U T a) (G→H γ U T a) ≡ a
H→G∘G→H-identity (ι < i | e >') U T ★         = refl-≡
H→G∘G→H-identity (σ A γ)        U T < a | b > = cong-≡ (\z -> < a | z >) (H→G∘G→H-identity (γ a) U T b)
H→G∘G→H-identity (δ A i γ)      U T < g | b > = cong-≡ (\z -> < g | z >)
                                                       (H→G∘G→H-identity (γ (T « i × g »)) U T b)
{-
Gi∘H→G-identity : {I : Set}{D : I -> Set1}
                  (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                  (i : I)(b : Hu (ε γ) U T i) ->
                  Gi γ U T (H→G γ U T i b) == i
Gi∘H→G-identity (ι < j | e >') U T i < p | ★ > = p
Gi∘H→G-identity (σ A γ)        U T i < a | b > = Gi∘H→G-identity (γ a) U T i b
Gi∘H→G-identity (δ A j γ)      U T i < g | b > = Gi∘H→G-identity (γ (T « j × g »)) U T i b

Gt∘H→G-identity : {I : Set}{D : I -> Set1}
                  (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                  (i : I)(b : Hu (ε γ) U T i) ->
                  Gt γ U T (H→G γ U T i b) ≡₁ Ht (ε γ) U T i b
Gt∘H→G-identity γ U T i b = ?

-- This one ain't true! p ≢ refl : x == y
G→H∘H→G-identity : {I : Set}{D : I -> Set1}
                   (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                   (i : I)(b : Hu (ε γ) U T i) ->
                   G→H γ U T (H→G γ U T i b) ≡ b
G→H∘H→G-identity (ι < j | e >') U T i < p | ★ > = ?
G→H∘H→G-identity (σ A γ)        U T i < a | b > = ?
G→H∘H→G-identity (δ A j γ)      U T i < g | b > = ?
-}

-- Rather than proving equalities (which doesn't hold anyway) we provide
-- substitution rules.
G→H∘H→G-subst : {I : Set}{D : I -> Set1}
                (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                (F : (i : I)(a : Hu (ε γ) U T i) -> Set1)
                (i : I)(a : Hu (ε γ) U T i)
                (h : F (Gi γ U T (H→G γ U T i a)) (G→H γ U T (H→G γ U T i a))) ->
                F i a
G→H∘H→G-subst (ι < j | e >') U T F i < p | ★ > h = elim==₁ j (\z q -> F z < q | ★ >) h i p
G→H∘H→G-subst (σ A γ)        U T F i < a | b > h =
  G→H∘H→G-subst (γ a) U T (\j c -> F j < a | c >) i b h
G→H∘H→G-subst (δ A j γ)      U T F i < g | b > h =
  G→H∘H→G-subst (γ (T « j × g »)) U T (\j c -> F j < g | c >) i b h

-- Q. When can we remove a G→H∘H→G-subst ?
-- A. When a = G→H γ U T i a'
G→H∘H→G-identity : {I : Set}{D : I -> Set1}
                   (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                   (F : (i : I)(a : Hu (ε γ) U T i) -> Set1)
                   (a : Gu γ U T)
                   (h : F (Gi γ U T (H→G γ U T (Gi γ U T a) (G→H γ U T a)))
                          (G→H γ U T (H→G γ U T (Gi γ U T a) (G→H γ U T a)))
                   ) ->
                   G→H∘H→G-subst γ U T F (Gi γ U T a) (G→H γ U T a) h ≡₁ h
G→H∘H→G-identity (ι < i | e >') U T F ★ h = refl-≡₁
G→H∘H→G-identity (σ A γ) U T F < a | b > h =
  G→H∘H→G-identity (γ a) U T (\j  c -> F j < a | c >) b h
G→H∘H→G-identity (δ A i γ) U T F < g | b > h =
  G→H∘H→G-identity (γ (T « i × g »)) U T (\j c -> F j < g | c >) b h

εIArg : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
        (i : I)(a : Hu (ε γ) U T i) ->
        KIArg γ U T (H→G γ U T i a) -> KIArg (ε γ i) U T a
εIArg (ι < j | e >') U T i < h | ★ > ()
εIArg (σ A γ)        U T i < a | b > v       = εIArg (γ a) U T i b v
εIArg (δ A j γ)      U T i < g | b > (inl a) = inl a
εIArg (δ A j γ)      U T i < g | b > (inr v) = inr (εIArg (γ (T « j × g »)) U T i b v)

εIArg→I-identity : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                   (i : I)(a : Hu (ε γ) U T i)(v : KIArg γ U T (H→G γ U T i a)) ->
                   KIArg→I (ε γ i) U T a (εIArg γ U T i a v)
                   ≡ KIArg→I γ U T (H→G γ U T i a) v
εIArg→I-identity (ι < j | e >') U T i < p | ★ > ()
εIArg→I-identity (σ A γ)        U T i < a | b > v       = εIArg→I-identity (γ a) U T i b v
εIArg→I-identity (δ A j γ)      U T i < g | b > (inl a) = refl-≡
εIArg→I-identity (δ A j γ)      U T i < g | b > (inr v) = εIArg→I-identity (γ (T « j × g »)) U T i b v

εIArg→U-identity : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                   (i : I)(a : Hu (ε γ) U T i)(v : KIArg γ U T (H→G γ U T i a)) ->
                   KIArg→U (ε γ i) U T a (εIArg γ U T i a v)
                   ≡ KIArg→U γ U T (H→G γ U T i a) v
εIArg→U-identity (ι < j | e >') U T i < p | ★ > ()
εIArg→U-identity (σ A γ)        U T i < a | b > v       = εIArg→U-identity (γ a) U T i b v
εIArg→U-identity (δ A j γ)      U T i < g | b > (inl a) = refl-≡
εIArg→U-identity (δ A j γ)      U T i < g | b > (inr v) = εIArg→U-identity (γ (T « j × g »)) U T i b v

εIArg-subst : {I : Set}{D : I -> Set1}(γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
              (F : (i : I)(u : U i) -> Set1)
              (i : I)(a : Hu (ε γ) U T i)(v : KIArg γ U T (H→G γ U T i a)) ->
              F (KIArg→I (ε γ i) U T a (εIArg γ U T i a v))
                (KIArg→U (ε γ i) U T a (εIArg γ U T i a v)) ->
              F (KIArg→I γ U T (H→G γ U T i a) v)
                (KIArg→U γ U T (H→G γ U T i a) v)
εIArg-subst (ι < j | e >') U T F i < p | ★ > ()      h
εIArg-subst (σ A γ)        U T F i < a | b > v       h = εIArg-subst (γ a) U T F i b v h
εIArg-subst (δ A j γ)      U T F i < g | b > (inl a) h = h
εIArg-subst (δ A j γ)      U T F i < g | b > (inr v) h = εIArg-subst (γ (T « j × g »)) U T F i b v h

εIArg-identity : {I : Set}{D : I -> Set1}
                 (γ : OPg I D)(U : I -> Set)(T : (i : I) -> U i -> D i)
                 (F : (i : I)(u : U i) -> Set1)
                 (a : Gu γ U T)
                 (v : KIArg γ U T (H→G γ U T (Gi γ U T a) (G→H γ U T a)))
                 (h : F (KIArg→I (ε γ (Gi γ U T a)) U T (G→H γ U T a) (εIArg γ U T (Gi γ U T a) (G→H γ U T a) v))
                        (KIArg→U (ε γ (Gi γ U T a)) U T (G→H γ U T a) (εIArg γ U T (Gi γ U T a) (G→H γ U T a) v))
                 ) ->
                 εIArg-subst γ U T F (Gi γ U T a) (G→H γ U T a) v h ≡₁ h
εIArg-identity (ι < i | e >') U T F ★         ()      h
εIArg-identity (σ A γ)        U T F < a | b > v       h = εIArg-identity (γ a) U T F b v h
εIArg-identity (δ A i γ)      U T F < g | b > (inl a) h = refl-≡₁
εIArg-identity (δ A i γ)      U T F < g | b > (inr v) h = εIArg-identity (γ (T « i × g »)) U T F b v h


open import FRP.JS.Bool using ( Bool ; not )
open import FRP.JS.Maybe using ( Maybe ; just ; nothing ; _≟[_]_ )
open import FRP.JS.Float using ( ℝ ; _≟_ ; -_ ; _+_ ; _*_ ; _-_ ; _/_ ; _/?_ ; _≤_ ; _<_ ; show )
open import FRP.JS.String using () renaming ( _≟_ to _≟s_ )
open import FRP.JS.QUnit using ( TestSuite ; ok ; ok! ; test ; _,_ )

module FRP.JS.Test.Float where

infixr 2 _≟?_

_≟?_ : Maybe ℝ → Maybe ℝ → Bool
x ≟? y = x ≟[ _≟_ ] y

tests : TestSuite
tests =
  ( test "≟"
    ( ok "0 ≟ 0" (0.0 ≟ 0.0)
    , ok "1 ≟ 1" (1.0 ≟ 1.0)
    , ok "2 ≟ 2" (2.0 ≟ 2.0)
    , ok "0 != 1" (not (0.0 ≟ 1.0))
    , ok "0 != 2" (not (0.0 ≟ 2.0))
    , ok "1 != 2" (not (1.0 ≟ 2.0))
    , ok "1 != 0" (not (1.0 ≟ 0.0)) )
  , test "+"
    ( ok "0 + 0" (0.0 + 0.0 ≟ 0.0)
    , ok "1 + 1" (1.0 + 1.0 ≟ 2.0)
    , ok "37 + 0" (37.0 + 0.0 ≟ 37.0)
    , ok "37 + 1" (37.0 + 1.0 ≟ 38.0)
    , ok "37 + 5" (37.0 + 5.0 ≟ 42.0) )
  , test "*"
    ( ok "0 * 0" (0.0 * 0.0 ≟ 0.0)
    , ok "1 * 1" (1.0 * 1.0 ≟ 1.0)
    , ok "37 * 0" (37.0 * 0.0 ≟ 0.0)
    , ok "37 * 1" (37.0 * 1.0 ≟ 37.0)
    , ok "37 * 5" (37.0 * 5.0 ≟ 185.0) )
  , test "-"
    ( ok "0 - 0" (0.0 - 0.0 ≟ 0.0)
    , ok "1 - 1" (1.0 - 1.0 ≟ 0.0)
    , ok "37 - 0" (37.0 - 0.0 ≟ 37.0)
    , ok "37 - 1" (37.0 - 1.0 ≟ 36.0)
    , ok "37 - 5" (37.0 - 5.0 ≟ 32.0)
    , ok "5 - 37" (5.0 - 37.0 ≟ - 32.0) )
  , test "/"
    ( ok "1 / 1" (1.0 / 1.0 ≟ 1.0)
    , ok "37 / 1" (37.0 / 1.0 ≟ 37.0)
    , ok "37 / 5" (37.0 / 5.0 ≟ 7.4)
    , ok "0 /? 0" (0.0 /? 0.0 ≟? nothing)
    , ok "1 /? 1" (1.0 /? 1.0 ≟? just 1.0)
    , ok "37 /? 0" (37.0 /? 0.0 ≟? nothing)
    , ok "37 /? 1" (37.0 /? 1.0 ≟? just 37.0)
    , ok "37 /? 5" (37.0 /? 5.0 ≟? just 7.4) )
  , test "≤"
    ( ok "0 ≤ 0" (0.0 ≤ 0.0)
    , ok "0 ≤ 1" (0.0 ≤ 1.0)
    , ok "1 ≤ 0" (not (1.0 ≤ 0.0))
    , ok "1 ≤ 1" (1.0 ≤ 1.0)
    , ok "37 ≤ 0" (not (37.0 ≤ 0.0))
    , ok "37 ≤ 1" (not (37.0 ≤ 1.0))
    , ok "37 ≤ 5" (not (37.0 ≤ 5.0))
    , ok "5 ≤ 37" (5.0 ≤ 37.0) )
  , test "<"
    ( ok "0 < 0" (not (0.0 < 0.0))
    , ok "0 < 1" (0.0 < 1.0)
    , ok "1 < 0" (not (1.0 < 0.0))
    , ok "1 < 1" (not (1.0 < 1.0))
    , ok "37 < 0" (not (37.0 < 0.0))
    , ok "37 < 1" (not (37.0 < 1.0))
    , ok "37 < 5" (not (37.0 < 5.0))
    , ok "5 < 37" (5.0 < 37.0) )
  , test "show"
    ( ok "show 0" (show 0.0 ≟s "0")
    , ok "show 1" (show 1.0 ≟s "1")
    , ok "show 5" (show 5.0 ≟s "5")
    , ok "show 37" (show 37.0 ≟s "37")
    , ok "show -0" (show (- 0.0) ≟s "0")
    , ok "show -37" (show (- 37.0) ≟s "-37")
    , ok "show 3.1415" (show 3.1415 ≟s "3.1415")
    , ok "show -3.1415" (show (- 3.1415) ≟s "-3.1415") ) )


{- Name: Bowornmet (Ben) Hudson

-- define the complexity language from the paper

-}

open import Preliminaries
open import Preorder-withmax

module Comp-lang where

  -- define the complexity language from the paper
  -- we want to focus on arrow, cross, and nat types
  -- do I need unit types?
  data CTp : Set where
    unit : CTp
    nat : CTp
    _->c_ : CTp → CTp → CTp
    _×c_ : CTp → CTp → CTp
    C : CTp

  -- represent a context as a list of types
  Ctx = List CTp

  -- de Bruijn indices (for free variables)
  data _∈_ : CTp → Ctx → Set where
    i0 : ∀ {Γ τ}
       → τ ∈ (τ :: Γ)
    iS : ∀ {Γ τ τ1}
       → τ ∈ Γ
       → τ ∈ (τ1 :: Γ)

  data _|-_ : Ctx → CTp → Set where
    unit : ∀ {Γ}
         → Γ |- unit
    0C : ∀ {Γ}
       → Γ |- C
    1C : ∀ {Γ}
       → Γ |- C
    plusC : ∀ {Γ}
         → Γ |- C
         → Γ |- C
         → Γ |- C
    var : ∀ {Γ τ}
        → τ ∈ Γ
        → Γ |- τ
    z : ∀ {Γ}
      → Γ |- nat
    suc : ∀ {Γ}
        → (e : Γ |- nat)
        → Γ |- nat
    rec : ∀ {Γ τ}
        → Γ |- nat
        → Γ |- τ
        → (nat :: (τ :: Γ)) |- τ
        → Γ |- τ
    lam : ∀ {Γ τ ρ}
        → (ρ :: Γ) |- τ
        → Γ |- (ρ ->c τ)
    app : ∀ {Γ τ1 τ2}
        → Γ |- (τ2 ->c τ1)
        → Γ |- τ2
        → Γ |- τ1
    prod : ∀ {Γ τ1 τ2}
         → Γ |- τ1
         → Γ |- τ2
         → Γ |- (τ1 ×c τ2)
    l-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×c τ2)
           → Γ |- τ1
    r-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×c τ2)
           → Γ |- τ2

  _+C_ : ∀ {Γ τ} → Γ |- C  → Γ |- (C ×c τ)→ Γ |- (C ×c τ)
  c +C e = prod (plusC c (l-proj e)) (r-proj e)

------weakening and substitution lemmas

 -- renaming function
  rctx : Ctx → Ctx → Set
  rctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → τ ∈ Γ

  -- re: transferring variables in contexts
  lem1 : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) (τ :: Γ')
  lem1 d i0 = i0
  lem1 d (iS x) = iS (d x)

  -- renaming lemma
  ren : ∀ {Γ Γ' τ} → Γ' |- τ → rctx Γ Γ' → Γ |- τ
  ren unit d = unit
  ren 0C d = 0C
  ren 1C d = 1C
  ren (plusC e1 e2) d = plusC (ren e1 d) (ren e2 d)
  ren (var x) d = var (d x)
  ren z d = z
  ren (suc e) d = suc (ren e d)
  ren (rec e e0 e1) d = rec (ren e d) (ren e0 d) (ren e1 (lem1 (lem1 d)))
  ren (lam e) d = lam (ren e (lem1 d))
  ren (app e1 e2) d = app (ren e1 d) (ren e2 d)
  ren (prod e1 e2) d = prod (ren e1 d) (ren e2 d)
  ren (l-proj e) d = l-proj (ren e d)
  ren (r-proj e) d = r-proj (ren e d)

  -- substitution
  sctx : Ctx → Ctx → Set
  sctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → Γ |- τ

  -- weakening a context
  wkn : ∀ {Γ τ1 τ2} → Γ |- τ2 → (τ1 :: Γ) |- τ2
  wkn e = ren e iS

  -- weakening also works with substitution
  wkn-s : ∀ {Γ τ1 Γ'} → sctx Γ Γ' → sctx (τ1 :: Γ) Γ'
  wkn-s d = λ f → wkn (d f)

  wkn-r : ∀ {Γ τ1 Γ'} → rctx Γ Γ' → rctx (τ1 :: Γ) Γ'
  wkn-r d = λ x → iS (d x)

  -- lem2 (need a lemma for subst like we did for renaming)
  lem2 : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) (τ :: Γ')
  lem2 d i0 = var i0
  lem2 d (iS i) = wkn (d i)

  -- another substitution lemma
  lem3 : ∀ {Γ τ} → Γ |- τ → sctx Γ (τ :: Γ)
  lem3 e i0 = e
  lem3 e (iS i) = var i

  lem3' : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ |- τ → sctx Γ (τ :: Γ')
  lem3' Θ e i0 = e
  lem3' Θ e (iS i) = Θ i

  -- one final lemma needed for the last stepping rule. Thank you Professor Licata!
  lem4 : ∀ {Γ τ1 τ2} → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ))
  lem4 e1 e2 i0 = e1
  lem4 e1 e2 (iS i0) = e2
  lem4 e1 e2 (iS (iS i)) = var i

  lem4' : ∀ {Γ Γ' τ1 τ2} → sctx Γ Γ' → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ'))
  lem4' Θ a b i0 = a
  lem4' Θ a b (iS i0) = b
  lem4' Θ a b (iS (iS i)) = Θ i

  -- the 'real' substitution lemma (if (x : τ') :: Γ |- (e : τ) and Γ |- (e : τ') , then Γ |- e[x -> e'] : τ)
  subst : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ' |- τ → Γ |- τ
  subst d unit = unit
  subst d 0C = 0C
  subst d 1C = 1C
  subst d (plusC e1 e2) = plusC (subst d e1) (subst d e2)
  subst d (var x) = d x
  subst d z = z
  subst d (suc x) = suc (subst d x)
  subst d (rec e e0 e1) = rec (subst d e) (subst d e0) (subst (lem2 (lem2 d)) e1)
  subst d (lam e) = lam (subst (lem2 d) e)
  subst d (app e1 e2) = app (subst d e1) (subst d e2)
  subst d (prod e1 e2) = prod (subst d e1) (subst d e2)
  subst d (l-proj e) = l-proj (subst d e)
  subst d (r-proj e) = r-proj (subst d e)

  postulate
    subst-compose : ∀ {Γ Γ' τ τ1} (Θ : sctx Γ Γ') (v : Γ |- τ) (e : (τ :: Γ' |- τ1) )
                  → subst (lem3 v) (subst (lem2 Θ) e) == subst (lem3' Θ v) e

  postulate
    subst-compose2 : ∀ {Γ Γ' τ} (Θ : sctx Γ Γ') (n : Γ |- nat) (e1 : Γ' |- τ) (e2 : (nat :: (τ :: Γ')) |- τ)
                  →  subst (lem4 n (rec n (subst Θ e1) (subst (lem2 (lem2 Θ)) e2))) (subst (lem2 (lem2 Θ)) e2) ==
                     subst (lem4' Θ n (rec n (subst Θ e1) (subst (lem2 (lem2 Θ)) e2))) e2

  postulate
    subst-compose3 : ∀ {Γ Γ' τ τ1 τ2} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ' |- τ1) (v2 : Γ' |- τ2)
                   → subst Θ (subst (lem4 v1 v2) e1) == subst (lem4' Θ (subst Θ v1) (subst Θ v2)) e1

  postulate
    subst-compose4 : ∀ {Γ Γ' τ} (Θ : sctx Γ Γ') (v' : Γ |- nat) (r : Γ |- τ) (e2 : (nat :: (τ :: Γ')) |- τ)
                   → subst (lem4 v' r) (subst (lem2 (lem2 Θ)) e2) == subst (lem4' Θ v' r) e2

-------

  -- define 'stepping' as a datatype (fig. 1 of proof)
  data _≤s_ : ∀ {Γ T} → Γ |- T → Γ |- T → Set where
    refl-s : ∀ {Γ T}
           → {e : Γ |- T}
           → e ≤s e
    trans-s : ∀ {Γ T}
            → {e e' e'' : Γ |- T}
            → e ≤s e' → e' ≤s e''
            → e ≤s e''
    plus-s : ∀ {Γ}
           → {e1 e2 n1 n2 : Γ |- C}
           → e1 ≤s n1 → e2 ≤s n2
           → (plusC e1 e2) ≤s (plusC n1 n2)
    cong-refl : ∀ {Γ τ} {e e' : Γ |- τ} → e == e' → e ≤s e'
    +-unit-l : ∀ {Γ} {e : Γ |- C} → (plusC 0C e) ≤s e
    +-unit-l' : ∀ {Γ} {e : Γ |- C} → e ≤s (plusC 0C e)
    +-unit-r : ∀ {Γ} {e : Γ |- C} → (plusC e 0C) ≤s e
    +-unit-r' : ∀ {Γ} {e : Γ |- C} → e ≤s (plusC e 0C)
    +-assoc : ∀ {Γ} {e1 e2 e3 : Γ |- C} → (plusC e1 (plusC e2 e3)) ≤s (plusC (plusC e1 e2) e3)
    +-assoc' : ∀ {Γ} {e1 e2 e3 : Γ |- C} → (plusC e1 (plusC e2 e3)) ≤s (plusC (plusC e1 e2) e3)
    refl-+ : ∀ {Γ} {e0 e1 : Γ |- C} → (plusC e0 e1) ≤s (plusC e1 e0)
    cong-+ : ∀ {Γ} {e0 e1 e0' e1' : Γ |- C} → e0 ≤s e0' → e1 ≤s e1' → (plusC e0 e1) ≤s (plusC e0' e1')
    cong-lproj : ∀ {Γ τ τ'} {e e' : Γ |- (τ ×c τ')} → e ≤s e' → (l-proj e) ≤s (l-proj e')
    cong-rproj : ∀ {Γ τ τ'} {e e' : Γ |- (τ ×c τ')} → e ≤s e' → (r-proj e) ≤s (r-proj e')
    cong-app   : ∀ {Γ τ τ'} {e e' : Γ |- (τ ->c τ')} {e1 : Γ |- τ} → e ≤s e' → (app e e1) ≤s (app e' e1)
    cong-rec : ∀ {Γ τ} {e e' : Γ |- nat} {e0 : Γ |- τ} {e1 : (nat :: (τ :: Γ)) |- τ}
             → e ≤s e'
             → rec e e0 e1 ≤s rec e' e0 e1
    lam-s : ∀ {Γ T T'}
          → {e : (T :: Γ) |- T'}
          → {e2 : Γ |- T}
          → subst (lem3 e2) e ≤s app (lam e) e2
    l-proj-s : ∀ {Γ T1 T2}
             → {e1 : Γ |- T1}  {e2 : Γ |- T2}
             → e1 ≤s (l-proj (prod e1 e2))
    r-proj-s : ∀ {Γ T1 T2}
             → {e1 : Γ |- T1} → {e2 : Γ |- T2}
             → e2 ≤s (r-proj (prod e1 e2))
    rec-steps-s : ∀ {Γ T}
                → {e : Γ |- nat}
                → {e0 : Γ |- T}
                → {e1 : (nat :: (T :: Γ)) |- T}
                → subst (lem4 e (rec e e0 e1)) e1 ≤s (rec (suc e) e0 e1)
    rec-steps-z : ∀ {Γ T}
                → {e0 : Γ |- T}
                → {e1 : (nat :: (T :: Γ)) |- T}
                → e0 ≤s (rec z e0 e1)

  _trans_ : ∀ {Γ T}
            → {e e' e'' : Γ |- T}
            → e ≤s e' → e' ≤s e''
            → e ≤s e''
  _trans_ = trans-s
  infixr 10 _trans_

-------

  -- interpret complexity types as preorders
  [_]t : CTp → PREORDER
  [ unit ]t = unit-p
  [ nat ]t = Nat , nat-p
  [ A ->c B ]t = [ A ]t ->p [ B ]t
  [ A ×c B ]t = [ A ]t ×p [ B ]t
  [ C ]t = Nat , nat-p

  -- interpret contexts as preorders
  [_]c : Ctx → PREORDER
  [ [] ]c = unit-p
  [ τ :: Γ ]c = [ τ ]t ×p [ Γ ]c


{-# OPTIONS --guardedness-preserving-type-constructors #-}
module Issue602 where

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

data CoNat : Set0 where
  z : CoNat
  s : ∞ CoNat → CoNat

record A : Set2 where
  field
    f : Set1

record B (a : ∞ A) : Set1 where
  field
    f : A.f (♭ a)

postulate
  a : A

e : CoNat → A
e z = a
e (s n) = record
  { f = B (♯ e (♭ n))
  }


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

module Categories.Adjoint.TwoSided where

-- A "two sided" adjoint is an adjoint of two functors L and R where the
-- unit and counit are natural isomorphisms.

-- A two sided adjoint is the underlying data to an Adjoint Equivalence
open import Level

open import Categories.Adjoint
open import Categories.Category.Core using (Category)
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Properties
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism as ≃ using (_≃_; NaturalIsomorphism)
open import Categories.NaturalTransformation.NaturalIsomorphism.Properties
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e    : Level
    o′ ℓ′ e′ : Level
    C D      : Category o ℓ e

infix 5 _⊣⊢_

record _⊣⊢_ (L : Functor C D) (R : Functor D C) : Set (levelOfTerm L ⊔ levelOfTerm R) where
  field
    unit   : idF ≃ (R ∘F L)
    counit : (L ∘F R) ≃ idF

  module unit   = NaturalIsomorphism unit
  module counit = NaturalIsomorphism counit

  private
    module C = Category C using (Obj; id; _∘_; _≈_; module HomReasoning)
    module D = Category D using (Obj; id; _∘_; _≈_; module HomReasoning)
    module L = Functor L using (₀; ₁; op; identity)
    module R = Functor R using (₀; ₁; op; identity)

  field
    zig : ∀ {A : C.Obj} → counit.⇒.η (L.₀ A) D.∘ L.₁ (unit.⇒.η A) D.≈ D.id
    zag : ∀ {B : D.Obj} → R.₁ (counit.⇒.η B) C.∘ unit.⇒.η (R.₀ B) C.≈ C.id

  op₁ : R.op ⊣⊢ L.op
  op₁ = record
    { unit   = counit.op
    ; counit = unit.op
    ; zig    = zag
    ; zag    = zig
    }

  zag⁻¹ : {B : D.Obj} → unit.⇐.η (R.₀ B) C.∘ R.₁ (counit.⇐.η B) C.≈ C.id
  zag⁻¹ {B} = begin
    unit.⇐.η (R.₀ B) C.∘ R.₁ (counit.⇐.η B)   ≈˘⟨ flip-fromʳ unit.FX≅GX zag ⟩∘⟨refl ⟩
    R.₁ (counit.⇒.η B) C.∘ R.₁ (counit.⇐.η B) ≈⟨ [ R ]-resp-∘ (counit.iso.isoʳ B) ⟩
    R.₁ D.id                                  ≈⟨ R.identity ⟩
    C.id                                      ∎
    where open C.HomReasoning
          open MR C

  zig⁻¹ : {A : C.Obj} → L.₁ (unit.⇐.η A) D.∘ counit.⇐.η (L.₀ A) D.≈ D.id
  zig⁻¹ {A} = begin
      L.₁ (unit.⇐.η A) D.∘ counit.⇐.η (L.₀ A) ≈˘⟨ refl⟩∘⟨ flip-fromˡ counit.FX≅GX zig ⟩
      L.₁ (unit.⇐.η A) D.∘ L.₁ (unit.⇒.η A)   ≈⟨ [ L ]-resp-∘ (unit.iso.isoˡ A) ⟩
      L.₁ C.id                                ≈⟨ L.identity ⟩
      D.id                                    ∎
      where open D.HomReasoning
            open MR D

  op₂ : R ⊣⊢ L
  op₂ = record
    { unit   = ≃.sym counit
    ; counit = ≃.sym unit
    ; zig    = zag⁻¹
    ; zag    = zig⁻¹
    }

  L⊣R : L ⊣ R
  L⊣R = record
    { unit   = unit.F⇒G
    ; counit = counit.F⇒G
    ; zig    = zig
    ; zag    = zag
    }

  module L⊣R = Adjoint L⊣R
  open L⊣R hiding (unit; counit; zig; zag; op) public

  R⊣L : R ⊣ L
  R⊣L = record
    { unit   = counit.F⇐G
    ; counit = unit.F⇐G
    ; zig    = zag⁻¹
    ; zag    = zig⁻¹
    }

  module R⊣L = Adjoint R⊣L

private

  record WithZig (L : Functor C D) (R : Functor D C) : Set (levelOfTerm L ⊔ levelOfTerm R) where
    field
      unit   : idF ≃ (R ∘F L)
      counit : (L ∘F R) ≃ idF

    private
      module unit   = NaturalIsomorphism unit
      module counit = NaturalIsomorphism counit
      module C = Category C using (Obj; id; _∘_; _≈_; module HomReasoning)
      module D = Category D using (Obj; id; _∘_; _≈_; module HomReasoning)
      module L = Functor L using (₀; ₁; op; identity)
      module R = Functor R using (₀; ₁; op; identity; F-resp-≈)

    field
      zig : ∀ {A : C.Obj} → counit.⇒.η (L.₀ A) D.∘ L.₁ (unit.⇒.η A) D.≈ D.id

    zag : ∀ {B : D.Obj} → R.₁ (counit.⇒.η B) C.∘ unit.⇒.η (R.₀ B) C.≈ C.id
    zag {B} = F≃id⇒id (≃.sym unit) helper
      where open C
            open HomReasoning
            helper : R.₁ (L.₁ (R.₁ (counit.⇒.η B) ∘ unit.⇒.η (R.₀ B))) ≈ id
            helper = begin
              R.₁ (L.₁ (R.₁ (counit.⇒.η B) ∘ unit.⇒.η (R.₀ B)))             ≈⟨ Functor.homomorphism (R ∘F L) ⟩
              R.₁ (L.₁ (R.₁ (counit.⇒.η B))) ∘ R.₁ (L.₁ (unit.⇒.η (R.₀ B))) ≈˘⟨ R.F-resp-≈ (F≃id-comm₁ counit) ⟩∘⟨refl ⟩
              R.₁ (counit.⇒.η (L.₀ (R.₀ B))) ∘ R.₁ (L.₁ (unit.⇒.η (R.₀ B))) ≈⟨ [ R ]-resp-∘ zig ⟩
              R.₁ D.id                                                      ≈⟨ R.identity ⟩
              id                                                            ∎

  record WithZag (L : Functor C D) (R : Functor D C) : Set (levelOfTerm L ⊔ levelOfTerm R) where
    field
      unit   : idF ≃ (R ∘F L)
      counit : (L ∘F R) ≃ idF

    private
      module unit   = NaturalIsomorphism unit
      module counit = NaturalIsomorphism counit
      module C = Category C using (Obj; id; _∘_; _≈_; module HomReasoning)
      module D = Category D using (Obj; id; _∘_; _≈_; module HomReasoning)
      module L = Functor L using (₀; ₁; op; identity; F-resp-≈)
      module R = Functor R using (₀; ₁; op; identity)

    field
      zag : ∀ {B : D.Obj} → R.₁ (counit.⇒.η B) C.∘ unit.⇒.η (R.₀ B) C.≈ C.id

    zig : ∀ {A : C.Obj} → counit.⇒.η (L.₀ A) D.∘ L.₁ (unit.⇒.η A) D.≈ D.id
    zig {A} = F≃id⇒id counit helper
      where open D
            open HomReasoning
            helper : L.₁ (R.₁ (counit.⇒.η (L.₀ A) ∘ L.₁ (unit.⇒.η A))) ≈ id
            helper = begin
              L.₁ (R.₁ (counit.⇒.η (L.₀ A) ∘ L.₁ (unit.⇒.η A)))               ≈⟨ Functor.homomorphism (L ∘F R) ⟩
              (L.₁ (R.₁ (counit.⇒.η (L.₀ A))) ∘ L.₁ (R.₁ (L.₁ (unit.⇒.η A)))) ≈˘⟨ refl⟩∘⟨ L.F-resp-≈ (F≃id-comm₂ (≃.sym unit)) ⟩
              L.₁ (R.₁ (counit.⇒.η (L.₀ A))) ∘ L.₁ (unit.⇒.η (R.₀ (L.₀ A)))   ≈⟨ [ L ]-resp-∘ zag ⟩
              L.₁ C.id                                                       ≈⟨ L.identity ⟩
              id                                                              ∎

module _ {L : Functor C D} {R : Functor D C} where

  withZig : WithZig L R → L ⊣⊢ R
  withZig LR = record
    { unit   = unit
    ; counit = counit
    ; zig    = zig
    ; zag    = zag
    }
    where open WithZig LR

  withZag : WithZag L R → L ⊣⊢ R
  withZag LR = record
    { unit   = unit
    ; counit = counit
    ; zig    = zig
    ; zag    = zag
    }
    where open WithZag LR

id⊣⊢id : idF {C = C} ⊣⊢ idF
id⊣⊢id {C = C} = record
  { unit   = ≃.sym ≃.unitor²
  ; counit = ≃.unitor²
  ; zig    = identity²
  ; zag    = identity²
  }
  where open Category C


------------------------------------------------------------------------
-- Collection of most needed import from standard library
------------------------------------------------------------------------

module Library where

open import Data.Empty public
open import Data.Unit hiding (_≟_; _≤_; _≤?_; decSetoid; decTotalOrder; setoid) public
open import Data.Sum public hiding (map)
open import Data.Bool hiding (_≟_) public
open import Data.Nat hiding (_⊔_) public
open import Data.Product hiding (map ; swap) public
open import Data.Vec using ([]; _∷_; Vec) public
open import Level renaming (zero to ℓ₀; suc to ℓ⁺) public
open import Function public
open import Size public
open import Relation.Binary.PropositionalEquality hiding (decSetoid; preorder; setoid) public

open import ContainerMonkeyPatched as Container renaming (map to fmap) public


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

module Dodo.Binary.Identity where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; subst; sym)
open import Level using (Level; _⊔_)
open import Function.Base using (flip)
open import Data.Product using (_×_; _,_; ∃; ∃-syntax; proj₁; proj₂)
open import Data.Sum using (inj₁; inj₂)
open import Relation.Unary using (Pred)
open import Relation.Binary using (Rel)
open import Relation.Binary using (Symmetric; Transitive; IsStrictTotalOrder)
-- Local imports
open import Dodo.Binary.Equality
open import Dodo.Binary.Composition
open import Dodo.Binary.Intersection
open import Dodo.Binary.Union
open import Dodo.Unary.Equality
open import Dodo.Unary.Intersection
open import Dodo.Unary.Union

-- # Definitions

-- | Identity relation over some set
--
-- Iff `P x` holds then `⦗ P ⦘ x x` holds.
⦗_⦘ : ∀ {a ℓ : Level} {A : Set a}
  → Pred A ℓ
    -------------
  → Rel A (a ⊔ ℓ)
⦗ p ⦘ x y = x ≡ y × p x

-- # Properties

module _ {a ℓ : Level} {A : Set a} {p : Pred A ℓ} where

  ⦗⦘-sym : Symmetric ⦗ p ⦘
  ⦗⦘-sym (refl , px) = (refl , px)

  ⦗⦘-trans : Transitive ⦗ p ⦘
  ⦗⦘-trans (refl , pi) (refl , _) = (refl , pi)

  ⦗⦘-flip : ⦗ p ⦘ ⇔₂ flip ⦗ p ⦘
  ⦗⦘-flip = ⇔: (λ{_ _ → ⦗⦘-sym}) (λ{_ _ → ⦗⦘-sym})

-- # Operations

module _ {a ℓ : Level} {A : Set a} {p : Pred A ℓ} where

  ⦗⦘-combine-⨾ : ⦗ p ⦘ ⨾ ⦗ p ⦘ ⇔₂ ⦗ p ⦘
  ⦗⦘-combine-⨾ = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : ⦗ p ⦘ ⨾ ⦗ p ⦘ ⊆₂' ⦗ p ⦘
    ⊆-proof _ _ ((refl , Px) ⨾[ x ]⨾ (refl , _)) = (refl , Px)
    ⊇-proof : ⦗ p ⦘ ⊆₂' ⦗ p ⦘ ⨾ ⦗ p ⦘
    ⊇-proof x _ (refl , Px) = (refl , Px) ⨾[ _ ]⨾ (refl , Px)

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {p : Pred A ℓ₁} {q : Pred A ℓ₂} where

  ⦗⦘-lift-⊆₂ : p ⊆₁ q → ⦗ p ⦘ ⊆₂ ⦗ q ⦘
  ⦗⦘-lift-⊆₂ (⊆: p⊆q) = ⊆: lemma
    where
    lemma : ⦗ p ⦘ ⊆₂' ⦗ q ⦘
    lemma x .x (refl , px) = (refl , p⊆q x px)

  ⦗⦘-unlift-⊆₂ : ⦗ p ⦘ ⊆₂ ⦗ q ⦘ → p ⊆₁ q
  ⦗⦘-unlift-⊆₂ (⊆: ⦗p⦘⊆⦗q⦘) = ⊆: lemma
    where
    lemma : p ⊆₁' q
    lemma x px = proj₂ (⦗p⦘⊆⦗q⦘ x x (refl , px))

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {p : Pred A ℓ₁} {q : Pred A ℓ₂} where

  ⦗⦘-lift : p ⇔₁ q → ⦗ p ⦘ ⇔₂ ⦗ q ⦘
  ⦗⦘-lift = ⇔₂-compose-⇔₁ ⦗⦘-lift-⊆₂ ⦗⦘-lift-⊆₂

  ⦗⦘-unlift : ⦗ p ⦘ ⇔₂ ⦗ q ⦘ → p ⇔₁ q
  ⦗⦘-unlift = ⇔₁-compose-⇔₂ ⦗⦘-unlift-⊆₂ ⦗⦘-unlift-⊆₂

  ⦗⦘-dist-∪ : ⦗ p ∪₁ q ⦘ ⇔₂ ⦗ p ⦘ ∪₂ ⦗ q ⦘
  ⦗⦘-dist-∪ = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : ⦗ p ∪₁ q ⦘ ⊆₂' ⦗ p ⦘ ∪₂ ⦗ q ⦘
    ⊆-proof _ _ (refl , inj₁ px) = inj₁ (refl , px)
    ⊆-proof _ _ (refl , inj₂ qx) = inj₂ (refl , qx)
    ⊇-proof : ⦗ p ⦘ ∪₂ ⦗ q ⦘ ⊆₂' ⦗ p ∪₁ q ⦘
    ⊇-proof _ _ (inj₁ (refl , px)) = (refl , inj₁ px)
    ⊇-proof _ _ (inj₂ (refl , qx)) = (refl , inj₂ qx)

  ⦗⦘-dist-∩ : ⦗ p ∩₁ q ⦘ ⇔₂ ⦗ p ⦘ ∩₂ ⦗ q ⦘
  ⦗⦘-dist-∩ = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : ⦗ p ∩₁ q ⦘ ⊆₂' ⦗ p ⦘ ∩₂ ⦗ q ⦘
    ⊆-proof x .x (refl , Px , Qx) = (refl , Px) , (refl , Qx)

    ⊇-proof : ⦗ p ⦘ ∩₂ ⦗ q ⦘ ⊆₂' ⦗ p ∩₁ q ⦘
    ⊇-proof x .x ((refl , Px) , (_ , Qx)) = refl , (Px , Qx)


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

module Cubical.Categories.Category.Properties where

open import Cubical.Core.Glue
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Categories.Category.Base hiding (isSetHom)

open Precategory

private
  variable
    ℓ ℓ' : Level

module _ {C : Precategory ℓ ℓ'} ⦃ isC : isCategory C ⦄ where
  open isCategory isC
  -- isSet where your allowed to compare paths where one side is only
  -- equal up to path. Is there a generalization of this?
  isSetHomP1 : ∀ {x y : C .ob} {n : C [ x , y ]}
              → isOfHLevelDep 1 (λ m → m ≡ n)
  isSetHomP1 {x = x} {y} {n} = isOfHLevel→isOfHLevelDep 1 (λ m → isSetHom m n)

  -- isSet where the arrows can be between non-definitionally equal obs
  isSetHomP2l : ∀ {y : C .ob}
              → isOfHLevelDep 2 (λ x → C [ x , y ])
  isSetHomP2l = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom {x = a})

  isSetHomP2r : ∀ {x : C .ob}
              → isOfHLevelDep 2 (λ y → C [ x , y ])
  isSetHomP2r = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom {y = a})

-- opposite of opposite is definitionally equal to itself
involutiveOp : ∀ {C : Precategory ℓ ℓ'} → (C ^op) ^op ≡ C
involutiveOp = refl

module _ {C : Precategory ℓ ℓ'} where
  -- Other useful operations on categories

  -- whisker the parallel morphisms g and g' with f
  lPrecatWhisker : {x y z : C .ob} (f : C [ x , y ]) (g g' : C [ y , z ]) (p : g ≡ g') → f ⋆⟨ C ⟩ g ≡ f ⋆⟨ C ⟩ g'
  lPrecatWhisker f _ _ p = cong (_⋆_ C f) p

  rPrecatWhisker : {x y z : C .ob} (f f' : C [ x , y ]) (g : C [ y , z ]) (p : f ≡ f') → f ⋆⟨ C ⟩ g ≡ f' ⋆⟨ C ⟩ g
  rPrecatWhisker _ _ g p = cong (λ v → v ⋆⟨ C ⟩ g) p

  -- working with equal objects
  idP : ∀ {x x'} {p : x ≡ x'} → C [ x , x' ]
  idP {x = x} {x'} {p} = subst (λ v → C [ x , v ]) p (C .id x)

  -- heterogeneous seq
  seqP : ∀ {x y y' z} {p : y ≡ y'}
       → (f : C [ x , y ]) (g : C [ y' , z ])
       → C [ x , z ]
  seqP {x = x} {_} {_} {z} {p} f g = f ⋆⟨ C ⟩ (subst (λ a → C [ a , z ]) (sym p) g)

  -- also heterogeneous seq, but substituting on the left
  seqP' : ∀ {x y y' z} {p : y ≡ y'}
       → (f : C [ x , y ]) (g : C [ y' , z ])
       → C [ x , z ]
  seqP' {x = x} {_} {_} {z} {p} f g = subst (λ a → C [ x , a ]) p f ⋆⟨ C ⟩ g

  -- show that they're equal
  seqP≡seqP' : ∀ {x y y' z} {p : y ≡ y'}
             → (f : C [ x , y ]) (g : C [ y' , z ])
             → seqP {p = p} f g ≡ seqP' {p = p} f g
  seqP≡seqP' {x = x} {z = z} {p = p} f g i =
    (toPathP {A = λ i' → C [ x , p i' ]} {f} refl i)
      ⋆⟨ C ⟩
    (toPathP {A = λ i' → C [ p (~ i') , z ]} {x = g} (sym refl) (~ i))

  -- seqP is equal to normal seq when y ≡ y'
  seqP≡seq : ∀ {x y z}
             → (f : C [ x , y ]) (g : C [ y , z ])
             → seqP {p = refl} f g ≡ f ⋆⟨ C ⟩ g
  seqP≡seq {y = y} {z} f g i = f ⋆⟨ C ⟩ toPathP {A = λ _ → C [ y , z ]} {x = g} refl (~ i)

  -- whiskering with heterogenous seq -- (maybe should let z be heterogeneous too)
  lPrecatWhiskerP : {x y z y' : C .ob} {p : y ≡ y'}
                  → (f : C [ x , y ]) (g : C [ y , z ]) (g' : C [ y' , z ])
                  → (r : PathP (λ i → C [ p i , z ]) g g')
                  → f ⋆⟨ C ⟩ g ≡ seqP {p = p} f g'
  lPrecatWhiskerP f g g' r = cong (λ v → f ⋆⟨ C ⟩ v) (sym (fromPathP (symP r)))

  rPrecatWhiskerP : {x y' y z : C .ob} {p : y' ≡ y}
                  → (f' : C [ x , y' ]) (f : C [ x , y ]) (g : C [ y , z ])
                  → (r : PathP (λ i → C [ x , p i ]) f' f)
                  → f ⋆⟨ C ⟩ g ≡ seqP' {p = p} f' g
  rPrecatWhiskerP f' f g r = cong (λ v → v ⋆⟨ C ⟩ g) (sym (fromPathP r))


{-

Set quotients:

-}

{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SetQuotients.Properties where

open import Cubical.HITs.SetQuotients.Base

open import Cubical.Core.Everything

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

open import Cubical.Functions.FunExtEquiv

open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Base

open import Cubical.HITs.TypeQuotients as TypeQuot using (_/ₜ_ ; [_] ; eq/)
open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥ ; ∣_∣ ; squash)
open import Cubical.HITs.SetTruncation as SetTrunc using (∥_∥₂ ; ∣_∣₂ ; squash₂
                                                              ; setTruncIsSet)

private
  variable
    ℓ ℓ' ℓ'' : Level
    A : Type ℓ
    R : A → A → Type ℓ
    B : A / R → Type ℓ
    C : A / R → A / R → Type ℓ
    D : A / R → A / R → A / R → Type ℓ

elimEq/ : (Bprop : (x : A / R ) → isProp (B x))
          {x y : A / R}
          (eq : x ≡ y)
          (bx : B x)
          (by : B y) →
          PathP (λ i → B (eq i)) bx by
elimEq/ {B = B} Bprop {x = x} =
  J (λ y eq → ∀ bx by → PathP (λ i → B (eq i)) bx by) (λ bx by → Bprop x bx by)

elimProp : ((x : A / R ) → isProp (B x))
         → ((a : A) → B ( [ a ]))
         → (x : A / R)
         → B x
elimProp Bprop f [ x ] = f x
elimProp Bprop f (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 (λ x → isProp→isSet (Bprop x))
    (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
    g = elimProp Bprop f
elimProp Bprop f (eq/ a b r i) = elimEq/ Bprop (eq/ a b r) (f a) (f b) i

elimProp2 : ((x y : A / R ) → isProp (C x y))
          → ((a b : A) → C [ a ] [ b ])
          → (x y : A / R)
          → C x y
elimProp2 Cprop f = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                             (λ x → elimProp (λ y → Cprop [ x ] y) (f x))

elimProp3 : ((x y z : A / R ) → isProp (D x y z))
          → ((a b c : A) → D [ a ] [ b ] [ c ])
          → (x y z : A / R)
          → D x y z
elimProp3 Dprop f = elimProp (λ x → isPropΠ2 (λ y z → Dprop x y z))
                             (λ x → elimProp2 (λ y z → Dprop [ x ] y z) (f x))

-- lemma 6.10.2 in hott book
[]surjective : (x : A / R) → ∃[ a ∈ A ] [ a ] ≡ x
[]surjective = elimProp (λ x → squash) (λ a → ∣ a , refl ∣)

elim : {B : A / R → Type ℓ}
     → ((x : A / R) → isSet (B x))
     → (f : (a : A) → (B [ a ]))
     → ((a b : A) (r : R a b) → PathP (λ i → B (eq/ a b r i)) (f a) (f b))
     → (x : A / R)
     → B x
elim Bset f feq [ a ] = f a
elim Bset f feq (eq/ a b r i) = feq a b r i
elim Bset f feq (squash/ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 Bset
              (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j
    where
      g = elim Bset f feq

rec : {B : Type ℓ}
      (Bset : isSet B)
      (f : A → B)
      (feq : (a b : A) (r : R a b) → f a ≡ f b)
    → A / R → B
rec Bset f feq [ a ] = f a
rec Bset f feq (eq/ a b r i) = feq a b r i
rec Bset f feq (squash/ x y p q i j) = Bset (g x) (g y) (cong g p) (cong g q) i j
  where
  g = rec Bset f feq

rec2 : {B : Type ℓ} (Bset : isSet B)
       (f : A → A → B) (feql : (a b c : A) (r : R a b) → f a c ≡ f b c)
                       (feqr : (a b c : A) (r : R b c) → f a b ≡ f a c)
    → A / R → A / R → B
rec2 Bset f feql feqr = rec (isSetΠ (λ _ → Bset))
                            (λ a → rec Bset (f a) (feqr a))
                            (λ a b r → funExt (elimProp (λ _ → Bset _ _)
                                              (λ c → feql a b c r)))

-- the recursor for maps into groupoids:
-- i.e. for any type A with a binary relation R and groupoid B,
-- we can construct a map A / R → B from a map A → B satisfying the conditions
-- (i)   ∀ (a b : A) → R a b → f a ≡ f b
-- (ii)  ∀ (a b : A) → isProp (f a ≡ f b)

-- We start by proving that we can recover the set-quotient
-- by set-truncating the (non-truncated type quotient)
typeQuotSetTruncIso : Iso (A / R) ∥ A /ₜ R ∥₂
Iso.fun typeQuotSetTruncIso = rec setTruncIsSet (λ a → ∣ [ a ] ∣₂)
                                                 λ a b r → cong ∣_∣₂ (eq/ a b r)
Iso.inv typeQuotSetTruncIso = SetTrunc.rec squash/ (TypeQuot.rec [_] eq/)
Iso.rightInv typeQuotSetTruncIso = SetTrunc.elim (λ _ → isProp→isSet (squash₂ _ _))
                                  (TypeQuot.elimProp (λ _ → squash₂ _ _) λ _ → refl)
Iso.leftInv typeQuotSetTruncIso = elimProp (λ _ → squash/ _ _) λ _ → refl

module rec→Gpd {A : Type ℓ} {R : A → A → Type ℓ'} {B : Type ℓ''} (Bgpd : isGroupoid B)
               (f : A → B)
               (feq : ∀ (a b : A) → R a b → f a ≡ f b)
               (fprop : ∀ (a b : A) → isProp (f a ≡ f b)) where

 fun : A / R → B
 fun = f₁ ∘ f₂
  where
  f₁ : ∥ A /ₜ R ∥₂ → B
  f₁ = SetTrunc.rec→Gpd.fun Bgpd f/ congF/Const
   where
   f/ : A /ₜ R → B
   f/ = TypeQuot.rec f feq
   congF/Const : (a b : A /ₜ R) (p q : a ≡ b) → cong f/ p ≡ cong f/ q
   congF/Const = TypeQuot.elimProp2 (λ _ _ → isPropΠ2 λ _ _ → Bgpd _ _ _ _)
                                     λ a b p q → fprop a b (cong f/ p) (cong f/ q)

  f₂ : A / R → ∥ A /ₜ R ∥₂
  f₂ = Iso.fun typeQuotSetTruncIso

setQuotUniversalIso : {B : Type ℓ} (Bset : isSet B)
                    → Iso (A / R → B) (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b))
Iso.fun (setQuotUniversalIso Bset) g = (λ a → g [ a ]) , λ a b r i → g (eq/ a b r i)
Iso.inv (setQuotUniversalIso Bset) h = elim (λ x → Bset) (fst h) (snd h)
Iso.rightInv (setQuotUniversalIso Bset) h = refl
Iso.leftInv (setQuotUniversalIso Bset) g =
 funExt (λ x → PropTrunc.elim (λ sur → Bset (out (intro g) x) (g x))
        (λ sur → cong (out (intro g)) (sym (snd sur)) ∙ (cong g (snd sur))) ([]surjective x))
     where
     intro = Iso.fun (setQuotUniversalIso Bset)
     out = Iso.inv (setQuotUniversalIso Bset)

setQuotUniversal : {B : Type ℓ} (Bset : isSet B) →
                   (A / R → B) ≃ (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b))
setQuotUniversal Bset = isoToEquiv (setQuotUniversalIso Bset)

open BinaryRelation

-- characterisation of binary functions/operations on set-quotients
setQuotUniversal2Iso : {B : Type ℓ} (Bset : isSet B) → isRefl R
                 → Iso (A / R → A / R → B)
                       (Σ[ _∗_ ∈ (A → A → B) ] ((a a' b b' : A) → R a a' → R b b' → a ∗ b ≡ a' ∗ b'))
Iso.fun (setQuotUniversal2Iso {A = A} {R = R} {B = B} Bset isReflR) _∗/_ = _∗_ , h
   where
   _∗_ = λ a b → [ a ] ∗/ [ b ]
   h : (a a' b b' : A) → R a a' → R b b' → a ∗ b ≡ a' ∗ b'
   h a a' b b' ra rb = cong (_∗/ [ b ]) (eq/ _ _ ra) ∙ cong ([ a' ] ∗/_) (eq/ _ _ rb)
Iso.inv (setQuotUniversal2Iso {A = A} {R = R} {B = B} Bset isReflR) (_∗_ , h) =
   rec2 Bset _∗_ hleft hright
        where
        hleft : ∀ a b c → R a b → (a ∗ c) ≡ (b ∗ c)
        hleft _ _ c r = h _ _ _ _ r (isReflR c)
        hright : ∀ a b c → R b c → (a ∗ b) ≡ (a ∗ c)
        hright a _ _ r = h _ _ _ _ (isReflR a) r
Iso.rightInv (setQuotUniversal2Iso {A = A} {R = R} {B = B} Bset isReflR) (_∗_ , h) =
   Σ≡Prop (λ _ → isPropΠ4 λ _ _ _ _ → isPropΠ2 λ _ _ → Bset _ _) refl
Iso.leftInv (setQuotUniversal2Iso {A = A} {R = R} {B = B} Bset isReflR) _∗/_ =
   funExt₂ (elimProp2 (λ _ _ → Bset _ _) λ _ _ → refl)

setQuotUniversal2 : {B : Type ℓ} (Bset : isSet B) → isRefl R
                  → (A / R → A / R → B)
                  ≃ (Σ[ _∗_ ∈ (A → A → B) ] ((a a' b b' : A) → R a a' → R b b' → a ∗ b ≡ a' ∗ b'))
setQuotUniversal2 Bset isReflR = isoToEquiv (setQuotUniversal2Iso Bset isReflR)

-- corollary for binary operations
-- TODO: prove truncated inverse for effective relations
setQuotBinOp : isRefl R
             → (_∗_ : A → A → A)
             → (∀ a a' b b' → R a a' → R b b' → R (a ∗ b) (a' ∗ b'))
             → (A / R → A / R → A / R)
setQuotBinOp isReflR _∗_ h = Iso.inv (setQuotUniversal2Iso squash/ isReflR)
                             ((λ a b → [ a ∗ b ]) , λ _ _ _ _ ra rb → eq/ _ _ (h _ _ _ _ ra rb))

setQuotSymmBinOp : isRefl R → isTrans R
                 → (_∗_ : A → A → A)
                 → (∀ a b → a ∗ b ≡ b ∗ a)
                 → (∀ a a' b → R a a' → R (a ∗ b) (a' ∗ b))
                 → (A / R → A / R → A / R)
setQuotSymmBinOp {A = A} {R = R} isReflR isTransR _∗_ ∗-symm h = setQuotBinOp isReflR _∗_ h'
  where
  h' : ∀ a a' b b' → R a a' → R b b' → R (a ∗ b) (a' ∗ b')
  h' a a' b b' ra rb = isTransR _ _ _ (h a a' b ra)
                               (transport (λ i → R (∗-symm b a' i) (∗-symm b' a' i)) (h b b' a' rb))

effective : (Rprop : isPropValued R) (Requiv : isEquivRel R) (a b : A) → [ a ] ≡ [ b ] → R a b
effective {A = A} {R = R} Rprop (equivRel R/refl R/sym R/trans) a b p = transport aa≡ab (R/refl _)
  where
    helper : A / R → hProp _
    helper =
      rec isSetHProp (λ c → (R a c , Rprop a c))
                     (λ c d cd → Σ≡Prop (λ _ → isPropIsProp)
                                        (hPropExt (Rprop a c) (Rprop a d)
                                                  (λ ac → R/trans _ _ _ ac cd) (λ ad → R/trans _ _ _ ad (R/sym _ _ cd))))

    aa≡ab : R a a ≡ R a b
    aa≡ab i = helper (p i) .fst

isEquivRel→effectiveIso : isPropValued R → isEquivRel R → (a b : A) → Iso ([ a ] ≡ [ b ]) (R a b)
Iso.fun (isEquivRel→effectiveIso {R = R} Rprop Req a b) = effective Rprop Req a b
Iso.inv (isEquivRel→effectiveIso {R = R} Rprop Req a b) = eq/ a b
Iso.rightInv (isEquivRel→effectiveIso {R = R} Rprop Req a b) _ = Rprop a b _ _
Iso.leftInv (isEquivRel→effectiveIso {R = R} Rprop Req a b) _ = squash/ _ _ _ _

isEquivRel→isEffective : isPropValued R → isEquivRel R → isEffective R
isEquivRel→isEffective Rprop Req a b = isoToIsEquiv (invIso (isEquivRel→effectiveIso Rprop Req a b))

discreteSetQuotients : Discrete A → isPropValued R → isEquivRel R → (∀ a₀ a₁ → Dec (R a₀ a₁)) → Discrete (A / R)
discreteSetQuotients {A = A} {R = R} Adis Rprop Req Rdec =
  elim (λ a₀ → isSetΠ (λ a₁ → isProp→isSet (isPropDec (squash/ a₀ a₁))))
    discreteSetQuotients' discreteSetQuotients'-eq
  where
    discreteSetQuotients' : (a : A) (y : A / R) → Dec ([ a ] ≡ y)
    discreteSetQuotients' a₀ = elim (λ a₁ → isProp→isSet (isPropDec (squash/ [ a₀ ] a₁))) dis dis-eq
      where
        dis : (a₁ : A) → Dec ([ a₀ ] ≡ [ a₁ ])
        dis a₁ with Rdec a₀ a₁
        ... | (yes p) = yes (eq/ a₀ a₁ p)
        ... | (no ¬p) = no λ eq → ¬p (effective Rprop Req a₀ a₁ eq )

        dis-eq : (a b : A) (r : R a b) →
          PathP (λ i → Dec ([ a₀ ] ≡ eq/ a b r i)) (dis a) (dis b)
        dis-eq a b ab = J (λ b ab → ∀ k → PathP (λ i → Dec ([ a₀ ] ≡ ab i)) (dis a) k)
                          (λ k → isPropDec (squash/ _ _) _  _) (eq/ a b ab) (dis b)

    discreteSetQuotients'-eq : (a b : A) (r : R a b) →
      PathP (λ i → (y : A / R) → Dec (eq/ a b r i ≡ y))
            (discreteSetQuotients' a) (discreteSetQuotients' b)
    discreteSetQuotients'-eq a b ab =
      J (λ b ab → ∀ k → PathP (λ i → (y : A / R) → Dec (ab i ≡ y))
                              (discreteSetQuotients' a) k)
        (λ k → funExt (λ x → isPropDec (squash/ _ _) _ _)) (eq/ a b ab) (discreteSetQuotients' b)

-- Quotienting by the truncated relation is equivalent to quotienting by untruncated relation
truncRelIso : Iso (A / R) (A / (λ a b → ∥ R a b ∥))
Iso.fun truncRelIso = rec squash/ [_] λ _ _ r → eq/ _ _ ∣ r ∣
Iso.inv truncRelIso = rec squash/ [_] λ _ _ → PropTrunc.rec (squash/ _ _) λ r → eq/ _ _ r
Iso.rightInv truncRelIso = elimProp (λ _ → squash/ _ _) λ _ → refl
Iso.leftInv truncRelIso = elimProp (λ _ → squash/ _ _) λ _ → refl

truncRelEquiv : A / R ≃ A / (λ a b → ∥ R a b ∥)
truncRelEquiv = isoToEquiv truncRelIso

-- Using this we can obtain a useful characterization of
-- path-types for equivalence relations (not prop-valued)
-- and their quotients

isEquivRel→TruncIso : isEquivRel R → (a b : A) → Iso ([ a ] ≡ [ b ])  ∥ R a b ∥
isEquivRel→TruncIso {A = A} {R = R} Req a b = compIso (isProp→Iso (squash/ _ _) (squash/ _ _)
                                   (cong (Iso.fun truncRelIso)) (cong (Iso.inv truncRelIso)))
                      (isEquivRel→effectiveIso  (λ _ _ → PropTrunc.propTruncIsProp) ∥R∥eq a b)
 where
 open isEquivRel
 ∥R∥eq : isEquivRel  λ a b → ∥ R a b ∥
 reflexive ∥R∥eq a = ∣ reflexive Req a ∣
 symmetric ∥R∥eq a b = PropTrunc.map (symmetric Req a b)
 transitive ∥R∥eq a b c = PropTrunc.map2 (transitive Req a b c)


open import Proc

module Hear (param : Param) where

open import Basics
private open module P = Process param

open Tran

hear : {a : U}{p : Proc a} -> Guard p -> LT a -> Proc a
hear {p = p} g    bot      = p
hear og           (lift v) = o
hear (w !g p)     (lift v) = w ! p
hear (>g f)       (lift v) = f v
hear (_ ! _ +g f) (lift v) = f v
hear (g1 ||g g2)  (lift v) = hear g1 (lift v) || hear g2 (lift v)
hear (φ /|g g)    (lift v) = φ /| hear g (downV φ v)
hear (defg x g)   (lift v) = hear g (lift v)

sound : {a : U}{p : Proc a}(g : Guard p){w : LT a} ->
        p -[ w ]-> hear g w
sound g            {bot}    = qtau
sound og           {lift v} = rx-o
sound (>g _)       {lift v} = rx->
sound (w !g p)     {lift v} = rx-!
sound (w ! p +g f) {lift v} = rx-+
sound (g1 ||g g2)  {lift v} = rx-|| (sound g1) (sound g2)
sound (φ /|g g)    {lift v} = rx-/| (sound g)
sound (defg x g)   {lift v} = rx-def (sound g)

uniq : {a : U}{p : Proc a}{w : LT a}{px py : Proc a} ->
       p -[ w ]-> px -> p -[ w ]-> py -> px == py
uniq qtau qtau = refl
uniq rx-o rx-o = refl
uniq rx-> rx-> = refl
uniq rx-! rx-! = refl
uniq rx-+ rx-+ = refl
uniq (rx-|| l1 r1) (rx-|| l2 r2) with uniq l1 l2 | uniq r1 r2
... | refl | refl = refl
uniq (rx-/| r1) (rx-/| r2) with uniq r1 r2
... | refl = refl
uniq (rx-def r1) (rx-def r2) with uniq r1 r2
... | refl = refl

complete : {a : U}{p : Proc a}(g : Guard p){w : LT a}{p' : Proc a} ->
           p -[ w ]-> p' -> p' == hear g w
complete g r = uniq r (sound g)


{-# OPTIONS --universe-polymorphism --allow-unsolved-metas #-}
module Issue253 where

open import Common.Level

data Id l (X : Set l)(x : X) : X → Set where
  refl : Id l X x x

resp : (A B : Set _) → Id _ (Set _) A B → Set
resp  _ _ eq with eq
resp ._ _ eq | refl = Level

{-
An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Telescope.hs:51
-}


module ProcessAlgebra where

open import Data.Nat
open import Data.Nat.Properties
open import Data.List

data Channel : Set where
  ℂ_ : ℕ → Channel

data ℙ : Set₁ where
  ν_[_] : List Channel → (Channel → ℙ) → ℙ
  B_,_ : Channel → ℙ → ℙ
  Send_[_],_ : ∀ {A : Set} → Channel → A → ℙ → ℙ
  Recv_,_ : ∀ {A : Set} → Channel → (A → ℙ) → ℙ
  _||_ : ℙ → ℙ → ℙ
  Dup_ : ℙ → ℙ
  Done : ℙ

data Message : Set₁ where
  _,_of_ : Channel → (A : Set) → A → Message

data Action : Set₁ where
  Out_ : Message → Action
  In_  : Message → Action

data Label : Set₁ where
  Silent : Label
  Act_ : Action → Label


-- 2014-05-16 Andreas: Question mark not recognized by emacs

module _ where

data Nat : Set where
  suc : Nat → Nat

data Fin : Nat → Set where
  zero : ∀ n → Fin (suc n)

test : ∀ n → Fin n → Set
test .? (zero n) = Nat

-- The questionmark in the dot pattern is not recognized by emacs-mode.

-- This cannot be tested by test/interaction, but I still put the test case here.


-- Example by Ian Orton

{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

_∧_ : Bool → Bool → Bool
true ∧ y = y
false ∧ y = false

data ⊥ : Set where

⊥-elim : ∀ {a} {A : Set a} → ⊥ → A
⊥-elim ()

¬_ : ∀ {a} → Set a → Set a
¬ A = A → ⊥

contradiction : ∀ {a b} {A : Set a} {B : Set b} → A → ¬ A → B
contradiction a f = ⊥-elim (f a)

_≢_ : ∀ {a} {A : Set a} (x y : A) → Set a
x ≢ y = ¬ (x ≡ y)

postulate
  obvious : (b b' : Bool) (p : b ≢ b') → (b ∧ b') ≡ false

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE obvious #-}

oops : (b : Bool) → b ∧ b ≡ false
oops b = refl

true≢false : true ≡ false → ⊥
true≢false ()

bot : ⊥
bot = true≢false (oops true)


-- A Beth model of normal forms

open import Library hiding (_∈_; All)

module NfModel (Base : Set) where

import Formulas   ; open module Form = Formulas    Base
import Derivations; open module Der  = Derivations Base

-- Beth model

-- A cover for Γ is the skeleton of a case tree that can be formed in Γ.
-- It contains the (neutral) scrutinees we case over and the markers (hole)
-- for the leaves that have to be filled by the branches of the case statement.

data Cover (Γ : Cxt) : Set where
  hole   : Cover Γ
  falseC : (t : Ne Γ False) → Cover Γ
  orC    : ∀{A B} (t : Ne Γ (A ∨ B)) (c : Cover (Γ ∙ A)) (d : Cover (Γ ∙ B)) → Cover Γ

-- Choice of names.
-- hole  : has the same role as the hole-evaluation context (identity).
-- falseC: basically falseE.
-- orC   : basically orE.

-- Given c : Cover Γ, a path p : Δ ∈ c leads us from the root to one of the leaves (hole)
-- of the case tree.  Δ is the context at the leaf.

data _∈_ Δ : ({Γ} : Cxt) (c : Cover Γ) → Set where
  here  : Δ ∈ hole {Δ}
  left  : ∀{Γ A B c d} {t : Ne Γ (A ∨ B)} (e : Δ ∈ c) → Δ ∈ orC t c d
  right : ∀{Γ A B c d} {t : Ne Γ (A ∨ B)} (e : Δ ∈ d) → Δ ∈ orC t c d

-- Given a case tree c : Cover Γ and a context-indexed set P,
-- f : All c P  is an assignment of things in  P Δ  to holes
-- of type Δ reached by pathes e : Δ ∈ c.

All : ∀{Γ} (c : Cover Γ) (P : (Δ : Cxt) → Set) → Set
All c P = ∀{Δ} (e : Δ ∈ c) → P Δ

-- We can also use All c P with a property P on context,
-- to express that all holes of c satify P.

-- We might want to depend on the path e : Δ ∈ c also:

All' : ∀{Γ} (c : Cover Γ) (P : ∀ {Δ} (e : Δ ∈ c) → Set) → Set
All' c P = ∀{Δ} (e : Δ ∈ c) → P e

-- If  c : Cover Γ  and  e : Δ ∈ C,  then Δ must be an extension of Γ.
-- Here, we only prove that it is a thinning.

coverWk : ∀{Γ} {c : Cover Γ} → All c (_≤ Γ)
coverWk here      = id≤
coverWk (left  e) = coverWk e • weak id≤
coverWk (right e) = coverWk e • weak id≤

-- We can substitute leaves in the case tree by case trees in turn.
-- The following is a ``parallel substitution'' operations for covers.

-- If c : Cover Γ and f is a mapping from the leaves of c to case trees
-- we can graft f onto c to get a new case tree  transC c f.

-- Here, the case tree substitution is given as a function from pathes
-- p : Δ ∈ c  to covers.

transC : ∀{Γ} (c : Cover Γ) (f : All c Cover) → Cover Γ
transC hole        f = f here
transC (falseC t)  f = falseC t
transC (orC t c d) f = orC t (transC c (f ∘ left)) (transC d (f ∘ right))

-- Composition of pathes.

-- Assume a c : Cover Γ and a substitution f : Δ ∈ c → ∁over Δ and a path e : Δ ∈ c.
-- Then any path p : Φ ∈ f e can be extended to a path q : Φ ∈ transC c f
-- by essentially concatenating e and p.

-- Note that we maintain f only for the sake of typing.

-- trans∈ : ∀{Γ} (c : Cover Γ) (f : All c Cover) →
--   ∀ {Δ} (e : Δ ∈ c) {Φ} → Φ ∈ f e → Φ ∈ transC c f

trans∈ : ∀{Γ} (c : Cover Γ) (f : All c Cover) →
  All' c λ {Δ} (e : Δ ∈ c) → All (f e) (_∈ transC c f)
trans∈ hole        f here      = id
trans∈ (falseC t)  f ()
trans∈ (orC t c d) f (left  e) = left  ∘ trans∈ c (f ∘ left ) e
trans∈ (orC t c d) f (right e) = right ∘ trans∈ d (f ∘ right) e

-- Splitting of pathes.

-- In a situation similar to the previous lemma:
-- If we have a path q : Φ ∈ transC c f we can split it into some
-- e : Δ ∈ c and p : Φ ∈ f e.

split∈ : ∀{Γ} (c : Cover Γ) (f : All c Cover) {Φ} (q : Φ ∈ transC c f)
  → ∃ λ Δ → ∃ λ (e : Δ ∈ c) → Φ ∈ f e
split∈ hole        f q = _ , _ , q
split∈ (falseC t)  f ()
split∈ (orC t c d) f (left q) with split∈ c (f ∘ left) q
... | Δ , e₁ , e₂ = Δ , left e₁ , e₂
split∈ (orC t c d) f (right q) with split∈ d (f ∘ right) q
... | Δ , e₁ , e₂ = Δ , right e₁ , e₂

-- Syntactic paste (from Thorsten).

-- If for each leave e : Δ ∈ c of a case tree c : Cover Γ we have a normal form
-- f e : Nf Δ A  of type A, grafting these nfs onto c gives us a  Nf Γ A.

pasteNf : ∀{A Γ} (c : Cover Γ) (f : All c λ Δ → Nf Δ A) → Nf Γ A
pasteNf hole        f = f here
pasteNf (falseC t)  f = falseE t
pasteNf (orC t c d) f = orE t (pasteNf c (f ∘ left)) (pasteNf d (f ∘ right))

-- Weakening covers:  A case tree in Γ can be transported to a thinning Δ
-- by weakening all the scrutinees.

-- monC : ∀{Γ Δ} (τ : Δ ≤ Γ) (c : Cover Γ) → Cover Δ
monC : Mon Cover
monC τ hole        = hole
monC τ (falseC t)  = falseC (monNe τ t)
monC τ (orC t c d) = orC (monNe τ t) (monC (lift τ) c) (monC (lift τ) d)

-- Undoing a weakening on a path.
--
-- If we have a path  e : Φ ∈ monC τ c  in a case tree  c : Cover Γ  transported
-- to Δ via thinning  τ : Δ ≤ Γ, we also get a path  e' : Ψ ∈ c  in the original
-- case tree c such that Ψ is a strenthening of Φ  (Φ ≤ Ψ).

mon∈ : ∀{Γ Δ Φ} (c : Cover Γ) (τ : Δ ≤ Γ) (e : Φ ∈ monC τ c) → ∃ λ Ψ → Ψ ∈ c × Φ ≤ Ψ
mon∈  hole τ here = _ , here , τ
mon∈ (falseC t)  τ ()
mon∈ (orC t c d) τ (left e)  with mon∈ c (lift τ) e
... | Ψ , e' , σ = Ψ , left e' , σ
mon∈ (orC t c d) τ (right e) with mon∈ d (lift τ) e
... | Ψ , e' , σ = Ψ , right e' , σ

-- Packaging a case tree with its valuation.

CovExt : (Γ : Cxt) (P : Cxt → Set) → Set
CovExt Γ P = Σ (Cover Γ) λ c → All c P

transCE : ∀ {P Γ} (c : Cover Γ) (f : All c λ Δ → CovExt Δ P) → CovExt Γ P
transCE c f = transC c (proj₁ ∘ f) , λ e →
  let _ , e₁ , e₂ = split∈ c (proj₁ ∘ f) e
  in  f e₁ .proj₂ e₂

monCE : ∀{P} → Mon P → Mon λ Γ → CovExt Γ P
monCE monP τ (c , f) = monC τ c ,  λ {Φ} e →
  let Ψ , e' , σ = mon∈ c τ e
  in  monP σ (f {Ψ} e')

-- The syntactic Beth model.

-- We interpret base propositions  Atom P  by their normal deriviations.
-- ("Normal" is important; "neutral is not sufficient since we need case trees here.)

-- The negative connectives True, ∧, and ⇒ are explained as usual by η-expansion
-- and the meta-level connective.

-- The positive connectives False and ∨ are inhabited by case trees.
-- In case False, the tree has no leaves.
-- In case A ∨ B, each leaf must be in the semantics of either A or B.

T⟦_⟧ : (A : Form) (Γ : Cxt) → Set
T⟦ Atom P ⟧ Γ = Nf Γ (Atom P)
T⟦ True   ⟧ Γ = ⊤
T⟦ False  ⟧ Γ = CovExt Γ λ Δ → ⊥
T⟦ A ∨ B  ⟧ Γ = CovExt Γ λ Δ → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ
T⟦ A ∧ B  ⟧ Γ = T⟦ A ⟧ Γ × T⟦ B ⟧ Γ
T⟦ A ⇒ B  ⟧ Γ = ∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ B ⟧ Δ

-- Monotonicity of the model is proven by induction on the proposition,
-- using monotonicity of covers and the built-in monotonicity at implication.

-- monT : ∀ A {Γ Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ → T⟦ A ⟧ Δ

monT : ∀ A → Mon T⟦ A ⟧
monT (Atom P) = monNf
monT True     = _
monT False    = monCE λ τ ()
monT (A ∨ B)  = monCE λ τ → map-⊎ (monT A τ) (monT B τ)
monT (A ∧ B) τ (a , b) = monT A τ a , monT B τ b
monT (A ⇒ B) τ f σ = f (σ • τ)

-- Reflection / reification, proven simultaneously by induction on the proposition.

-- Reflection is η-expansion (and recursively reflection);
-- at positive connections we build a case tree with a single scrutinee: the neutral
-- we are reflecting.

-- At implication, we need reification, which produces introductions
-- and reifies the stored case trees.

mutual

  reflect : ∀{Γ} A (t : Ne Γ A) → T⟦ A ⟧ Γ
  reflect (Atom P) t = ne t
  reflect True     t = _
  reflect False    t = falseC t , λ()
  reflect (A ∨ B)  t = orC t hole hole , λ where
    (left  here) → inj₁ (reflect A (hyp top))
    (right here) → inj₂ (reflect B (hyp top))
  reflect (A ∧ B)  t = reflect A (andE₁ t) , reflect B (andE₂ t)
  reflect (A ⇒ B)  t τ a = reflect B (impE (monNe τ t) (reify A a))

  reify : ∀{Γ} A (⟦f⟧ : T⟦ A ⟧ Γ) → Nf Γ A
  reify (Atom P) t      = t
  reify True _          = trueI
  reify False   (c , f) = pasteNf c (⊥-elim ∘ f)
  reify (A ∨ B) (c , f) = pasteNf c ([ orI₁ ∘ reify A , orI₂ ∘ reify B ] ∘ f)
  reify (A ∧ B) (a , b) = andI (reify A a) (reify B b)
  reify (A ⇒ B) ⟦f⟧     = impI (reify B (⟦f⟧ (weak id≤) (reflect A (hyp top))))

-- Semantic paste.

-- This grafts semantic values f onto a case tree c : Cover Γ.
-- For atomic propositions, this is grafting of normal forms (defined before).

paste : ∀ A {Γ} (c : Cover Γ) (f : All c (T⟦ A ⟧)) → T⟦ A ⟧ Γ
paste (Atom P) = pasteNf
paste True     = _
paste False    = transCE
paste (A ∨ B)  = transCE
paste (A ∧ B) c f = paste A c (proj₁ ∘ f) , paste B c (proj₂ ∘ f)
paste (A ⇒ B) c f τ a = paste B (monC τ c) λ {Δ} e →
  let Ψ , e' , σ  = mon∈ c τ e
  in  f e' σ (monT A (coverWk e) a)

-- Fundamental theorem
-- Extension of T⟦_⟧ to contexts

G⟦_⟧ : ∀ (Γ Δ : Cxt) → Set
G⟦ ε     ⟧ Δ = ⊤
G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × T⟦ A ⟧ Δ

-- monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ

monG : ∀{Γ} → Mon G⟦ Γ ⟧
monG {ε} τ _ = _
monG {Γ ∙ A} τ (γ , a) = monG τ γ , monT A τ a

-- Variable case.

fundH : ∀{Γ Δ A} (x : Hyp A Γ) (γ : G⟦ Γ ⟧ Δ) → T⟦ A ⟧ Δ
fundH top     = proj₂
fundH (pop x) = fundH x ∘ proj₁

-- A lemma for the orE case.

orElim : ∀ {Γ A B E} → T⟦ A ∨ B ⟧ Γ →
         (∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ E ⟧ Δ) →
         (∀{Δ} (τ : Δ ≤ Γ) → T⟦ B ⟧ Δ → T⟦ E ⟧ Δ) →
         T⟦ E ⟧ Γ
orElim (c , f) g h = paste _ c λ e → case f e of [ g (coverWk e) , h (coverWk e) ]

-- A lemma for the falseE case.

-- Casts an empty cover into any semantic value (by contradiction).

falseElim : ∀{Γ A} → T⟦ False ⟧ Γ → T⟦ A ⟧ Γ
falseElim (c , f) = paste _ c (⊥-elim ∘ f)

-- The fundamental theorem

fund :  ∀{Γ A} (t : Γ ⊢ A) {Δ} (γ : G⟦ Γ ⟧ Δ) → T⟦ A ⟧ Δ
fund (hyp x)           = fundH x
fund (impI t)    γ τ a = fund t (monG τ γ , a)
fund (impE t u)  γ     = fund t γ id≤ (fund u γ)
fund (andI t u)  γ     = fund t γ , fund u γ
fund (andE₁ t)         = proj₁ ∘ fund t
fund (andE₂ t)         = proj₂ ∘ fund t
fund (orI₁ t)    γ     = hole , inj₁ ∘ λ{ here → fund t γ }
fund (orI₂ t)    γ     = hole , inj₂ ∘ λ{ here → fund t γ }
fund (orE t u v) γ     = orElim (fund t γ)
  (λ τ a → fund u (monG τ γ , a))
  (λ τ b → fund v (monG τ γ , b))
fund (falseE t)  γ     = falseElim (fund t γ)
fund trueI       γ     = _

-- Identity environment

ide : ∀ Γ → G⟦ Γ ⟧ Γ
ide ε = _
ide (Γ ∙ A) = monG (weak id≤) (ide Γ) , reflect A (hyp top)

-- Normalization

norm : ∀{Γ A} (t : Γ ⊢ A) → Nf Γ A
norm t = reify _ (fund t (ide _))

-- Q.E.D. -}