{-# OPTIONS --copatterns #-}

module SizedPolyIO.Base where

open import Data.Maybe.Base
open import Data.Sum renaming (inj₁ to left; inj₂ to right; [_,_]′ to either)

open import Function
open import Level using (_⊔_) renaming (suc to lsuc)
open import Size

open import NativePolyIO

record IOInterface γ ρ : Set (lsuc (γ ⊔ ρ)) where
  field
    Command   : Set γ
    Response  : (m : Command) → Set ρ
open IOInterface public

module _ {γ ρ} (I : IOInterface γ ρ) (let C = Command I) (let R = Response I) where

  mutual
    record IO (i : Size) {α} (A : Set α) : Set (α ⊔ γ ⊔ ρ) where
      coinductive
      constructor delay
      field
        force : {j : Size< i} → IO' j A

    data IO' (i : Size) {α} (A : Set α) : Set (α ⊔ γ ⊔ ρ) where
      do'      : (c : C) (f : R c → IO i A) → IO' i A
      return' : (a : A) → IO' i A

    data IO+ (i : Size) {α} (A : Set α) : Set (α ⊔ ρ ⊔ γ) where
      do' : (c : C) (f : R c → IO i A) → IO+ i A

open IO public

module _ {γ ρ} {I : IOInterface γ ρ} (let C = Command I) (let R = Response I) where

  return : ∀{i α}{A : Set α} (a : A) → IO I i A
  force (return a) = return' a

  do : ∀{i α}{A : Set α} (c : C) (f : R c → IO I i A) → IO I i A
  force (do c f) = do' c f

  do1 :  ∀{i} (c : C) → IO I i (R c)
  do1 c = do c return

  infixl 2 _>>=_ _>>='_ _>>_

  mutual
    _>>='_ : ∀{i α}{A B : Set α} (m : IO' I i A) (k : A → IO I (↑ i) B) → IO' I i B
    do' c f    >>=' k = do' c λ x → f x >>= k
    return' a >>=' k = force (k a)

    _>>=_ : ∀{i α}{A B : Set α} (m : IO I i A) (k : A → IO I i B) → IO I i B
    force (m >>= k) = force m >>=' k

  _>>_ : ∀{i α}{B : Set α} (m : IO I i Unit) (k : IO I i B) → IO I i B
  m >> k = m >>= λ _ → k

  {-# NON_TERMINATING #-}
  translateIO : ∀{α}{A : Set α}
    →  (translateLocal : (c : C) → NativeIO (R c))
    →  IO I ∞ A
    →  NativeIO A
  translateIO translateLocal m = case (force m {_}) of
    λ{ (do' c f)    → (translateLocal c) native>>= λ r →
         translateIO translateLocal (f r)
     ; (return' a) → nativeReturn a
     }

  -- Recursion

  -- trampoline provides a generic form of loop (generalizing while/repeat).
  -- Starting at state s : S, step function f is iterated until it returns
  -- a result in A.

  fromIO+' : ∀{i α}{A : Set α} → IO+ I i A → IO' I i A
  fromIO+' (do' c f) = do' c f

  fromIO+ : ∀{i α}{A : Set α} → IO+ I i A → IO I i A
  force (fromIO+ (do' c f)) = do' c f

  _>>=+'_ : ∀{i α}{A B : Set α} (m : IO+ I i A) (k : A → IO I i B) → IO' I i B
  do' c f >>=+' k = do' c λ x → f x >>= k

  _>>=+_ : ∀{i α}{A B : Set α} (m : IO+ I i A) (k : A → IO I i B) → IO I i B
  force (m >>=+ k) = m >>=+' k

  mutual

    _>>+_ : ∀{i α}{A B : Set α} (m : IO I i (A ⊎ B)) (k : A → IO I i B) → IO I i B
    force (m >>+ k) = force m >>+' k

    _>>+'_ : ∀{j α}{A B : Set α} (m : IO' I j (A ⊎ B)) (k : A → IO I (↑ j) B) → IO' I j B
    do' c f            >>+' k = do' c λ x → f x >>+ k
    return' (left  a) >>+' k = force (k a)
    return' (right b) >>+' k = return' b

   -- loop

  trampoline : ∀{i α}{A S : Set α} (f : S → IO+ I i (S ⊎ A)) (s : S) → IO I i A
  force (trampoline f s) = case (f s) of
    \{ (do' c k) → do' c λ r → k r >>+ trampoline f }

  -- simple infinite loop

  forever : ∀{i α}{A B : Set α} → IO+ I i A → IO I i B
  force (forever (do' c f)) = do' c λ r → f r >>= λ _ → forever (do' c f)

  whenJust : ∀{i α}{A : Set α} → Maybe A → (A → IO I i (Unit {α})) → IO I i Unit
  whenJust nothing  k = return _
  whenJust (just a) k = k a


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Symmetry {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening hiding (wk)
open import Definition.Typed.Properties
open import Definition.Typed.EqualityRelation
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Conversion

open import Tools.Product
open import Tools.Empty
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

mutual
  -- Helper function for symmetry of type equality using shape views.
  symEqT : ∀ {Γ A B r l l′} {[A] : Γ ⊩⟨ l ⟩ A ^ r} {[B] : Γ ⊩⟨ l′ ⟩ B ^ r}
         → ShapeView Γ l l′ A B r r [A] [B]
         → Γ ⊩⟨ l  ⟩ A ≡ B ^ r / [A]
         → Γ ⊩⟨ l′ ⟩ B ≡ A ^ r / [B]
  symEqT (ℕᵥ D D′) A≡B = red D
  symEqT (Emptyᵥ D D′) A≡B = red D
  symEqT (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ne₌ M D′ neM K≡M)
         rewrite whrDet* (red D′ , ne neM) (red D₁ , ne neK₁) =
    ne₌ _ D neK
        (~-sym K≡M)
  symEqT {Γ = Γ} {r = [ r , ι lΠ ] } (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                     (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
         (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
    let ΠF₁G₁≡ΠF′G′   = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        F₁≡F′ , rF₁≡rF′ , lF₁≡lF′ , G₁≡G′ , lG₁≡lG′ , lΠ≡lΠ₁ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        [F₁≡F] : ∀ {Δ} {ρ} [ρ] ⊢Δ → _
        [F₁≡F] {Δ} {ρ} [ρ] ⊢Δ =
          let ρF′≡ρF₁ ρ = PE.cong (wk ρ) (PE.sym F₁≡F′)
              [ρF′] {ρ} [ρ] ⊢Δ = PE.subst (λ x → Δ ⊩⟨ _ ⟩ wk ρ x ^ _) F₁≡F′ ([F]₁ [ρ] ⊢Δ)
          in  irrelevanceEq′ {Δ} (ρF′≡ρF₁ ρ) PE.refl PE.refl
                             ([ρF′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ)
                             (symEq′ (PE.sym rF₁≡rF′) (PE.cong ι (PE.sym lF₁≡lF′)) ([F] [ρ] ⊢Δ) ([ρF′] [ρ] ⊢Δ)
                                    ([F≡F′] [ρ] ⊢Δ))
    in  Π₌ _ _ (red (PE.subst₃ _ (PE.sym rF₁≡rF′) (PE.sym lF₁≡lF′) (PE.sym lG₁≡lG′) D))
           (PE.subst₃ _ (PE.sym rF₁≡rF′) (PE.sym lF₁≡lF′) (PE.sym lG₁≡lG′) (≅-sym (PE.subst (λ x → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ≅ x ^ [ r , ι lΠ ]) (PE.sym ΠF₁G₁≡ΠF′G′) A≡B)))
           [F₁≡F]
           (λ {ρ} [ρ] ⊢Δ [a] →
               let ρG′a≡ρG₁′a = PE.cong (λ x → wk (lift ρ) x [ _ ]) (PE.sym G₁≡G′)
                   [ρG′a] = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk (lift ρ) x [ _ ] ^ _) G₁≡G′
                                     ([G]₁ [ρ] ⊢Δ [a])
                   [a]₁ = convTerm₁′ rF₁≡rF′ (PE.cong ι lF₁≡lF′) ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) ([F₁≡F] [ρ] ⊢Δ) [a]
               in  irrelevanceEq′ ρG′a≡ρG₁′a PE.refl PE.refl
                                  [ρG′a]
                                  ([G]₁ [ρ] ⊢Δ [a]) (symEq′ PE.refl (PE.sym (PE.cong ι lG₁≡lG′)) ([G] [ρ] ⊢Δ [a]₁) [ρG′a] ([G≡G′] [ρ] ⊢Δ [a]₁)))
  symEqT {Γ = Γ} {r = r} (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                     (∃ᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
         (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
    let ∃F₁G₁≡∃F′G′   = whrDet* (red D₁ , ∃ₙ) (D′ , ∃ₙ)
        F₁≡F′ , G₁≡G′ = ∃-PE-injectivity ∃F₁G₁≡∃F′G′
        [F₁≡F] : ∀ {Δ} {ρ} [ρ] ⊢Δ → _
        [F₁≡F] {Δ} {ρ} [ρ] ⊢Δ =
          let ρF′≡ρF₁ ρ = PE.cong (wk ρ) (PE.sym F₁≡F′)
              [ρF′] {ρ} [ρ] ⊢Δ = PE.subst (λ x → Δ ⊩⟨ _ ⟩ wk ρ x ^ _) F₁≡F′ ([F]₁ [ρ] ⊢Δ)
          in  irrelevanceEq′ {Δ} (ρF′≡ρF₁ ρ) PE.refl PE.refl
                             ([ρF′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ)
                             (symEq′ PE.refl PE.refl ([F] [ρ] ⊢Δ) ([ρF′] [ρ] ⊢Δ)
                                    ([F≡F′] [ρ] ⊢Δ))
    in  ∃₌ _ _ (red D) (≅-sym (PE.subst (λ x → Γ ⊢ ∃ F ▹ G ≅ x ^ r) (PE.sym ∃F₁G₁≡∃F′G′) A≡B))
          [F₁≡F]
          (λ {ρ} [ρ] ⊢Δ [a] →
               let ρG′a≡ρG₁′a = PE.cong (λ x → wk (lift ρ) x [ _ ]) (PE.sym G₁≡G′)
                   [ρG′a] = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk (lift ρ) x [ _ ] ^ _) G₁≡G′
                                     ([G]₁ [ρ] ⊢Δ [a])
                   [a]₁ = convTerm₁′ PE.refl PE.refl ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) ([F₁≡F] [ρ] ⊢Δ) [a]
               in  irrelevanceEq′ ρG′a≡ρG₁′a PE.refl PE.refl
                                  [ρG′a]
                                  ([G]₁ [ρ] ⊢Δ [a])
                                  (symEq ([G] [ρ] ⊢Δ [a]₁) [ρG′a]
                                         ([G≡G′] [ρ] ⊢Δ [a]₁)))
  symEqT (Uᵥ (Uᵣ r l l< el d) (Uᵣ r' l' l<' PE.refl d')) A≡B =
    let U≡U   = whrDet* (A≡B , Uₙ) (red d' , Uₙ)
        r≡r , l≡l = Univ-PE-injectivity (PE.sym U≡U)
    in PE.subst _ (PE.sym l≡l) (PE.subst _ (PE.sym r≡r) (red d))
  symEqT (emb⁰¹ X) A≡B = symEqT X A≡B
  symEqT (emb¹⁰ X) A≡B = symEqT X A≡B
  symEqT (emb¹∞ X) A≡B = symEqT X A≡B
  symEqT (emb∞¹ X) A≡B = symEqT X A≡B

  -- Symmetry of type equality.
  symEq : ∀ {Γ A B r l l′} ([A] : Γ ⊩⟨ l ⟩ A ^ r) ([B] : Γ ⊩⟨ l′ ⟩ B ^ r)
        → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
        → Γ ⊩⟨ l′ ⟩ B ≡ A ^ r / [B]
  symEq [A] [B] A≡B = symEqT (goodCases [A] [B] A≡B) A≡B

  -- same but with PE
  symEq′ : ∀ {Γ A B r r' l l′ ll ll'} (eq : r PE.≡ r') (eq' : ll PE.≡ ll')
             ([A] : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) ([B] : Γ ⊩⟨ l′ ⟩ B ^ [ r' , ll' ])
        → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ll ] / [A]
        → Γ ⊩⟨ l′ ⟩ B ≡ A ^ [ r' , ll' ] / [B]
  symEq′ PE.refl PE.refl [A] [B] A≡B = symEq [A] [B] A≡B

symNeutralTerm : ∀ {t u A r Γ}
               → Γ ⊩neNf t ≡ u ∷ A ^ r
               → Γ ⊩neNf u ≡ t ∷ A ^ r
symNeutralTerm {r = [ ! , ll ]} (neNfₜ₌ neK neM k≡m) = neNfₜ₌ neM neK (~-sym k≡m)
symNeutralTerm {r = [ % , ll ]} (neNfₜ₌ neK neM k≡m) = neNfₜ₌ neM neK (~-sym k≡m)

symNatural-prop : ∀ {Γ k k′}
                → [Natural]-prop Γ k k′
                → [Natural]-prop Γ k′ k
symNatural-prop (sucᵣ (ℕₜ₌ k k′ d d′ t≡u prop)) =
  sucᵣ (ℕₜ₌ k′ k d′ d (≅ₜ-sym t≡u) (symNatural-prop prop))
symNatural-prop zeroᵣ = zeroᵣ
symNatural-prop (ne prop) = ne (symNeutralTerm prop)

symEmpty-prop : ∀ {Γ k k′ l}
                → [Empty]-prop Γ k k′ l
                → [Empty]-prop Γ k′ k l
symEmpty-prop (ne t u ) = ne u t

symEqTerm⁰ : ∀ {Γ A t u r} ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ r)
          → Γ ⊩⟨ ι ⁰ ⟩ t ≡ u ∷ A ^ r / [A]
          → Γ ⊩⟨ ι ⁰ ⟩ u ≡ t ∷ A ^ r / [A]
symEqTerm⁰ (ℕᵣ D) (ℕₜ₌ k k′ d d′ t≡u prop) =
  ℕₜ₌ k′ k d′ d (≅ₜ-sym t≡u) (symNatural-prop prop)
symEqTerm⁰ (Emptyᵣ D) (Emptyₜ₌ prop) = Emptyₜ₌ (symEmpty-prop prop)
symEqTerm⁰ {r = [ ! , ll ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ nf) =
  neₜ₌ m k d′ d (symNeutralTerm nf)
symEqTerm⁰ {r = [ % , ll ]} (ne′ K D neK K≡K) (neₜ₌ d d′) = neₜ₌ d′ d
symEqTerm⁰ {r = [ ! , ll ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  Πₜ₌ g f d′ d funcG funcF (≅ₜ-sym f≡g) [g] [f]
      (λ ρ ⊢Δ [a] → symEqTerm⁰ ([G] ρ ⊢Δ [a]) ([f≡g] ρ ⊢Δ [a]))
symEqTerm⁰ {r = [ % , ll ]} (Πᵣ′ rF lF _ _ F lG G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d
symEqTerm⁰ {r = [ % , ll ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d

symEqTerm¹ : ∀ {Γ A t u r} ([A] : Γ ⊩⟨ ι ¹ ⟩ A ^ r)
          → Γ ⊩⟨ ι ¹ ⟩ t ≡ u ∷ A ^ r / [A]
          → Γ ⊩⟨ ι ¹ ⟩ u ≡ t ∷ A ^ r / [A]
symEqTerm¹ {Γ} {A} {t} {u} (Uᵣ (Uᵣ r ⁰ l< el D)) (Uₜ₌ [A] [B] A≡B [A≡B]) =
  let
    [B≡A] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      symEq (LogRel._⊩¹U_∷_^_/_.[t] [A] [ρ] ⊢Δ) (LogRel._⊩¹U_∷_^_/_.[t] [B] [ρ] ⊢Δ) ([A≡B] [ρ] ⊢Δ)
    u_to_t : ∀ {ρ Δ a} → ([ρ] : ρ ∷ Δ ⊆ Γ) → (⊢Δ : ⊢ Δ)
      → ([a] : Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ u ^ [ r , ι ⁰ ] / (LogRel._⊩¹U_∷_^_/_.[t] [B] [ρ] ⊢Δ))
      → Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ t ^ [ r , ι ⁰ ] / (LogRel._⊩¹U_∷_^_/_.[t] [A] [ρ] ⊢Δ)
    u_to_t = λ [ρ] ⊢Δ [a] → convTerm₂ (LogRel._⊩¹U_∷_^_/_.[t] [A] [ρ] ⊢Δ) (LogRel._⊩¹U_∷_^_/_.[t] [B] [ρ] ⊢Δ) ([A≡B] [ρ] ⊢Δ) [a]
  in
  Uₜ₌ [B] [A] (≅ₜ-sym A≡B) [B≡A]
symEqTerm¹ (ℕᵣ D) (ℕₜ₌ k k′ d d′ t≡u prop) =
  ℕₜ₌ k′ k d′ d (≅ₜ-sym t≡u) (symNatural-prop prop)
symEqTerm¹ (Emptyᵣ D) (Emptyₜ₌ prop) = Emptyₜ₌ (symEmpty-prop prop)
symEqTerm¹ {r = [ ! , ll ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ nf) =
  neₜ₌ m k d′ d (symNeutralTerm nf)
symEqTerm¹ {r = [ % , ll ]} (ne′ K D neK K≡K) (neₜ₌ d d′) = neₜ₌ d′ d
symEqTerm¹ {r = [ ! , ll ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  Πₜ₌ g f d′ d funcG funcF (≅ₜ-sym f≡g) [g] [f]
      (λ ρ ⊢Δ [a] → symEqTerm¹ ([G] ρ ⊢Δ [a]) ([f≡g] ρ ⊢Δ [a]))
symEqTerm¹ {r = [ % , ll ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d
symEqTerm¹ {r = [ % , ll ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d
symEqTerm¹ (emb <l x) t≡u = symEqTerm⁰ x t≡u

-- Symmetry of term equality.
symEqTerm∞ : ∀ {Γ A t u r} ([A] : Γ ⊩⟨ ∞ ⟩ A ^ r)
          → Γ ⊩⟨ ∞ ⟩ t ≡ u ∷ A ^ r / [A]
          → Γ ⊩⟨ ∞ ⟩ u ≡ t ∷ A ^ r / [A]
symEqTerm∞ {Γ} {A} {t} {u} (Uᵣ (Uᵣ r ⁰ l< el D)) (Uₜ₌ [A] [B] A≡B [A≡B]) =
  let
    [B≡A] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      symEq (LogRel._⊩¹U_∷_^_/_.[t] [A] [ρ] ⊢Δ) (LogRel._⊩¹U_∷_^_/_.[t] [B] [ρ] ⊢Δ) ([A≡B] [ρ] ⊢Δ)
  in
  Uₜ₌ [B] [A] (≅ₜ-sym A≡B) [B≡A]
symEqTerm∞ {Γ} {A} {t} {u} (Uᵣ (Uᵣ r ¹ l< el D)) (Uₜ₌ [A] [B] A≡B [A≡B]) =
  let
    [B≡A] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      symEq (LogRel._⊩¹U_∷_^_/_.[t] [A] [ρ] ⊢Δ) (LogRel._⊩¹U_∷_^_/_.[t] [B] [ρ] ⊢Δ) ([A≡B] [ρ] ⊢Δ)
  in
  Uₜ₌ [B] [A] (≅ₜ-sym A≡B) [B≡A]
symEqTerm∞ (ℕᵣ D) (ℕₜ₌ k k′ d d′ t≡u prop) =
  ℕₜ₌ k′ k d′ d (≅ₜ-sym t≡u) (symNatural-prop prop)
symEqTerm∞ (Emptyᵣ D) (Emptyₜ₌ prop) = Emptyₜ₌ (symEmpty-prop prop)
symEqTerm∞ {r = [ ! , ll ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ nf) =
  neₜ₌ m k d′ d (symNeutralTerm nf)
symEqTerm∞ {r = [ % , ll ]} (ne′ K D neK K≡K) (neₜ₌ d d′) = neₜ₌ d′ d
symEqTerm∞ {r = [ ! , ll ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  Πₜ₌ g f d′ d funcG funcF (≅ₜ-sym f≡g) [g] [f]
      (λ ρ ⊢Δ [a] → symEqTerm∞ ([G] ρ ⊢Δ [a]) ([f≡g] ρ ⊢Δ [a]))
symEqTerm∞ {r = [ % , ll ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d
symEqTerm∞ {r = [ % , ll ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (d , d′) = d′ , d
symEqTerm∞ (emb <l x) t≡u = symEqTerm¹ x t≡u

symEqTerm : ∀ {l Γ A t u r} ([A] : Γ ⊩⟨ l ⟩ A ^ r)
          → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / [A]
          → Γ ⊩⟨ l ⟩ u ≡ t ∷ A ^ r / [A]
symEqTerm {l = ι ⁰} = symEqTerm⁰
symEqTerm {l = ι ¹} = symEqTerm¹
symEqTerm {l = ∞} = symEqTerm∞


module Structure.Operator.Properties where

import      Lvl
open import Functional
open import Lang.Instance
open import Logic
open import Logic.Predicate
open import Logic.Propositional
import      Structure.Operator.Names as Names
open import Structure.Setoid
open import Syntax.Function
open import Type

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

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₁ → T₁ → T₂) where
  record Commutativity : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Commutativity(_▫_)
  commutativity = inst-fn Commutativity.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₁ → T₂ → T₂) (id : T₁) where
  record Identityₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Identityₗ(_▫_)(id)
  identityₗ = inst-fn Identityₗ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₁ → T₂ → T₂) (null : T₂) where
  record Absorberᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Absorberᵣ(_▫_)(null)
  absorberᵣ = inst-fn Absorberᵣ.proof

module _ {T₁ : Type{ℓ₁}} ⦃ _ : Equiv{ℓₑ₁}(T₁) ⦄ {T₂ : Type{ℓ₂}} (_▫_ : T₁ → T₂ → T₁) (id : T₂) where
  record Identityᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₁} where
    constructor intro
    field proof : Names.Identityᵣ(_▫_)(id)
  identityᵣ = inst-fn Identityᵣ.proof

module _ {T₁ : Type{ℓ₁}} ⦃ _ : Equiv{ℓₑ₁}(T₁) ⦄ {T₂ : Type{ℓ₂}} (_▫_ : T₁ → T₂ → T₁) (null : T₁) where
  record Absorberₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₁} where
    constructor intro
    field proof : Names.Absorberₗ(_▫_)(null)
  absorberₗ = inst-fn Absorberₗ.proof

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) (id : T) where
  record Identity : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
    constructor intro
    field
      instance ⦃ left ⦄  : Identityₗ(_▫_)(id)
      instance ⦃ right ⦄ : Identityᵣ(_▫_)(id)
  identity-left = inst-fn (Identityₗ.proof ∘ Identity.left)
  identity-right = inst-fn (Identityᵣ.proof ∘ Identity.right)

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) where
  record Idempotence : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
    constructor intro
    field proof : Names.Idempotence(_▫_)
  idempotence = inst-fn Idempotence.proof

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) (id : T) where
  record Absorber : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
    constructor intro
    field
      instance ⦃ left ⦄  : Absorberₗ(_▫_)(id)
      instance ⦃ right ⦄ : Absorberᵣ(_▫_)(id)
  absorber-left = inst-fn (Absorberₗ.proof ∘ Absorber.left)
  absorber-right = inst-fn (Absorberᵣ.proof ∘ Absorber.right)

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ identityₗ : ∃(Identityₗ(_▫_)) ⦄ where
  module _ (x : T) where
    module _ (inv : T) where
      record InverseElementₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
        constructor intro
        field proof : Names.InverseElementₗ(_▫_)([∃]-witness identityₗ)(x)(inv)
      inverseElementₗ = inst-fn InverseElementₗ.proof
    InvertibleElementₗ = ∃(InverseElementₗ)

  module _ (inv : T → T) where
    record InverseFunctionₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field proof : Names.InverseFunctionₗ(_▫_)([∃]-witness identityₗ)(inv)
    inverseFunctionₗ = inst-fn InverseFunctionₗ.proof
  Invertibleₗ = ∃(InverseFunctionₗ)

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ identityᵣ : ∃(Identityᵣ(_▫_)) ⦄ where
  module _ (x : T) where
    module _ (inv : T) where
      record InverseElementᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
        constructor intro
        field proof : Names.InverseElementᵣ(_▫_)([∃]-witness identityᵣ)(x)(inv)
      inverseElementᵣ = inst-fn InverseElementᵣ.proof
    InvertibleElementᵣ = ∃(InverseElementᵣ)

  module _ (inv : T → T) where
    record InverseFunctionᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field proof : Names.InverseFunctionᵣ(_▫_)([∃]-witness identityᵣ)(inv)
    inverseFunctionᵣ = inst-fn InverseFunctionᵣ.proof
  Invertibleᵣ = ∃(InverseFunctionᵣ)

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ identity : ∃(Identity(_▫_)) ⦄ where
  module _ (x : T) where
    module _ (inv : T) where
      InverseElement : Stmt
      InverseElement =
        InverseElementₗ(_▫_) ⦃ [∃]-map-proof Identity.left  identity ⦄ (x)(inv) ∧
        InverseElementᵣ(_▫_) ⦃ [∃]-map-proof Identity.right identity ⦄ (x)(inv)
    InvertibleElement = ∃(InverseElement)

  module _ (inv : T → T) where
    import Logic.IntroInstances

    record InverseFunction : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field
        instance ⦃ left ⦄  : InverseFunctionₗ(_▫_) ⦃ [∃]-map-proof Identity.left  identity ⦄ (inv)
        instance ⦃ right ⦄ : InverseFunctionᵣ(_▫_) ⦃ [∃]-map-proof Identity.right identity ⦄ (inv)
    inverseFunction-left  = inst-fn (InverseFunctionₗ.proof ∘ InverseFunction.left)
    inverseFunction-right = inst-fn (InverseFunctionᵣ.proof ∘ InverseFunction.right)
  Invertible = ∃(InverseFunction)
  -- TODO: Add some kind of inverse function

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ absorberₗ : ∃(Absorberₗ(_▫_)) ⦄ where
  module _ (opp : T → T) where
    record ComplementFunctionₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field proof : Names.InverseFunctionₗ(_▫_)([∃]-witness absorberₗ)(opp)
    oppositeFunctionₗ = inst-fn ComplementFunctionₗ.proof

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ absorberᵣ : ∃(Absorberᵣ(_▫_)) ⦄ where
  module _ (opp : T → T) where
    record ComplementFunctionᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field proof : Names.InverseFunctionᵣ(_▫_)([∃]-witness absorberᵣ)(opp)
    oppositeFunctionᵣ = inst-fn ComplementFunctionᵣ.proof

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) ⦃ absorber : ∃(Absorber(_▫_)) ⦄ where
  module _ (opp : T → T) where
    record ComplementFunction : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
      constructor intro
      field
        instance ⦃ left ⦄  : ComplementFunctionₗ(_▫_) ⦃ [∃]-map-proof Absorber.left  absorber ⦄ (opp)
        instance ⦃ right ⦄ : ComplementFunctionᵣ(_▫_) ⦃ [∃]-map-proof Absorber.right absorber ⦄ (opp)

module _{T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) where
  record Associativity : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ} where
    constructor intro
    field proof : Names.Associativity(_▫_)
  associativity = inst-fn Associativity.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫₁_ : T₁ → T₂ → T₂) (_▫₂_ : T₂ → T₂ → T₂) where
  record Distributivityₗ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Distributivityₗ(_▫₁_)(_▫₂_)
  distributivityₗ = inst-fn Distributivityₗ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫₁_ : T₂ → T₁ → T₂) (_▫₂_ : T₂ → T₂ → T₂) where
  record Distributivityᵣ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Distributivityᵣ(_▫₁_)(_▫₂_)
  distributivityᵣ = inst-fn Distributivityᵣ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₃}(T₃) ⦄ (_▫_ : T₁ → T₂ → T₃) where
  record Cancellationₗ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₂ Lvl.⊔ ℓₑ₃} where
    constructor intro
    field proof : Names.Cancellationₗ(_▫_)
  cancellationₗ = inst-fn Cancellationₗ.proof

module _ {T₁ : Type{ℓ₁}} ⦃ _ : Equiv{ℓₑ₁}(T₁) ⦄ {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₃}(T₃) ⦄ (_▫_ : T₁ → T₂ → T₃) where
  record Cancellationᵣ : Stmt{Lvl.of(Type.of(_▫_)) Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓₑ₃} where
    constructor intro
    field proof : Names.Cancellationᵣ(_▫_)
  cancellationᵣ = inst-fn Cancellationᵣ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₁}(T₁) ⦄ (_▫₁_ : T₁ → T₃ → T₁) (_▫₂_ : T₁ → T₂ → T₃) where
  record Absorptionₗ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₁} where
    constructor intro
    field proof : Names.Absorptionₗ(_▫₁_)(_▫₂_)
  absorptionₗ = inst-fn Absorptionₗ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫₁_ : T₃ → T₂ → T₂) (_▫₂_ : T₁ → T₂ → T₃) where
  record Absorptionᵣ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.Absorptionᵣ(_▫₁_)(_▫₂_)
  absorptionᵣ = inst-fn Absorptionᵣ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫₁_ : T₁ → T₂ → T₃) (_▫₂_ : T₁ → T₃ → T₂) where
  record InverseOperatorₗ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : Names.InverseOperatorₗ(_▫₁_)(_▫₂_)
  inverseOperₗ = inst-fn InverseOperatorₗ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} ⦃ _ : Equiv{ℓₑ₁}(T₁) ⦄ (_▫₁_ : T₁ → T₂ → T₃) (_▫₂_ : T₃ → T₂ → T₁) where
  record InverseOperatorᵣ : Stmt{Lvl.of(Type.of(_▫₁_)) Lvl.⊔ Lvl.of(Type.of(_▫₂_)) Lvl.⊔ ℓₑ₁} where
    constructor intro
    field proof : Names.InverseOperatorᵣ(_▫₁_)(_▫₂_)
  inverseOperᵣ = inst-fn InverseOperatorᵣ.proof

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₁ → T₂ → T₂) (inv : T₁ → T₁) where
  InversePropertyₗ = InverseOperatorₗ(_▫_)(a ↦ b ↦ inv(a) ▫ b)
  module InversePropertyₗ = InverseOperatorₗ{_▫₁_ = _▫_}{_▫₂_ = a ↦ b ↦ inv(a) ▫ b}
  inversePropₗ = inverseOperₗ(_▫_)(a ↦ b ↦ inv(a) ▫ b)

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₂ → T₁ → T₂) (inv : T₁ → T₁) where
  InversePropertyᵣ = InverseOperatorᵣ(_▫_)(a ↦ b ↦ a ▫ inv(b))
  module InversePropertyᵣ = InverseOperatorᵣ{_▫₁_ = _▫_}{_▫₂_ = a ↦ b ↦ a ▫ inv(b)}
  inversePropᵣ = inverseOperᵣ(_▫_)(a ↦ b ↦ a ▫ inv(b))

module _ {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(T₂) ⦄ (_▫_ : T₁ → T₁ → T₂) where
  record Central(x : T₁) : Stmt{ℓ₁ Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : ∀{y : T₁} → (x ▫ y ≡ y ▫ x)


module Σ where

A : Set₁
A = Set


{-# OPTIONS --without-K #-}
module UnivalenceFiniteTypes where

open import Data.Empty
open import Data.Unit
open import Data.Unit.Core
open import Data.Nat renaming (_⊔_ to _⊔ℕ_)
open import Data.Sum renaming (map to _⊎→_)
open import Data.Product renaming (map to _×→_)
open import Function renaming (_∘_ to _○_)

open import FT
open import SimpleHoTT
open import Equivalences
open import TypeEquivalences
open import Path2Equiv
open import FT-Nat
open import Inspect
open import LeftCancellation
open import Equiv2Path

-- univalence
{-  This does not typecheck in reasonable time.
univalence₁ : {B₁ B₂ : FT} →
  (e : ⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧) → path2equiv (equiv2path e) ≡ e
univalence₁ {B₁} {B₂} (f , feq) with equiv₂ feq
... | mkqinv g  α  β = {!!}
-}

-- and this can't possibly be true!
-- note that even the "normal form" of equiv2path idequiv (ctrl-C ctrl-N)
-- is an absolutely enormous term.
univalence₂ : {B₁ B₂ : FT} → (p : B₁ ⇛ B₂) → equiv2path (path2equiv p) ≡ p
univalence₂ unite₊⇛ = {!!}
univalence₂ uniti₊⇛ = {!!}
univalence₂ swap₊⇛ = {!!}
univalence₂ assocl₊⇛ = {!!}
univalence₂ assocr₊⇛ = {!!}
univalence₂ unite⋆⇛ = {!!}
univalence₂ uniti⋆⇛ = {!!}
univalence₂ swap⋆⇛ = {!!}
univalence₂ assocl⋆⇛ = {!!}
univalence₂ assocr⋆⇛ = {!!}
univalence₂ distz⇛ = {!!}
univalence₂ factorz⇛ = {!!}
univalence₂ dist⇛ = {!!}
univalence₂ factor⇛ = {!!}
univalence₂ id⇛ = {!!}
univalence₂ (sym⇛ p) = {!!}
univalence₂ (p ◎ q) = {!!}
univalence₂ (p ⊕ q) = {!!}
univalence₂ (p ⊗ q) = {!!}

{-
univalence : {B₁ B₂ : FT} → (B₁ ⇛ B₂) ≃ (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧)
univalence =
  (path2equiv , equiv₁ (mkqinv equiv2path univalence₁ univalence₂))
-}


-- Andreas, 2015-03-16

open import Common.Size
open import Common.Prelude

-- Note: the assumption of pred is absurd,
-- but still should not make Agda loop.

module _ (pred : ∀ i → Size< i) where

data D (i : Size) : Set where
  wrap : (j : Size< i) → D i

loop : ∀ i → D i → ⊥
loop i (wrap j) = loop j (wrap (pred j))
-- Loops during injectivity check

d : ∀ i → D i
d i = wrap (pred i)

absurd : ⊥
absurd = FIXME loop ∞ (d ∞)

-- Testcase temporarily mutilated, original error:
-- -Issue1428a.agda:9,20-31
-- -Functions may not return sizes, thus, function type
-- -(i : Size) → Size< i is illegal
-- -when checking that the expression ∀ i → Size< i is a type
-- +Issue1428a.agda:22,10-15
-- +Not in scope:
-- +  FIXME at Issue1428a.agda:22,10-15
-- +when scope checking FIXME


------------------------------------------------------------------------
-- Application of substitutions to terms
------------------------------------------------------------------------

import Level
open import Data.Universe

module README.DependentlyTyped.Term.Substitution
  (Uni₀ : Universe Level.zero Level.zero) where

open import Data.Product as Prod renaming (curry to c; uncurry to uc)
open import deBruijn.Substitution.Data
open import Function as F using (_$_; _ˢ_) renaming (const to k)
import README.DependentlyTyped.Term as Term; open Term Uni₀
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- Code for applying substitutions.
--
-- Note that the _↦_ record ensures that we already have access to
-- operations such as lifting.

module Apply {T : Term-like Level.zero} (T↦Tm : T ↦ Tm) where

  open _↦_ T↦Tm hiding (var)

  mutual

    infixl 8 _/⊢_ _/⊢-lemma_

    -- Applies a substitution to a term. TODO: Generalise and allow
    -- the codomain to be any suitable applicative structure?

    _/⊢_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ⊢ σ → Sub T ρ̂ → Δ ⊢ σ /̂ ρ̂
    var x   /⊢ ρ = trans ⊙ (x /∋ ρ)
    ƛ t     /⊢ ρ = ƛ (t /⊢ ρ ↑)
    t₁ · t₂ /⊢ ρ = [ t₁ · t₂ ]/⊢ ρ

    -- The body of the last case above. (At the time of writing the
    -- termination checker complains if [ t₁ · t₂ ]/⊢ ρ is replaced by
    -- t₁ · t₂ /⊢ ρ in the type signature of ·-/⊢ below.)

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

    abstract

      -- An unfolding lemma.

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

      -- The application operation is well-behaved.

      _/⊢-lemma_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢ σ) (ρ : Sub T ρ̂) →
                   ⟦ t ⟧ /Val ρ ≅-Value ⟦ t /⊢ ρ ⟧
      var x /⊢-lemma ρ = /̂∋-⟦⟧⇨ x ρ
      ƛ t   /⊢-lemma ρ = begin
        [ c ⟦ t ⟧ /Val ρ     ]  ≡⟨ P.refl ⟩
        [ c (⟦ t ⟧ /Val ρ ↑) ]  ≡⟨ curry-cong (t /⊢-lemma (ρ ↑)) ⟩
        [ c ⟦ t /⊢ ρ ↑ ⟧     ]  ∎
      t₁ · t₂ /⊢-lemma ρ = begin
        [ ⟦ t₁ · t₂ ⟧ /Val ρ                ]  ≡⟨ P.refl ⟩
        [ (⟦ t₁ ⟧ /Val ρ) ˢ (⟦ t₂ ⟧ /Val ρ) ]  ≡⟨ ˢ-cong (t₁ /⊢-lemma ρ) (t₂ /⊢-lemma ρ) ⟩
        [ ⟦ t₁ /⊢ ρ ⟧ ˢ ⟦ t₂ /⊢ ρ ⟧         ]  ≡⟨ P.refl ⟩
        [ ⟦ (t₁ /⊢ ρ) · (t₂ /⊢ ρ) ⟧         ]  ≡⟨ ⟦⟧-cong (P.sym $ ·-/⊢ t₁ t₂ ρ) ⟩
        [ ⟦ t₁ · t₂ /⊢ ρ ⟧                  ]  ∎

  app : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → [ Tm ⟶ Tm ] ρ̂
  app ρ = record
    { function    = λ _ t → t /⊢ ρ
    ; corresponds = λ _ t → t /⊢-lemma ρ
    }

  -- Application of substitutions to syntactic types. TODO: Remove?

  infixl 8 _/⊢t_ _/⊢t⋆_

  _/⊢t_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ⊢ σ type → Sub T ρ̂ → Δ ⊢ σ /̂ ρ̂ type
  ⋆       /⊢t ρ = ⋆
  el t    /⊢t ρ = P.subst (λ v → _ ⊢ -, k U-el ˢ v type)
                          (≅-Value-⇒-≡ $ P.sym $ t /⊢-lemma ρ) $
                    el (t /⊢ ρ)
  π σ′ τ′ /⊢t ρ = π (σ′ /⊢t ρ) (τ′ /⊢t ρ ↑)

  _/⊢t⋆_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} →
           Γ ⊢ σ type → Subs T ρ̂ → Δ ⊢ σ /̂ ρ̂ type
  σ′ /⊢t⋆ ε        = σ′
  σ′ /⊢t⋆ (ρs ▻ ρ) = σ′ /⊢t⋆ ρs /⊢t ρ

  -- Congruence lemmas.

  /⊢t-cong :
    ∀ {Γ₁ Δ₁ σ₁} {σ′₁ : Γ₁ ⊢ σ₁ type} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T ρ̂₁}
      {Γ₂ Δ₂ σ₂} {σ′₂ : Γ₂ ⊢ σ₂ type} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T ρ̂₂} →
    σ′₁ ≅-type σ′₂ → ρ₁ ≅-⇨ ρ₂ → σ′₁ /⊢t ρ₁ ≅-type σ′₂ /⊢t ρ₂
  /⊢t-cong P.refl P.refl = P.refl

  /⊢t⋆-cong :
    ∀ {Γ₁ Δ₁ σ₁} {σ′₁ : Γ₁ ⊢ σ₁ type} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T ρ̂₁}
      {Γ₂ Δ₂ σ₂} {σ′₂ : Γ₂ ⊢ σ₂ type} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T ρ̂₂} →
    σ′₁ ≅-type σ′₂ → ρs₁ ≅-⇨⋆ ρs₂ → σ′₁ /⊢t⋆ ρs₁ ≅-type σ′₂ /⊢t⋆ ρs₂
  /⊢t⋆-cong P.refl P.refl = P.refl

substitution₁ : Substitution₁ Tm
substitution₁ = record
  { var      = record { function    = λ _ → var
                      ; corresponds = λ _ _ → P.refl
                      }
  ; app′     = Apply.app
  ; app′-var = λ _ _ _ → P.refl
  }

open Substitution₁ substitution₁ hiding (var)

-- Some unfolding lemmas.

module Unfolding-lemmas
  {T : Term-like Level.zero}
  (T↦Tm : Translation-from T)
  where

  open Translation-from T↦Tm
  open Apply translation hiding (_/⊢_; app)

  abstract

    ƛ-/⊢⋆ : ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ▻ σ ⊢ τ) (ρs : Subs T ρ̂) →
            ƛ t /⊢⋆ ρs ≅-⊢ ƛ (t /⊢⋆ ρs ↑⋆)
    ƛ-/⊢⋆ t ε        = P.refl
    ƛ-/⊢⋆ t (ρs ▻ ρ) = begin
      [ ƛ t /⊢⋆ ρs /⊢ ρ       ]  ≡⟨ /⊢-cong (ƛ-/⊢⋆ t ρs) (P.refl {x = [ ρ ]}) ⟩
      [ ƛ (t /⊢⋆ ρs ↑⋆) /⊢ ρ  ]  ≡⟨ P.refl ⟩
      [ ƛ (t /⊢⋆ (ρs ▻ ρ) ↑⋆) ]  ∎

    ·-/⊢⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} {sp₁ sp₂ σ}
            (t₁ : Γ ⊢ π sp₁ sp₂ , σ) (t₂ : Γ ⊢ fst σ) (ρs : Subs T ρ̂) →
            t₁ · t₂ /⊢⋆ ρs ≅-⊢ (t₁ /⊢⋆ ρs) · (t₂ /⊢⋆ ρs)
    ·-/⊢⋆ t₁ t₂ ε        = P.refl
    ·-/⊢⋆ t₁ t₂ (ρs ▻ ρ) = begin
        [ t₁ · t₂ /⊢⋆ ρs /⊢ ρ                   ]  ≡⟨ /⊢-cong (·-/⊢⋆ t₁ t₂ ρs) P.refl ⟩
        [ (t₁ /⊢⋆ ρs) · (t₂ /⊢⋆ ρs) /⊢ ρ        ]  ≡⟨ ·-/⊢ (t₁ /⊢⋆ ρs) (t₂ /⊢⋆ ρs) ρ ⟩
        [ (t₁ /⊢⋆ (ρs ▻ ρ)) · (t₂ /⊢⋆ (ρs ▻ ρ)) ]  ∎

    -- TODO: Remove the following lemmas?

    ⋆-/⊢t⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs : Subs T ρ̂) →
             ⋆ /⊢t⋆ ρs ≅-type ⋆ {Γ = Δ}
    ⋆-/⊢t⋆ ε        = P.refl
    ⋆-/⊢t⋆ (ρs ▻ ρ) = begin
      [ ⋆ /⊢t⋆ ρs /⊢t ρ ]  ≡⟨ /⊢t-cong (⋆-/⊢t⋆ ρs) (P.refl {x = [ ρ ]}) ⟩
      [ ⋆ /⊢t ρ         ]  ≡⟨ P.refl ⟩
      [ ⋆               ]  ∎

    el-/⊢t : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢ -, k U-⋆) (ρ : Sub T ρ̂) →
             el t /⊢t ρ ≅-type el (t /⊢ ρ)
    el-/⊢t t ρ =
      drop-subst-⊢-type (λ v → -, k U-el ˢ v)
                        (≅-Value-⇒-≡ $ P.sym $ t /⊢-lemma ρ)

    el-/⊢t⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢ -, k U-⋆) (ρs : Subs T ρ̂) →
              el t /⊢t⋆ ρs ≅-type el (t /⊢⋆ ρs)
    el-/⊢t⋆ t ε        = P.refl
    el-/⊢t⋆ t (ρs ▻ ρ) = begin
      [ el t /⊢t⋆ ρs /⊢t ρ  ]  ≡⟨ /⊢t-cong (el-/⊢t⋆ t ρs) (P.refl {x = [ ρ ]}) ⟩
      [ el (t /⊢⋆ ρs) /⊢t ρ ]  ≡⟨ el-/⊢t (t /⊢⋆ ρs) ρ ⟩
      [ el (t /⊢⋆ ρs /⊢ ρ)  ]  ∎

    π-/⊢t⋆ : ∀ {Γ Δ σ τ} {ρ̂ : Γ ⇨̂ Δ}
             (σ′ : Γ ⊢ σ type) (τ′ : Γ ▻ σ ⊢ τ type) (ρs : Subs T ρ̂) →
             π σ′ τ′ /⊢t⋆ ρs ≅-type π (σ′ /⊢t⋆ ρs) (τ′ /⊢t⋆ ρs ↑⋆)
    π-/⊢t⋆ σ′ τ′ ε        = P.refl
    π-/⊢t⋆ σ′ τ′ (ρs ▻ ρ) = begin
      [ π σ′ τ′ /⊢t⋆ ρs /⊢t ρ                        ]  ≡⟨ /⊢t-cong (π-/⊢t⋆ σ′ τ′ ρs) (P.refl {x = [ ρ ]}) ⟩
      [ π (σ′ /⊢t⋆ ρs) (τ′ /⊢t⋆ ρs ↑⋆) /⊢t ρ         ]  ≡⟨ P.refl ⟩
      [ π (σ′ /⊢t⋆ ρs /⊢t ρ) (τ′ /⊢t⋆ ρs ↑⋆ /⊢t ρ ↑) ]  ∎

-- Another lemma.

module Apply-lemma
  {T₁ T₂ : Term-like Level.zero}
  (T₁↦T : Translation-from T₁) (T₂↦T : Translation-from T₂)
  {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T₁ ρ̂) (ρs₂ : Subs T₂ ρ̂) where

  open Translation-from T₁↦T
    using () renaming (_↑⁺⋆_ to _↑⁺⋆₁_; _/⊢⋆_ to _/⊢⋆₁_)
  open Apply (Translation-from.translation T₁↦T)
    using () renaming (_/⊢t⋆_ to _/⊢t⋆₁_)
  open Translation-from T₂↦T
    using () renaming (_↑⁺⋆_ to _↑⁺⋆₂_; _/⊢⋆_ to _/⊢⋆₂_)
  open Apply (Translation-from.translation T₂↦T)
    using () renaming (_/⊢t⋆_ to _/⊢t⋆₂_)

  abstract

    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ :
      (∀ Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
         var x /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢ var x /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺) →
      ∀ Γ⁺ {σ} (t : Γ ++⁺ Γ⁺ ⊢ σ) →
      t /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢ t /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺
    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp Γ⁺ (var x)  = hyp Γ⁺ x
    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp Γ⁺ (ƛ {σ = σ} t) = begin
      [ ƛ t /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺         ]  ≡⟨ Unfolding-lemmas.ƛ-/⊢⋆ T₁↦T t (ρs₁ ↑⁺⋆₁ Γ⁺) ⟩
      [ ƛ (t /⊢⋆₁ ρs₁ ↑⁺⋆₁ (Γ⁺ ▻ σ)) ]  ≡⟨ ƛ-cong (var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp (Γ⁺ ▻ σ) t) ⟩
      [ ƛ (t /⊢⋆₂ ρs₂ ↑⁺⋆₂ (Γ⁺ ▻ σ)) ]  ≡⟨ P.sym $ Unfolding-lemmas.ƛ-/⊢⋆ T₂↦T t (ρs₂ ↑⁺⋆₂ Γ⁺) ⟩
      [ ƛ t /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺         ]  ∎
    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp Γ⁺ (t₁ · t₂) = begin
      [ t₁ · t₂ /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺                      ]  ≡⟨ Unfolding-lemmas.·-/⊢⋆ T₁↦T t₁ t₂ (ρs₁ ↑⁺⋆₁ Γ⁺) ⟩
      [ (t₁ /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺) · (t₂ /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺) ]  ≡⟨ ·-cong (var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp Γ⁺ t₁)
                                                                   (var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ hyp Γ⁺ t₂) ⟩
      [ (t₁ /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺) · (t₂ /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺) ]  ≡⟨ P.sym $ Unfolding-lemmas.·-/⊢⋆ T₂↦T t₁ t₂ (ρs₂ ↑⁺⋆₂ Γ⁺) ⟩
      [ t₁ · t₂ /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺                      ]  ∎

-- Term substitutions, along with a number of lemmas.

substitution₂ : Substitution₂ Tm
substitution₂ = record
  { substitution₁          = substitution₁
  ; var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆′ = Apply-lemma.var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆
  }

open Apply (Translation-from.translation no-translation) public
  using (·-/⊢; _/⊢t_; /⊢t-cong; _/⊢t⋆_; /⊢t⋆-cong)
open Unfolding-lemmas no-translation public
open Substitution₂ substitution₂ public hiding (var; substitution₁)


module PreludeString where
import RTP -- magic module

import PreludeList
open   PreludeList using (List)

open import AlonzoPrelude

infixr 50 _++_

private
    primitive
      primStringAppend	 : String -> String -> String
      -- primStringReverse  : String -> String
      primStringToList	 : String -> List Char
      primStringFromList : List Char -> String

_++_     = primStringAppend
reverseString = RTP.primStringReverse

toList : String -> List Char
toList = primStringToList

fromList : List Char -> String
fromList = primStringFromList

-- toList   = RTP.primStringToList
-- fromList = RTP.primStringFromList


module Issue353 where

data Func : Set₁ where
  K : (A : Set) → Func

-- Doesn't work.
module M where

  const : ∀ {A B : Set₁} → A → B → A
  const x = λ _ → x

  ⟦_⟧ : Func → Set → Set
  ⟦ K A ⟧ X = const A X

  data μ (F : Func) : Set where
    ⟨_⟩ : ⟦ F ⟧ (μ F) → μ F

  -- Error: μ is not strictly positive, because it occurs in the second
  -- argument to ⟦_⟧ in the type of the constructor ⟨_⟩ in the
  -- definition of μ.


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Susp.Base where

open import Cubical.Core.Glue

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

open import Cubical.Data.Bool

open import Cubical.HITs.S1
open import Cubical.HITs.S2
open import Cubical.HITs.S3

data Susp {ℓ} (A : Type ℓ) : Type ℓ where
  north : Susp A
  south : Susp A
  merid : (a : A) → north ≡ south

SuspBool : Type₀
SuspBool = Susp Bool

SuspBool→S¹ : SuspBool → S¹
SuspBool→S¹ north = base
SuspBool→S¹ south = base
SuspBool→S¹ (merid false i) = loop i
SuspBool→S¹ (merid true i)  = base

S¹→SuspBool : S¹ → SuspBool
S¹→SuspBool base     = north
S¹→SuspBool (loop i) = (merid false ∙ (sym (merid true))) i

SuspBool→S¹→SuspBool : (x : SuspBool) → Path _ (S¹→SuspBool (SuspBool→S¹ x)) x
SuspBool→S¹→SuspBool north = refl
SuspBool→S¹→SuspBool south = merid true
SuspBool→S¹→SuspBool (merid false i) = λ j → hcomp (λ k → (λ { (j = i1) → merid false i
                                                             ; (i = i0) → north
                                                             ; (i = i1) → merid true (j ∨ ~ k)}))
                                                   (merid false i)
SuspBool→S¹→SuspBool (merid true i)  = λ j → merid true (i ∧ j)

S¹→SuspBool→S¹ : (x : S¹) → SuspBool→S¹ (S¹→SuspBool x) ≡ x
S¹→SuspBool→S¹ base     = refl
S¹→SuspBool→S¹ (loop i) = λ j →
  hfill (λ k → λ { (i = i0) → base
                 ; (i = i1) → base })
        (inS (loop i)) (~ j)

S¹≃SuspBool : S¹ ≃ SuspBool
S¹≃SuspBool = isoToEquiv (iso S¹→SuspBool SuspBool→S¹ SuspBool→S¹→SuspBool S¹→SuspBool→S¹)

S¹≡SuspBool : S¹ ≡ SuspBool
S¹≡SuspBool = isoToPath (iso S¹→SuspBool SuspBool→S¹ SuspBool→S¹→SuspBool S¹→SuspBool→S¹)

-- Now the sphere

SuspS¹ : Type₀
SuspS¹ = Susp S¹

SuspS¹→S² : SuspS¹ → S²
SuspS¹→S² north = base
SuspS¹→S² south = base
SuspS¹→S² (merid base i) = base
SuspS¹→S² (merid (loop j) i) = surf i j

meridian-contraction : I → I → I → SuspS¹
meridian-contraction i j l = hfill (λ k → λ { (i = i0) → north
                                            ; (i = i1) → merid base (~ k)
                                            ; (j = i0) → merid base (~ k ∧ i)
                                            ; (j = i1) → merid base (~ k ∧ i) })
                                   (inS (merid (loop j) i)) l

S²→SuspS¹ : S² → SuspS¹
S²→SuspS¹ base = north
S²→SuspS¹ (surf i j) = meridian-contraction i j i1

S²→SuspS¹→S² : ∀ x → SuspS¹→S² (S²→SuspS¹ x) ≡ x
S²→SuspS¹→S² base k = base
S²→SuspS¹→S² (surf i j) k = SuspS¹→S² (meridian-contraction i j (~ k))

SuspS¹→S²→SuspS¹ : ∀ x → S²→SuspS¹ (SuspS¹→S² x) ≡ x
SuspS¹→S²→SuspS¹ north k = north
SuspS¹→S²→SuspS¹ south k = merid base k
SuspS¹→S²→SuspS¹ (merid base j) k = merid base (k ∧ j)
SuspS¹→S²→SuspS¹ (merid (loop j) i) k = meridian-contraction i j (~ k)

S²≡SuspS¹ : S² ≡ SuspS¹
S²≡SuspS¹ = isoToPath (iso S²→SuspS¹ SuspS¹→S² SuspS¹→S²→SuspS¹ S²→SuspS¹→S²)

-- And the 3-sphere

SuspS² : Type₀
SuspS² = Susp S²

SuspS²→S³ : SuspS² → S³
SuspS²→S³ north = base
SuspS²→S³ south = base
SuspS²→S³ (merid base i) = base
SuspS²→S³ (merid (surf j k) i) = surf i j k

meridian-contraction-2 : I → I → I → I → SuspS²
meridian-contraction-2 i j k l = hfill (λ m → λ { (i = i0) → north
                                                ; (i = i1) → merid base (~ m)
                                                ; (j = i0) → merid base (~ m ∧ i)
                                                ; (j = i1) → merid base (~ m ∧ i)
                                                ; (k = i0) → merid base (~ m ∧ i)
                                                ; (k = i1) → merid base (~ m ∧ i) })
                                       (inS (merid (surf j k) i)) l

S³→SuspS² : S³ → SuspS²
S³→SuspS² base = north
S³→SuspS² (surf i j k) = meridian-contraction-2 i j k i1

S³→SuspS²→S³ : ∀ x → SuspS²→S³ (S³→SuspS² x) ≡ x
S³→SuspS²→S³ base l = base
S³→SuspS²→S³ (surf i j k) l = SuspS²→S³ (meridian-contraction-2 i j k (~ l))

SuspS²→S³→SuspS² : ∀ x → S³→SuspS² (SuspS²→S³ x) ≡ x
SuspS²→S³→SuspS² north l = north
SuspS²→S³→SuspS² south l = merid base l
SuspS²→S³→SuspS² (merid base j) l = merid base (l ∧ j)
SuspS²→S³→SuspS² (merid (surf j k) i) l = meridian-contraction-2 i j k (~ l)

S³≡SuspS² : S³ ≡ SuspS²
S³≡SuspS² = isoToPath (iso S³→SuspS² SuspS²→S³ SuspS²→S³→SuspS² S³→SuspS²→S³)


{-# OPTIONS --rewriting #-}
module DualContractive where

open import Data.Fin
open import Data.Maybe
open import Data.Nat hiding (_≤_ ; compare) renaming (_+_ to _+ℕ_)
open import Data.Nat.Properties
open import Data.Sum hiding (map)
open import Data.Product

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality hiding (Extensionality)

open import Function

open import Types.Direction

open import Auxiliary.Extensionality

open import Max hiding (n)

----------------------------------------------------------------------
-- see also https://github.com/zmthy/recursive-types/tree/ftfjp16
-- for encoding of recursive types

variable
  m n : ℕ
  i i' j : Fin n

----------------------------------------------------------------------
-- lemmas for rewriting

n+1=suc-n : n +ℕ 1 ≡ suc n
n+1=suc-n {zero} = refl
n+1=suc-n {suc n} = cong suc (n+1=suc-n {n})

n+0=n : n +ℕ 0 ≡ n
n+0=n {zero} = refl
n+0=n {suc n} = cong suc (n+0=n {n})

n+sucm=sucn+m : ∀ n m → n +ℕ suc m ≡ suc (n +ℕ m)
n+sucm=sucn+m zero m = refl
n+sucm=sucn+m (suc n) m = cong suc (n+sucm=sucn+m n m)

{-# REWRITE n+sucm=sucn+m #-}

open import Agda.Builtin.Equality.Rewrite

----------------------------------------------------------------------
-- auxiliaries for automatic rewriting

{- REWRITE n+1=suc-n #-}

{-# REWRITE n+0=n #-}

-- inject+0-x=x : {x : Fin m} → inject+ 0 x ≡ x
-- inject+0-x=x {x = zero} = refl
-- inject+0-x=x {x = suc x} = cong suc inject+0-x=x

{- REWRITE inject+0-x=x #-}

----------------------------------------------------------------------
-- types and session types

data TType (n : ℕ) : Set
data SType (n : ℕ) : Set

data TType n where
  TInt : TType n
  TChn : (S : SType n) → TType n

data SType n where
  xmt : (d : Dir) (T : TType n) (S : SType n) → SType n
  end : SType n
  rec : (S : SType (suc n)) → SType n
  var : (x : Fin n) → SType n

variable
  t T : TType n
  s s₀ S S₀ : SType n

----------------------------------------------------------------------
module Examples-Types where
  sint : SType n → SType n
  sint = xmt SND TInt

  -- μ X. !Int. X
  s1 : SType 0
  s1 = rec (sint (var zero))

  -- μ X. μ Y. !Int. Y
  s2 : SType 0
  s2 = rec (rec (sint (var zero)))

  -- μ X. μ Y. !Int. X
  s2a : SType 0
  s2a = rec (rec (sint (var (suc zero))))

  -- μ X. !Int. μ Y. X
  s3 : SType 0
  s3 = rec (sint (rec (var (suc zero))))

module Alternative-Substitution where

  -- analogous to https://plfa.github.io/DeBruijn/

  -- extending a map by an identity segment

  extV : (Fin m → Fin n) → (Fin (suc m) → Fin (suc n))
  extV ρ zero = zero
  extV ρ (suc i) = suc (ρ i)

  -- renaming / can be used for weakening one binding as @rename suc@

  renameT : (Fin m → Fin n) → TType m → TType n
  renameS : (Fin m → Fin n) → SType m → SType n

  renameT ρ TInt = TInt
  renameT ρ (TChn S) = TChn (renameS ρ S)

  renameS ρ (xmt d T S) = xmt d (renameT ρ T) (renameS ρ S)
  renameS ρ end = end
  renameS ρ (rec S) = rec (renameS (extV ρ) S)
  renameS ρ (var x) = var (ρ x)

  -- extending a map from variables to terms

  extS : (Fin m → SType n) → (Fin (suc m) → SType (suc n))
  extS σ zero = var zero
  extS σ (suc i) = renameS suc (σ i)

  -- simultaneous substitution

  substT : (Fin m → SType n) → TType m → TType n
  substS : (Fin m → SType n) → SType m → SType n

  substT σ TInt = TInt
  substT σ (TChn S) = TChn (substS σ S)

  substS σ (xmt d T S) = xmt d (substT σ T) (substS σ S)
  substS σ end = end
  substS σ (rec S) = rec (substS (extS σ) S)
  substS σ (var x) = σ x

  -- single substitution

  mk-σ : SType n → Fin (suc n) → SType n
  mk-σ S' zero = S'
  mk-σ S' (suc x) = var x

  substT1 : SType n → TType (suc n) → TType n
  substT1 S' T = substT (mk-σ S') T

  substS1 : SType n → SType (suc n) → SType n
  substS1 S' S = substS (mk-σ S') S

----------------------------------------------------------------------
-- weakening

increase : ∀ m → (x : Fin n) → Fin (n +ℕ m)
increase zero x = x
increase (suc m) x = suc (increase m x)

increaseS : ∀ m → SType n → SType (n +ℕ m)
increaseT : ∀ m → TType n → TType (n +ℕ m)

increaseS m (xmt d t s) = xmt d (increaseT m t) (increaseS m s)
increaseS m (rec s) = rec (increaseS m s)
increaseS m (var x) = var (inject+ m x) -- should say increase here
increaseS m end = end

increaseT m TInt = TInt
increaseT m (TChn s) = TChn (increaseS m s)

-- weaken m is used to push a (closed) term under m new binders
weakenS : ∀ m → SType n → SType (n +ℕ m)
weakenT : ∀ m → TType n → TType (n +ℕ m)

weakenS m (xmt d t s) = xmt d (weakenT m t) (weakenS m s)
weakenS m (rec s) = rec (weakenS m s)
weakenS m (var x) = var (inject+ m x)
weakenS m end = end

weakenT m TInt = TInt
weakenT m (TChn s) = TChn (weakenS m s)

weaken1S : SType n → SType (suc n)
weaken1S s = weakenS 1 s

-- this one behaves correctly
weaken'S : ∀ m → Fin (suc n) → SType n → SType (n +ℕ m)
weaken'T : ∀ m → Fin (suc n) → TType n → TType (n +ℕ m)

weaken'S m i (xmt d T S) = xmt d (weaken'T m i T) (weaken'S m i S)
weaken'S m i end = end
weaken'S m i (rec S) = rec (weaken'S m (suc i) S)
weaken'S {suc n} m zero (var x) = var (increase m x)
weaken'S {suc n} m (suc i) (var x)
  with compare i x
weaken'S {suc n} m (suc .(inject least)) (var x) | less .x least = var (increase m x)
weaken'S {suc n} m (suc i) (var .i) | equal .i = var (inject+ m i)
weaken'S {suc n} m (suc i) (var .(inject least)) | greater .i least = var (inject+ m (inject least))

weaken'T m i TInt = TInt
weaken'T m i (TChn S) = TChn (weaken'S m i S)

weaken'S0 : ∀ m → SType n → SType (n +ℕ m)
weaken'S0 m S = weaken'S m (fromℕ _) S

----------------------------------------------------------------------
-- examples

module Examples-Weakening where

  sv0 sv1 : SType 1
  sv0 = rec (var zero)
  sv1 = rec (var (suc zero))

  sv0-w : SType 2
  sv0-w = weaken'S 1 zero sv0

  step0 : weaken'S{2} 1 zero (var zero) ≡ var (suc zero)
        × weaken'S{2} 1 zero (var (suc zero)) ≡ var (suc (suc zero))
  step0 = refl , refl

  step1 : weaken'S{2} 1 (suc zero) (var zero) ≡ var zero
        × weaken'S{2} 1 (suc zero) (var (suc zero)) ≡ var (suc (suc zero))
  step1 = refl , refl

  stepr1 : weaken'S 1 zero sv0 ≡ rec (var zero)
         × weaken'S 1 zero sv1 ≡ rec (var (suc (suc zero)))
  stepr1 = refl , refl

  stepr2 : weaken'S{3} 1 zero (rec (rec (var zero))) ≡ rec (rec (var zero))
         × weaken'S{3} 1 zero (rec (rec (var (suc zero)))) ≡ rec (rec (var (suc zero)))
         × weaken'S{3} 1 zero (rec (rec (var (suc (suc zero))))) ≡ rec (rec (var (suc (suc (suc zero)))))
  stepr2 = refl , refl , refl

  sx1 : SType 0
  sx1 = rec (xmt SND TInt (var zero))

  sx1-w : SType 1
  sx1-w = rec (xmt SND TInt (var zero))

  sx1=sx1-w : sx1-w ≡ weaken'S 1 zero sx1
  sx1=sx1-w = refl

  sx2 : SType 1
  sx2 = xmt SND TInt (var zero)

  sx2-w1 : SType 2
  sx2-w1 = xmt SND TInt (var (suc zero))

  sx2-w0 : SType 2
  sx2-w0 = xmt SND TInt (var zero)

  sx2=w : sx2-w1 ≡ weaken'S 1 zero sx2
        × sx2-w0 ≡ weaken'S 1 (suc zero) sx2
  sx2=w = refl , refl

  open Alternative-Substitution

  step0-r : renameS suc sv0 ≡ rec (var zero)
          × renameS suc sv1 ≡ rec (var (suc (suc zero)))
  step0-r = refl , refl

  step1-r : renameS{1} suc (rec (rec (var zero))) ≡ (rec (rec (var zero)))
          × renameS{1} suc (rec (rec (var (suc zero)))) ≡ (rec (rec (var (suc zero))))
          × renameS{1} suc (rec (rec (var (suc (suc zero))))) ≡ (rec (rec (var (suc (suc (suc zero))))))
  step1-r = refl , refl , refl

----------------------------------------------------------------------
-- contractivity

mutual
  data ContractiveT {n} : TType n → Set where
    con-int : ContractiveT TInt
    con-chn : Contractive zero S → ContractiveT (TChn S)

  data Contractive (i : Fin (suc n)) : SType n → Set where
    con-xmt : ContractiveT t → Contractive zero s → Contractive i (xmt d t s)
    con-end : Contractive i end
    con-rec : Contractive (suc i) S → Contractive i (rec S)
    con-var : i ≤ inject₁ j → Contractive i (var j)

----------------------------------------------------------------------
module Examples-Contractivity where
  open Examples-Types

  cn1 : ¬ Contractive {2} (suc zero) (var zero)
  cn1 (con-var ())

  cp1 : Contractive {2} zero (var (suc zero))
  cp1 = con-var z≤n

  cp0 : Contractive {2} zero (var zero)
  cp0 = con-var z≤n

  cs1 : Contractive zero s1
  cs1 = con-rec (con-xmt con-int (con-var z≤n))

  cs2 : Contractive zero s2
  cs2 = con-rec (con-rec (con-xmt con-int (con-var z≤n)))

  cs2a : Contractive zero s2a
  cs2a = con-rec (con-rec (con-xmt con-int (con-var z≤n)))

  sp2 : SType 0
  sp2 = s3

  cp2 : Contractive zero sp2
  cp2 = con-rec (con-xmt con-int (con-rec (con-var (s≤s z≤n))))

  sn2 : SType 0
  sn2 = (rec (xmt SND TInt (rec (var zero))))

  cn2 : ¬ Contractive zero sn2
  cn2 (con-rec (con-xmt con-int (con-rec (con-var ()))))

module Alternative-Unfolding where
  open Alternative-Substitution

  -- one top-level unfolding if possible

  unfold₁ : SType n → SType n
  unfold₁ (rec S) = substS1 (rec S) S
  unfold₁ S@(xmt d T x) = S
  unfold₁ S@end = S
  unfold₁ S@(var x) = S

  -- unfold all the way

  unfold : (S : SType n) (σ : SType n → SType m) → SType m
  unfold S@(xmt d T S') σ = σ S
  unfold end σ = end
  unfold (rec S) σ = unfold S (σ ∘ substS1 (rec S))
  unfold S@(var x) σ = σ S

  unfold₀ : SType n → SType n
  unfold₀ S = unfold S id

----------------------------------------------------------------------
-- substitution

ssubst : SType (suc n) → Fin (suc n) → SType 0 → SType n
tsubst : TType (suc n) → Fin (suc n) → SType 0 → TType n

ssubst (xmt d t s) i s0 = xmt d (tsubst t i s0) (ssubst s i s0)
ssubst (rec s) i s0 = rec (ssubst s (suc i) s0)
ssubst {n} (var zero) zero s0 = increaseS n s0
ssubst {suc n} (var zero) (suc i) s0 = var zero
ssubst (var (suc x)) zero s0 = var x
ssubst {suc n} (var (suc x)) (suc i) s0 = increaseS 1 (ssubst (var x) i s0)
ssubst end i s0 = end

tsubst TInt i s₀ = TInt
tsubst (TChn s) i s₀ = TChn (ssubst s i s₀)

----------------------------------------------------------------------
-- unfolding to first non-rec constructor

unfold : (s : SType n) (c : Contractive i s) (σ : SType n → SType 0) → SType 0
unfold (xmt d t s) (con-xmt ct c) σ = σ (xmt d t s)
unfold end con-end σ = end
unfold (rec s) (con-rec c) σ = unfold s c (σ ∘ λ sn' → ssubst sn' zero (σ (rec s)))
unfold {i = zero} (var x) (con-var z≤n) σ = σ (var x)
unfold {i = suc i} (var zero) (con-var ()) σ
unfold {i = suc i} (var (suc x)) (con-var (s≤s x₁)) σ = unfold (var x) (con-var x₁) (σ ∘ increaseS 1)

unfold₀ : (S : SType 0) (c : Contractive zero S) → SType 0
unfold₀ S c = unfold S c id

----------------------------------------------------------------------
module Examples-Unfold where
  open Examples-Types

  c1 : Contractive zero s1
  c1 = con-rec (con-xmt con-int (con-var z≤n))
  s11 : SType 0
  s11 = xmt SND TInt s1

  u-s1=s11 : unfold s1 c1 id ≡ s11
  u-s1=s11 = refl

  c2 : Contractive zero s2
  c2 = con-rec (con-rec (con-xmt con-int (con-var z≤n)))
  u-s2=s11 : unfold s2 c2 id ≡ s11
  u-s2=s11 = cong (xmt SND TInt) (cong rec (cong (xmt SND TInt) refl))
----------------------------------------------------------------------
-- contractivity is decidable

infer-contractiveT : (t : TType n) → Dec (ContractiveT t)
infer-contractive : (s : SType n) (i : Fin (suc n)) → Dec (Contractive i s)

infer-contractiveT TInt = yes con-int
infer-contractiveT (TChn s)
  with infer-contractive s zero
infer-contractiveT (TChn s) | yes p = yes (con-chn p)
infer-contractiveT (TChn s) | no ¬p = no (λ { (con-chn cs) → ¬p cs })

infer-contractive (xmt d t s) i
  with infer-contractiveT t | infer-contractive s zero
infer-contractive (xmt d t s) i | yes p | yes p₁ = yes (con-xmt p p₁)
infer-contractive (xmt d t s) i | yes p | no ¬p = no (λ { (con-xmt ct cs) → ¬p cs })
infer-contractive (xmt d t s) i | no ¬p | yes p = no (λ { (con-xmt ct cs) → ¬p ct })
infer-contractive (xmt d t s) i | no ¬p | no ¬p₁ = no (λ { (con-xmt ct cs) → ¬p₁ cs})
infer-contractive end i = yes con-end
infer-contractive (rec s) i
  with infer-contractive s (suc i)
infer-contractive (rec s) i | yes p = yes (con-rec p)
infer-contractive (rec s) i | no ¬p = no (λ { (con-rec c) → ¬p c })
infer-contractive (var x) zero = yes (con-var z≤n)
infer-contractive (var zero) (suc i) = no (λ { (con-var ()) })
infer-contractive (var (suc x)) (suc i)
  with infer-contractive (var x) i
infer-contractive (var (suc x)) (suc i) | yes (con-var x₁) = yes (con-var (s≤s x₁))
infer-contractive (var (suc x)) (suc i) | no ¬p = no (λ { (con-var (s≤s y)) → ¬p (con-var y) })

----------------------------------------------------------------------
module Examples-Inference where
  open Examples-Contractivity

  infer-p2 : infer-contractive sp2 zero ≡ yes cp2
  infer-p2 = refl

  infer-n2 : infer-contractive sn2 zero ≡ no cn2
  infer-n2 = cong no (ext (λ { (con-rec (con-xmt con-int (con-rec (con-var ())))) }))

----------------------------------------------------------------------
-- RT: if a type is contractive at level i, then it is also contractive at any smaller level

c-weakenS : {S : SType n} (i' : Fin′ i) → Contractive i S → Contractive (inject i') S
c-weakenS i' (con-rec cis) = con-rec (c-weakenS (suc i') cis)
c-weakenS i' (con-xmt x cis) = con-xmt x cis
c-weakenS i' con-end = con-end
c-weakenS {i = suc i} i' (con-var {zero} ())
c-weakenS {i = suc i} zero (con-var {suc n} (s≤s x)) = con-var z≤n
c-weakenS {i = suc i} (suc i') (con-var {suc n} (s≤s x)) = con-var (s≤s (trans-< x))

c-weakenS₁ : {S : SType n} → Contractive (suc i) S → Contractive (inject₁ i) S
c-weakenS₁ (con-rec cis) = con-rec (c-weakenS₁ cis)
c-weakenS₁ (con-xmt x cis) = con-xmt x cis
c-weakenS₁ con-end = con-end
c-weakenS₁ {zero} {()} (con-var x)
c-weakenS₁ {suc n} {zero} (con-var x) = con-var z≤n
c-weakenS₁ {suc n} {suc i} (con-var x) = con-var (pred-≤ x)

c-weakenS! : {S : SType n} → Contractive i S → Contractive zero S
c-weakenS! {i = zero} (con-rec cis) = con-rec cis
c-weakenS! {i = suc i} (con-rec cis) = con-rec (c-weakenS (suc zero) cis)
c-weakenS! {n} {i} (con-xmt x cis) = con-xmt x cis
c-weakenS! {n} {i} con-end = con-end
c-weakenS! {n} {i} (con-var x) = con-var z≤n

ct-weaken+ : {T : TType n} → ContractiveT T → ContractiveT (weaken'T 1 zero T)
c-weaken+ : {S : SType n} → Contractive i S → Contractive (suc i) (weaken'S 1 zero S)

ct-weaken+ con-int = con-int
ct-weaken+ (con-chn x) = con-chn (c-weakenS! (c-weaken+ x))

c-weaken+ (con-xmt x cis) = con-xmt (ct-weaken+ x) (c-weakenS! (c-weaken+ cis))
c-weaken+ con-end = con-end
c-weaken+ (con-rec cis) = con-rec {!!} -- gives a problem: (c-weaken+ {!cis!})
c-weaken+ {suc n} {i} {var j} (con-var i≤j) = con-var (s≤s i≤j)

module Alternative-Multiple-Substitution-Preserves where

  open Alternative-Substitution

  subst-contr-T :
    {T : TType m}
    (σ : Fin m → SType n)
    (γ : (j : Fin m) → Contractive i (σ j))
    (ct : ContractiveT T)
    → ContractiveT (substT σ T)

  subst-contr-S : ∀ {k} →
    (σ : Fin m → SType n)
    (γ : (j : Fin m) → Contractive k (σ j))
    (c : Contractive zero S)
    → Contractive k (substS σ S)

  subst-contr-T σ γ con-int = con-int
  subst-contr-T σ γ (con-chn cs) = con-chn (subst-contr-S σ (c-weakenS! ∘ γ) cs)

  subst-contr-S σ γ (con-xmt ct cs) =
    con-xmt (subst-contr-T σ γ ct) (subst-contr-S σ (c-weakenS! ∘ γ) cs)
  subst-contr-S σ γ con-end = con-end
  subst-contr-S σ γ (con-rec cs) = con-rec (subst-contr-S (extS σ) {!extS!} (c-weakenS₁ cs))
  subst-contr-S σ γ (con-var{j} x) = γ j

module Alternative-Substitution-Preserves where

  open Alternative-Substitution

  subst-contr-T :
    {S' : SType n} (c' : Contractive i S')
    {T : TType (suc n)} (c : ContractiveT T)
      → ContractiveT (substT1 S' T)
  subst-contr-S :
    {S' : SType n} (c' : Contractive i S')
    {S : SType (suc n)} (c : Contractive (inject₁ i) S)
      → Contractive i (substS1 S' S)

  subst-contr-T c' con-int = con-int
  subst-contr-T c' (con-chn x) = con-chn (subst-contr-S (c-weakenS! c') x)

  subst-contr-S c' (con-xmt ct cs) =
    con-xmt (subst-contr-T c' ct) (subst-contr-S (c-weakenS! c') cs)
  subst-contr-S c' con-end = con-end
  subst-contr-S c' (con-rec c) = con-rec {!!} -- (subst-contr-S {!!} {!c!})
  subst-contr-S c' (con-var x) = {!!}

module Alternative-SingleSubstitution where
  ----------------------------------------------------------------------
  -- single substitution of j ↦ Sj

  subst1T : (T : TType (suc n)) (j : Fin (suc n)) (Sj : SType n) → TType n
  subst1S : (S : SType (suc n)) (j : Fin (suc n)) (Sj : SType n) → SType n

  subst1T TInt j Sj = TInt
  subst1T (TChn S) j Sj = TChn (subst1S S j Sj)

  subst1S (xmt d T S) j Sj = xmt d (subst1T T j Sj) (subst1S S j Sj)
  subst1S end j Sj = end
  subst1S (rec S) j Sj = rec (subst1S S (suc j) (weaken'S 1 zero Sj))
  subst1S (var x) j Sj
    with compare x j
  subst1S (var .(inject least)) j Sj | less .j least = var (inject! least)
  subst1S (var x) .x Sj | equal .x = Sj
  subst1S (var (suc x)) .(inject least) Sj | greater .(suc x) least = var x

  {- the termination checker doesnt like this:
  subst1S (var zero) zero Sj = Sj
  subst1S {suc n} (var zero) (suc j) Sj = var zero
  subst1S (var (suc x)) zero Sj = var x
  subst1S (var (suc x)) (suc j) Sj = subst1S (var (inject₁ x)) (inject₁ j) Sj
  -}

  unfold1S : (S : SType 0) → SType 0
  unfold1S (xmt d T S) = xmt d T S
  unfold1S end = end
  unfold1S (rec S) = subst1S S zero (rec S)

  unfoldSS : (S : SType n) → SType n
  unfoldSS (xmt d T S) = xmt d T S
  unfoldSS end = end
  unfoldSS (rec S)
    with unfoldSS S
  ... | ih = subst1S ih zero (rec ih)
  unfoldSS (var x) = var x

----------------------------------------------------------------------
-- max index substitution

subst-maxT : (Sm : SType n) (T : TType (suc n)) → TType n
subst-maxS : (Sm : SType n) (S : SType (suc n)) → SType n

subst-maxT Sm TInt = TInt
subst-maxT Sm (TChn S) = TChn (subst-maxS Sm S)

subst-maxS Sm (xmt d T S) = xmt d (subst-maxT Sm T) (subst-maxS Sm S)
subst-maxS Sm end = end
subst-maxS Sm (rec S) = rec (subst-maxS (weaken'S 1 zero Sm) S)
subst-maxS Sm (var x)
  with max? x
subst-maxS Sm (var x) | yes p = Sm
subst-maxS Sm (var x) | no ¬p = var (reduce ¬p)

unfoldmS : (S : SType n) → SType n
unfoldmS (xmt d T S) = xmt d T S
unfoldmS end = end
unfoldmS (rec S) = subst-maxS (rec S) S
unfoldmS {suc n} (var x) = var x

----------------------------------------------------------------------
-- max substitution preserves contractivity

subst-contr-mT :
  {T : TType (suc n)} (c : ContractiveT T)
  {S' : SType n} (c' : Contractive i S')
    → ContractiveT (subst-maxT S' T)

subst-contr-mS :
  -- {i : Fin (suc (suc n))}
  {S : SType (suc n)} (c : Contractive (inject₁ i) S)
  {S' : SType n} (c' : Contractive i S')
    → Contractive i (subst-maxS S' S)

subst-contr-mT con-int csm = con-int
subst-contr-mT (con-chn x) csm = con-chn (c-weakenS! (subst-contr-mS x (c-weakenS! csm)))

subst-contr-mS (con-xmt x cs) csm = con-xmt (subst-contr-mT x csm) (subst-contr-mS cs (c-weakenS! csm))
subst-contr-mS con-end csm = con-end
subst-contr-mS (con-rec cs) csm = con-rec (subst-contr-mS cs (c-weaken+ csm))
subst-contr-mS {S = var j} (con-var x) csm
  with max? j
subst-contr-mS {i = _} {var j} (con-var x) csm | yes p = csm
subst-contr-mS {i = _} {var j} (con-var x) csm | no ¬p = con-var (lemma-reduce x ¬p)

-- one step unfolding preserves contractivity

unfold-contr : Contractive i S → Contractive i (unfoldmS S)
unfold-contr (con-xmt x c) = con-xmt x c
unfold-contr con-end = con-end
unfold-contr (con-rec c) = subst-contr-mS (c-weakenS₁ c) (con-rec c)
unfold-contr (con-var x) = {!!}

-- multiple unfolding
-- terminates even for non-contractive types because it delays the substitution

unfold! : (S : SType n) (σ : SType n → SType 0) → SType 0
unfold! (xmt d T S) σ = σ (xmt d T S)
unfold! end σ = end
unfold! (rec S) σ = unfold! S (σ ∘ subst-maxS (rec S))
unfold! (var x) σ = σ (var x)

-- unclear how this could be completed
-- unfold!-contr : Contractive i S → Contractive i (unfold! S id)
-- unfold!-contr (con-xmt x cs) = con-xmt x cs
-- unfold!-contr con-end = con-end
-- unfold!-contr (con-rec cs) = {!!}

-- multiple unfolding preserves contractivity

TCType : (n : ℕ) → Set
TCType n = Σ (TType n) ContractiveT

SCType : (n : ℕ) → Fin (suc n) → Set
SCType n i = Σ (SType n) (Contractive i)

unfold!! : (SC : SCType n i) → (SCType n i → SCType 0 zero) → SCType 0 zero
unfold!! SC@(xmt d T S , con-xmt x cs) σ = σ SC
unfold!! (end , con-end) σ = end , con-end
unfold!! (rec S , con-rec cs) σ =
  unfold!! (S , cs) (σ ∘ λ{ (S' , c') → (subst-maxS (rec S) S') , (subst-contr-mS (c-weakenS₁ c') (con-rec cs)) })
unfold!! SC@(var x , con-var x₁) σ = σ SC

{-# TERMINATING #-}
unfold!!! : ∀ {m n : ℕ} → SCType (n +ℕ m) zero → (SCType (n +ℕ m) zero → SCType m zero) → SCType m zero
unfold!!! SC@(xmt d T S , con-xmt x cs) σ = σ SC
unfold!!! (end , con-end) σ = end , con-end
unfold!!! (rec S , con-rec cs) σ =
  unfold!!! (S , c-weakenS₁ cs) (σ ∘ λ SC → (subst-maxS (rec S) (proj₁ SC)) , (subst-contr-mS (proj₂ SC) (con-rec cs)))
unfold!!! SC@(var x , con-var x₁) σ = σ SC

----------------------------------------------------------------------
-- equivalence requires multiple unfolding

variable
  T₁ T₂ : TCType n
  S₁ S₂ : SCType n i

data EquivT (R : SCType n zero → SCType n zero → Set) : TCType n → TCType n → Set where
  eq-int : EquivT R (TInt , con-int) (TInt , con-int)
  eq-chn : R S₁ S₂ →
    EquivT R (TChn (proj₁ S₁) , con-chn (proj₂ S₁))
             (TChn (proj₁ S₂) , con-chn (proj₂ S₂))

data EquivS (R : SCType n zero → SCType n zero → Set) :
     (S₁ S₂ : SCType n zero) → Set where
  eq-end :
    EquivS R (end , con-end) (end , con-end)
  eq-xmt : (d : Dir) →
    EquivT R T₁ T₂ →
    R S₁ S₂ →
    EquivS R (xmt d (proj₁ T₁) (proj₁ S₁) , con-xmt (proj₂ T₁) (proj₂ S₁))
             (xmt d (proj₁ T₂) (proj₁ S₂) , con-xmt (proj₂ T₂) (proj₂ S₂))
  eq-rec-l :
    let S = proj₁ S₁ in
    let cs = proj₂ S₁ in
    EquivS R (subst-maxS (rec S) S , subst-contr-mS (c-weakenS₁ cs) (con-rec cs)) S₂ →
    EquivS R (rec S , con-rec cs) S₂
  eq-rec-r :
    let S = proj₁ S₂ in
    let cs = proj₂ S₂ in
    EquivS R S₁ (subst-maxS (rec S) S , subst-contr-mS (c-weakenS₁ cs) (con-rec cs)) →
    EquivS R S₁ (rec S , con-rec cs)

record Equiv (S₁ S₂ : SCType 0 zero) : Set where
  coinductive
  field force : EquivS Equiv (unfold!! S₁ id) (unfold!! S₂ id)

record Equiv' (S₁ S₂ : SCType n zero) : Set where
  coinductive
  field force : EquivS Equiv' (unfold!!!{n = 0} S₁ id) (unfold!!!{n = 0} S₂ id)

{-# TERMINATING #-}
equivt-refl : ∀ T → EquivT Equiv T T
equivs-refl : ∀ S → EquivS Equiv S S
equiv-refl : ∀ S → Equiv S S

equivt-refl (TInt , con-int) = eq-int
equivt-refl (TChn S , con-chn x) = eq-chn (equiv-refl (S , x))

equivs-refl (xmt d t s , con-xmt ct cs) = eq-xmt d (equivt-refl (t , ct)) (equiv-refl (s , cs))
equivs-refl (end , con-end) = eq-end
equivs-refl (rec s , con-rec cs) = eq-rec-l (eq-rec-r (equivs-refl ((subst-maxS (rec s) s) , (subst-contr-mS (c-weakenS₁ cs) (con-rec cs)))))

Equiv.force (equiv-refl S) = equivs-refl (unfold!! S id)

----------------------------------------------------------------------
-- prove equivalence of one-level unrolling
-- μX S ≈ S [μX S / X]

module μ-unrolling where

  unfold-≡ : ∀ S cs →
    unfold!! (S , cs) (λ { (S' , c') → (subst-maxS (rec S) S') , (subst-contr-mS (c-weakenS₁ c') (con-rec cs)) })
    ≡
      (unfold!!
       (subst-maxS (rec S) S ,
        subst-contr-mS (c-weakenS₁ cs) (con-rec cs))
       id)

  unfold-≡ (xmt d T S) (con-xmt x cs) = refl
  unfold-≡ end con-end = refl
  unfold-≡ (rec S) (con-rec cs) = {!!}
  unfold-≡ (var x) (con-var x₁)
    with max? x
  unfold-≡ (var x) (con-var x₁) | yes p = {!!}
  unfold-≡ (var x) (con-var x₁) | no ¬p = refl

  unroll : SCType n i → SCType n i
  unroll SC@(xmt d T S , con-xmt x cs) = SC
  unroll SC@(end , con-end) = SC
  unroll (rec S , cs@(con-rec cs')) = (subst-maxS (rec S) S) , (subst-contr-mS (c-weakenS₁ cs') cs)
  unroll SC@(var x , con-var x₁) = SC

  unroll-equiv : (SC : SCType 0 zero) → Equiv SC (unroll SC)
  Equiv.force (unroll-equiv SC@(xmt d T S , con-xmt x cs))
    with unroll SC
  ... | SC' = equivs-refl SC'
  Equiv.force (unroll-equiv (end , con-end)) = eq-end
  Equiv.force (unroll-equiv (rec S , con-rec cs))
    rewrite unfold-≡ S cs =
    let S₁ = unfold!! (S , cs) (λ { (S' , c') → (subst-maxS (rec S) S') , (subst-contr-mS (c-weakenS₁ c') (con-rec cs)) }) in
    let eqx = equivs-refl S₁ in
    {!S₁!}

----------------------------------------------------------------------
-- prove the folk theorem
-- μX μY S = μY [Y/X]S

module μ-examples where

  r1 : SType 0
  r1 = rec (rec (xmt SND (TChn (var zero)) (var (suc zero))))

  r2 : SType n
  r2 = rec (xmt SND (TChn (var zero)) (var zero))

  r2a : SType 0
  r2a = rec r2

  r2b : SType n
  r2b = rec (rec (xmt SND (TChn (var zero)) (var (suc zero))))

  r2-unfolded : SType 0
  r2-unfolded = xmt SND (TChn r2) r2

  r2-unf : SType 0
  r2-unf = rec (xmt SND (TChn (var zero)) r2b)

  rc2-unf : SCType 0 zero
  rc2-unf = r2-unf , (con-rec (con-xmt (con-chn (con-var z≤n)) (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n))))))

  rc1 : SCType 0 zero
  rc1 = r1 , (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n))))

  rc2 : SCType n zero
  rc2 = r2 , (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))

  rc2a : SCType 0 zero
  rc2a = r2a , con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))

  rc2b : SCType n zero
  rc2b = r2b , con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))

  rc2-unfolded : SCType 0 zero
  rc2-unfolded = r2-unfolded , (con-xmt (con-chn (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))) (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n))))

  rc2=rc2 : Equiv rc2 rc2
  Equiv.force rc2=rc2 = eq-xmt SND (eq-chn rc2=rc2) rc2=rc2

  rc2=rc2-unfolded : Equiv rc2 rc2-unfolded
  Equiv.force rc2=rc2-unfolded = eq-xmt SND (eq-chn rc2=rc2) rc2=rc2

  weak-r2 : SType 0
  weak-r2 = rec (weaken'S 1 zero r2)

  weak-rc2 : SCType 0 zero
  weak-rc2 = weak-r2 , (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n))))

  r2-weak : SType n
  r2-weak = rec (xmt SND ((TChn (weaken'S 1 zero (rec (rec (xmt SND (TChn (var (suc zero))) (var (suc zero)))))))) ((weaken'S 1 zero (rec (rec (xmt SND (TChn (var (suc zero))) (var (suc zero))))))))

  rc2-weak : SCType 0 zero
  rc2-weak = r2-weak , con-rec (con-xmt (con-chn (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n))))) (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))))

  rc2=rc2a : Equiv rc2 rc2a
  Equiv.force rc2=rc2a = eq-xmt SND (eq-chn rc2=rc2a) rc2=rc2a

  rc2=xxxrc2b : Equiv' rc2 rc2-unf
  rc2=rc2b : Equiv' rc2 rc2b

  Equiv'.force rc2=xxxrc2b = eq-xmt SND (eq-chn rc2=xxxrc2b) rc2=rc2b
  Equiv'.force rc2=rc2b = eq-xmt SND (eq-chn rc2=rc2b) rc2=xxxrc2b

  rc2=rc2-weak : Equiv' rc2 rc2-weak
  Equiv'.force rc2=rc2-weak = eq-xmt SND (eq-chn {!rc2=rc2b!}) {!!}

  rc2=weak-rc2 : Equiv rc2 weak-rc2
  Equiv.force rc2=weak-rc2 = eq-xmt SND (eq-chn rc2=rc2a) rc2=rc2a

  r3 : SType 0
  r3 = rec (xmt SND (TChn (var zero)) (weaken'S 1 zero r1))

  rc3 : SCType 0 zero
  rc3 = r3 , con-rec (con-xmt (con-chn (con-var z≤n)) (con-rec (con-rec (con-xmt (con-chn (con-var z≤n)) (con-var z≤n)))))

  rc1=rc2 : Equiv rc1 rc2
  rc3=rc2 : Equiv rc3 rc2

  Equiv.force rc1=rc2 = eq-xmt SND (eq-chn rc1=rc2) rc3=rc2
  Equiv.force rc3=rc2 = eq-xmt SND (eq-chn rc3=rc2) rc1=rc2

-- end examples
----------------------------------------------------------------------

recrec : SType 2 → SType 0 × SType 0
recrec S = rec (rec S) , rec (subst-maxS (var zero) S)

recrec2 : SType 2 → SType 1
recrec2 S = rec S

conrr1 : {S : SType 2} → Contractive (suc (suc zero)) S → Contractive zero (rec (rec S))
conrr1 cs = con-rec (con-rec cs)

conrr2 : {S : SType 2} → Contractive (suc (suc zero)) S → Contractive (suc zero) (subst-maxS (var zero) S)
conrr2 cs = subst-contr-mS {!subst-contr-mS!} (con-var (s≤s z≤n))

sc-rec : SCType (suc n) (suc i) → SCType n i
sc-rec (S , cs) = (rec S , con-rec cs)

¬fromN≤x : (x : Fin n) → ¬ (fromℕ n ≤ inject₁ x)
¬fromN≤x {suc n} zero ()
¬fromN≤x {suc n} (suc x) (s≤s n≤x) = ¬fromN≤x x n≤x

μμ-lem-gen : {n : ℕ}
  → (S : SType (suc (suc n)))
  → Contractive (suc (suc (fromℕ n))) S
  → Contractive (suc (fromℕ n)) (subst-maxS (var (fromℕ n)) S)
μμ-lem-gen (xmt d T S) (con-xmt x cs) = con-xmt (subst-contr-mT x (con-var z≤n)) (subst-contr-mS cs (con-var z≤n))
μμ-lem-gen end con-end = con-end
μμ-lem-gen (rec S) (con-rec cs) = con-rec (μμ-lem-gen S cs)
μμ-lem-gen (var zero) (con-var ())
μμ-lem-gen (var (suc zero)) (con-var (s≤s ()))
μμ-lem-gen (var (suc (suc x))) (con-var (s≤s (s≤s x₁)))
  with ¬fromN≤x x x₁
μμ-lem-gen (var (suc (suc x))) (con-var (s≤s (s≤s x₁))) | ()

μμ-lemma : (S : SType 2) → Contractive (suc (suc zero)) S → Contractive (suc zero) (subst-maxS (var zero) S)
μμ-lemma S cs = μμ-lem-gen S cs

μμ-gen : (S : SType (suc (suc n))) (cs : Contractive (suc (suc (fromℕ n))) S) →
  Equiv' (sc-rec (sc-rec (S , {!!})))
         (sc-rec ((subst-maxS (var zero) S) , {!!}))
μμ-gen S cs = {!!}

μμ1 : (S : SType 2) (cs : Contractive (suc (suc zero)) S) →
  Equiv (sc-rec (sc-rec (S , cs)))
        (sc-rec ((subst-maxS (var zero) S) , μμ-lemma S cs))
Equiv.force (μμ1 (xmt d T S) (con-xmt x cs)) = {!!}
Equiv.force (μμ1 end con-end) = eq-end
Equiv.force (μμ1 (rec S) (con-rec cs)) = {!!}
Equiv.force (μμ1 (var x) (con-var x₁)) = {!!}

-- or μX μY S = μX [X/Y]S

μμ2 : (S : SType 2) (cs : Contractive (suc (suc zero)) S) →
  Equiv (sc-rec (sc-rec (S , cs)))
        let xxx = subst-maxS {!sc-rec!} (rec S) in (sc-rec ((subst-maxS (var zero) S) , (subst-contr-mS (c-weakenS₁ cs) (con-var {!!}))))
μμ2 S cs = {!!}


-- Andreas, 2017-01-21, issue #2423 overloading inherited projections

-- {-# OPTIONS -v tc.lhs.split:30 #-}
-- {-# OPTIONS -v tc.proj.amb:100 #-}
-- {-# OPTIONS -v tc.mod.apply:100 #-}

postulate
  A : Set

record R : Set where
  field f : A

record S : Set where
  field r : R
  open R r public
  -- The inherited projection (in the eyes of the scope checker) S.f
  -- is actually a composition of projections R.f ∘ S.r
  -- s .S.f = s .S.r .R.f

open S
open R

test : S → S
test s .f = s .f

-- Error WAS:
-- Cannot eliminate type S with pattern .f (did you supply too many arguments?)

-- NOW:
-- Cannot eliminate type  S  with projection  R.f

-- Shows the chosen disambiguation in error message.


{-# OPTIONS --cubical --safe --postfix-projections #-}

open import Prelude hiding (_×_)

module Categories.HSets {ℓ : Level} where

open import Categories
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Data.Sigma.Properties
open import Categories.Product
open import Categories.Exponential

hSetPreCategory : PreCategory (ℓsuc ℓ) ℓ
hSetPreCategory .PreCategory.Ob = hSet _
hSetPreCategory .PreCategory.Hom (X , _) (Y , _) = X → Y
hSetPreCategory .PreCategory.Id = id
hSetPreCategory .PreCategory.Comp f g = f ∘ g
hSetPreCategory .PreCategory.assoc-Comp _ _ _ = refl
hSetPreCategory .PreCategory.Comp-Id _ = refl
hSetPreCategory .PreCategory.Id-Comp _ = refl
hSetPreCategory .PreCategory.Hom-Set {X} {Y} = hLevelPi 2 λ _ → Y .snd

open PreCategory hSetPreCategory

_⟨×⟩_ : isSet A → isSet B → isSet (A Prelude.× B)
xs ⟨×⟩ ys = isOfHLevelΣ 2 xs (const ys)

module _ {X Y : Ob} where
  iso-iso : (X ≅ Y) ⇔ (fst X ⇔ fst Y)
  iso-iso .fun (f , g , f∘g , g∘f) = iso f g (λ x i → g∘f i x) (λ x i → f∘g i x)
  iso-iso .inv (iso f g g∘f f∘g) = f , g  , (λ i x → f∘g x i) , (λ i x → g∘f x i)
  iso-iso .rightInv _ = refl
  iso-iso .leftInv  _ = refl

  univ⇔ : (X ≡ Y) ⇔ (X ≅ Y)
  univ⇔ = equivToIso (≃ΣProp≡ (λ _ → isPropIsSet)) ⟨ trans-⇔ ⟩
          equivToIso univalence ⟨ trans-⇔ ⟩
          sym-⇔ (iso⇔equiv (snd X)) ⟨ trans-⇔ ⟩
          sym-⇔ iso-iso

hSetCategory : Category (ℓsuc ℓ) ℓ
hSetCategory .Category.preCategory = hSetPreCategory
hSetCategory .Category.univalent = isoToEquiv univ⇔

hSetProd : HasProducts hSetCategory
hSetProd .HasProducts.product X Y .Product.obj = (X .fst Prelude.× Y .fst) , X .snd ⟨×⟩ Y .snd
hSetProd .HasProducts.product X Y .Product.proj₁ = fst
hSetProd .HasProducts.product X Y .Product.proj₂ = snd
hSetProd .HasProducts.product X Y .Product.ump f g .fst z = f z , g z
hSetProd .HasProducts.product X Y .Product.ump f g .snd .fst .fst = refl
hSetProd .HasProducts.product X Y .Product.ump f g .snd .fst .snd = refl
hSetProd .HasProducts.product X Y .Product.ump f g .snd .snd (f≡ , g≡) i x = f≡ (~ i) x , g≡ (~ i) x

hSetExp : HasExponentials hSetCategory hSetProd
hSetExp  X Y .Exponential.obj = (X .fst → Y .fst) , hLevelPi 2 λ _ → Y .snd
hSetExp  X Y .Exponential.eval (f , x) = f x
hSetExp  X Y .Exponential.uniq X₁ f .fst = curry f
hSetExp  X Y .Exponential.uniq X₁ f .snd .fst = refl
hSetExp  X Y .Exponential.uniq X₁ f .snd .snd {y} x = cong curry (sym x)

open import Categories.Pullback

hSetHasPullbacks : HasPullbacks hSetCategory
hSetHasPullbacks {X = X} {Y = Y} {Z = Z} f g .Pullback.P = ∃[ ab ] (f (fst ab) ≡ g (snd ab)) , isOfHLevelΣ 2 (X .snd ⟨×⟩ Y .snd) λ xy → isProp→isSet (Z .snd (f (xy .fst)) (g (xy .snd)))
hSetHasPullbacks f g .Pullback.p₁ ((x , _) , _) = x
hSetHasPullbacks f g .Pullback.p₂ ((_ , y) , _) = y
hSetHasPullbacks f g .Pullback.commute = funExt snd
hSetHasPullbacks f g .Pullback.ump {A = A} h₁ h₂ p .fst x = (h₁ x , h₂ x) , λ i → p i x
hSetHasPullbacks f g .Pullback.ump {A = A} h₁ h₂ p .snd .fst .fst = refl
hSetHasPullbacks f g .Pullback.ump {A = A} h₁ h₂ p .snd .fst .snd = refl
hSetHasPullbacks {Z = Z} f g .Pullback.ump {A = A} h₁ h₂ p .snd .snd {i} (p₁e , p₂e) = funExt (λ x → ΣProp≡ (λ _ → Z .snd _ _) λ j → p₁e (~ j) x , p₂e (~ j) x)

hSetTerminal : Terminal
hSetTerminal .fst = Lift _ ⊤ , isProp→isSet λ _ _ → refl
hSetTerminal .snd .fst x .lower = tt
hSetTerminal .snd .snd y = funExt λ _ → refl

hSetInitial : Initial
hSetInitial .fst = Lift _ ⊥ , λ ()
hSetInitial .snd .fst ()
hSetInitial .snd .snd y i ()

open import HITs.PropositionalTruncation
open import Categories.Coequalizer

∃!′ : (A : Type a) → (A → Type b) → Type (a ℓ⊔ b)
∃!′ A P = ∥ Σ A P ∥ Prelude.× AtMostOne P

lemma23 : ∀ {p} {P : A → hProp p} → ∃!′ A (fst ∘ P) → Σ A (fst ∘ P)
lemma23 {P = P} (x , y) = rec (λ xs ys → ΣProp≡ (snd ∘ P) (y (xs .fst) (ys .fst) (xs .snd) (ys .snd))) id x

module _ {A : Type a} {P : A → Type b} (R : ∀ x → P x → hProp c) where
  uniqueChoice : (Π[ x ⦂ A ] (∃!′ (P x) (λ u → R x u .fst))) →
                 Σ[ f ⦂ Π[ x ⦂ A ] P x ] Π[ x ⦂ A ] (R x (f x) .fst)
  uniqueChoice H = fst ∘ mid , snd ∘ mid
    where
    mid : Π[ x ⦂ A ] Σ[ u ⦂ P x ] (R x u .fst)
    mid x = lemma23 {P = R x} (H x)

open import HITs.PropositionalTruncation.Sugar

module CoeqProofs {X Y : Ob} (f : X ⟶ Y) where
  KernelPair : Pullback hSetCategory {X = X} {Z = Y} {Y = X} f f
  KernelPair = hSetHasPullbacks f f

  Im : Ob
  Im = ∃[ b ] ∥ fiber f b ∥ , isOfHLevelΣ 2 (Y .snd) λ _ → isProp→isSet squash

  im : X ⟶ Im
  im x = f x , ∣ x , refl ∣

  open Pullback KernelPair

  lem : ∀ {H : Ob} (h : X ⟶ H) → h ∘ p₁ ≡ h ∘ p₂ → Σ[ f ⦂ (Im ⟶ H) ] Π[ x ⦂ Im .fst ] (∀ y → im y ≡ x → h y ≡ f x)
  lem {H = H} h eq = uniqueChoice R prf
    where
    R : Im .fst → H .fst → hProp _
    R w x .fst = ∀ y → im y ≡ w → h y ≡ x
    R w x .snd = hLevelPi 1 λ _ → hLevelPi 1 λ _ → H .snd _ _

    prf : Π[ x ⦂ Im .fst ] ∃!′ (H .fst) (λ u → ∀ y → im y ≡ x → h y ≡ u)
    prf (xy , p) .fst = (λ { (z , r) → h z , λ y imy≡xyp → cong (_$ ((y , z) , cong fst imy≡xyp ; sym r)) eq }) ∥$∥ p
    prf (xy , p) .snd x₁ x₂ Px₁ Px₂ = rec (H .snd x₁ x₂) (λ { (z , zs) → sym (Px₁ z (ΣProp≡ (λ _ → squash) zs)) ; Px₂ z (ΣProp≡ (λ _ → squash) zs) } ) p

  lem₂ : ∀ (H : Ob) (h : X ⟶ H) (i : Im ⟶ H) (x : Im .fst) (hi : h ≡ i ∘ im) (eq : h ∘ p₁ ≡ h ∘ p₂) → i x ≡ lem {H = H} h eq .fst x
  lem₂ H h i x hi eq = rec (H .snd _ _) (λ { (y , ys) → (cong i (ΣProp≡ (λ _ → squash) (sym ys)) ; sym (cong (_$ y) hi)) ; lem {H = H} h eq .snd x y (ΣProp≡ (λ _ → squash) ys) }) (x .snd)

  hSetCoeq : Coequalizer hSetCategory {X = P} {Y = X} p₁ p₂
  hSetCoeq .Coequalizer.obj = Im
  hSetCoeq .Coequalizer.arr = im
  hSetCoeq .Coequalizer.equality = funExt λ x → ΣProp≡ (λ _ → squash) λ i → commute i x
  hSetCoeq .Coequalizer.coequalize {H = H} {h = h} eq = lem {H = H} h eq .fst
  hSetCoeq .Coequalizer.universal {H = H} {h = h} {eq = eq} = funExt λ x → lem {H = H} h eq .snd (im x) x refl
  hSetCoeq .Coequalizer.unique {H = H} {h = h} {i = i} {eq = eq} prf = funExt λ x → lem₂ H h i x prf eq
open CoeqProofs using (hSetCoeq) public

module PullbackSurjProofs {X Y : Ob} (f : X ⟶ Y) (fSurj : Surjective f) where
  KernelPair : Pullback hSetCategory {X = X} {Z = Y} {Y = X} f f
  KernelPair = hSetHasPullbacks f f

  open Pullback KernelPair

  p₁surj : Surjective p₁
  p₁surj y = ∣ ((y , y) , refl) , refl ∣

  p₂surj : Surjective p₂
  p₂surj y = ∣ ((y , y) , refl) , refl ∣

open import Relation.Binary
open import Cubical.HITs.SetQuotients

module _ {A : Type a} {R : A → A → Type b} {C : Type c}
         (isSetC : isSet C)
         (f : A → C)
         (coh : ∀ x y → R x y → f x ≡ f y)
         where

  recQuot : A / R → C
  recQuot [ a ] = f a
  recQuot (eq/ a b r i) = coh a b r i
  recQuot (squash/ xs ys x y i j) = isSetC (recQuot xs) (recQuot ys) (cong recQuot x) (cong recQuot y) i j

open import Path.Reasoning

module ExtactProofs {X : Ob} {R : X .fst → X .fst → hProp ℓ}
  (symR : Symmetric (λ x y → R x y .fst))
  (transR : Transitive (λ x y → R x y .fst))
  (reflR : Reflexive (λ x y → R x y .fst))
  where
  ℛ : X .fst → X .fst → Type ℓ
  ℛ x y = R x y .fst

  Src : Ob
  Src .fst = ∃[ x,y ] (uncurry ℛ x,y)
  Src .snd = isOfHLevelΣ 2 (X .snd ⟨×⟩ X .snd) λ _ → isProp→isSet (R _ _ .snd)

  pr₁ pr₂ : Src ⟶ X
  pr₁ = fst ∘ fst
  pr₂ = snd ∘ fst

  ROb : Ob
  ROb = X .fst / ℛ , squash/

  CR : Coequalizer hSetCategory {X = Src} {Y = X} pr₁ pr₂
  CR .Coequalizer.obj = ROb
  CR .Coequalizer.arr = [_]
  CR .Coequalizer.equality = funExt λ { ((x , y) , x~y) → eq/ x y x~y}
  CR .Coequalizer.coequalize {H = H} {h = h} e = recQuot (H .snd) h λ x y x~y → cong (_$ ((x , y) , x~y)) e
  CR .Coequalizer.universal {H = H} {h = h} {eq = e} = refl
  CR .Coequalizer.unique {H = H} {h = h} {i = i} {eq = e} p = funExt (elimSetQuotientsProp (λ _ → H .snd _ _) λ x j → p (~ j) x)


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

module Light.Level where

open import Agda.Primitive using (Level ; _⊔_ ; Setω) renaming (lzero to 0ℓ ; lsuc to ++_) public

record Lifted ℓ {aℓ} (𝕒 : Set aℓ) : Set (ℓ ⊔ aℓ) where
      constructor lift
      field lower : 𝕒


module PiQ.Eval where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Data.Nat hiding (_≟_)
open import Data.List as L hiding (_∷_)
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function using (_∘_)
open import PiQ.Syntax
open import PiQ.Opsem
open import PiQ.AuxLemmas
open import PiQ.NoRepeat
open import PiQ.Invariants

infix 100 _⃗
infix 100 _⃖

-- Stuck states must be either of the form ⟨ c ∣ v ∣ ☐ ⟩◁), ［ c ∣ v ∣ ☐ ］▷ or ⊠
Stuck : ∀ {st} → is-stuck st
      → (Σ[ A ∈ 𝕌 ] Σ[ B ∈ 𝕌 ] Σ[ c ∈ A ↔ B ] Σ[ v ∈ ⟦ A ⟧ ] st ≡ ⟨ c ∣ v ∣ ☐ ⟩◁)
      ⊎ (Σ[ A ∈ 𝕌 ] Σ[ B ∈ 𝕌 ] Σ[ c ∈ A ↔ B ] Σ[ v ∈ ⟦ B ⟧ ] st ≡ ［ c ∣ v ∣ ☐ ］▷)
      ⊎ st ≡ ⊠
Stuck {⟨ unite₊l ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ uniti₊l ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ swap₊   ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ assocl₊ ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ assocr₊ ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ unite⋆l ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ uniti⋆l ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ swap⋆   ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ assocl⋆ ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ assocr⋆ ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ dist    ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ factor  ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₁))
Stuck {⟨ id↔     ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₂))
Stuck {⟨ c₁ ⨾ c₂ ∣ v          ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₃))
Stuck {⟨ c₁ ⊕ c₂ ∣ inj₁ x     ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₄))
Stuck {⟨ c₁ ⊕ c₂ ∣ inj₂ y     ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₅))
Stuck {⟨ c₁ ⊗ c₂ ∣ (x , y)    ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗₆))
Stuck {⟨ ε₊      ∣ inj₁ x     ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦ε₊₁))
Stuck {⟨ ε₊      ∣ inj₂ (- x) ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦ε₊₂))
Stuck {⟨ ηₓ _    ∣ tt         ∣ κ ⟩▷} stuck = ⊥-elim (stuck (_ , ↦⃗ηₓ))
Stuck {⟨ εₓ v    ∣ (v' , ↻)   ∣ κ ⟩▷} stuck with v ≟ v'
... | yes p = ⊥-elim (stuck (_ , ↦⃗εₓ₁ {eq = p}))
... | no  p = ⊥-elim (stuck (_ , ↦⃗εₓ₂ {neq = p}))
Stuck {［ c ∣ v ∣ ☐ ］▷}               stuck = inj₂ (inj₁ (_ , _ , c , v , refl))
Stuck {［ c₁ ∣ v ∣ ☐⨾ c₂ • κ ］▷}      stuck = ⊥-elim (stuck (_ , ↦⃗₇))
Stuck {［ c ∣ v ∣ c₁ ⨾☐• κ ］▷}        stuck = ⊥-elim (stuck (_ , ↦⃗₁₀))
Stuck {［ c ∣ v ∣ ☐⊕ c₂ • κ ］▷}       stuck = ⊥-elim (stuck (_ , ↦⃗₁₁))
Stuck {［ c ∣ v ∣ c₁ ⊕☐• κ ］▷}        stuck = ⊥-elim (stuck (_ , ↦⃗₁₂))
Stuck {［ c ∣ v ∣ ☐⊗[ c₂ , x ]• κ ］▷} stuck = ⊥-elim (stuck (_ , ↦⃗₈))
Stuck {［ c ∣ v ∣ [ c₁ , x ]⊗☐• κ ］▷} stuck = ⊥-elim (stuck (_ , ↦⃗₉))
Stuck {⟨ c  ∣ v ∣ ☐ ⟩◁}                stuck = inj₁ (_ , _ , c , v , refl)
Stuck {⟨ c₁ ∣ v ∣ ☐⨾ c₂ • κ ⟩◁}        stuck = ⊥-elim (stuck (_ , ↦⃖₃))
Stuck {⟨ c₂ ∣ v ∣ c₁ ⨾☐• κ ⟩◁}         stuck = ⊥-elim (stuck (_ , ↦⃖₇))
Stuck {⟨ c₁ ∣ v ∣ ☐⊕ c₂ • κ ⟩◁}        stuck = ⊥-elim (stuck (_ , ↦⃖₄))
Stuck {⟨ c₂ ∣ v ∣ c₁ ⊕☐• κ ⟩◁}         stuck = ⊥-elim (stuck (_ , ↦⃖₅))
Stuck {⟨ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ⟩◁}  stuck = ⊥-elim (stuck (_ , ↦⃖₆))
Stuck {⟨ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ⟩◁}  stuck = ⊥-elim (stuck (_ , ↦⃖₈))
Stuck {［ unite₊l ∣ v ∣ κ ］◁}             stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ v ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ uniti₊l ∣ inj₂ y ∣ κ ］◁}        stuck = ⊥-elim (stuck (⟨ _ ∣ y ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ swap₊ ∣ inj₁ x ∣ κ ］◁}          stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ x ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ swap₊ ∣ inj₂ y ∣ κ ］◁}          stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ y ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocl₊ ∣ inj₁ (inj₁ x) ∣ κ ］◁} stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ x ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocl₊ ∣ inj₁ (inj₂ y) ∣ κ ］◁} stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ (inj₁ y) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocl₊ ∣ inj₂ y ∣ κ ］◁}        stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ (inj₂ y) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocr₊ ∣ inj₁ x ∣ κ ］◁}        stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ (inj₁ x) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocr₊ ∣ inj₂ (inj₁ x) ∣ κ ］◁} stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ (inj₂ x) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocr₊ ∣ inj₂ (inj₂ y) ∣ κ ］◁} stuck = ⊥-elim (stuck (⟨ _ ∣ (inj₂ y) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ unite⋆l ∣ v ∣ κ ］◁}             stuck = ⊥-elim (stuck (⟨ _ ∣ (tt , v) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ uniti⋆l ∣ (tt , v) ∣ κ ］◁}      stuck = ⊥-elim (stuck (⟨ _ ∣ v ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ swap⋆ ∣ (x , y) ∣ κ ］◁}         stuck = ⊥-elim (stuck (⟨ _ ∣ (y , x) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocl⋆ ∣ (x , y) , z ∣ κ ］◁}   stuck = ⊥-elim (stuck (⟨ _ ∣ x , (y , z) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ assocr⋆ ∣ x , (y , z) ∣ κ ］◁}   stuck = ⊥-elim (stuck (⟨ _ ∣ (x , y) , z ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ dist ∣ inj₁ (x , z) ∣ κ ］◁}     stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ x , z ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ dist ∣ inj₂ (y , z) ∣ κ ］◁}     stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ y , z ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ factor ∣ inj₁ x , z ∣ κ ］◁}     stuck = ⊥-elim (stuck (⟨ _ ∣ inj₁ (x , z) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ factor ∣ inj₂ y , z ∣ κ ］◁}     stuck = ⊥-elim (stuck (⟨ _ ∣ inj₂ (y , z) ∣ _ ⟩◁ , ↦⃖₁))
Stuck {［ id↔     ∣ v ∣ κ ］◁}             stuck = ⊥-elim (stuck (_ , ↦⃖₂))
Stuck {［ c₁ ⨾ c₂ ∣ v ∣ κ ］◁}             stuck = ⊥-elim (stuck (_ , ↦⃖₁₀))
Stuck {［ c₁ ⊕ c₂ ∣ inj₁ x ∣ κ ］◁}        stuck = ⊥-elim (stuck (_ , ↦⃖₁₁))
Stuck {［ c₁ ⊕ c₂ ∣ inj₂ y ∣ κ ］◁}        stuck = ⊥-elim (stuck (_ , ↦⃖₁₂))
Stuck {［ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ］◁}       stuck = ⊥-elim (stuck (_ , ↦⃖₉))
Stuck {［ η₊      ∣ inj₁ x ∣ κ ］◁}        stuck = ⊥-elim (stuck (_ , ↦η₊₁))
Stuck {［ η₊      ∣ inj₂ (- x) ∣ κ ］◁}    stuck = ⊥-elim (stuck (_ , ↦η₊₂))
Stuck {［ ηₓ v    ∣ (v' , ↻)   ∣ κ ］◁}    stuck with v ≟ v'
... | yes p = ⊥-elim (stuck (_ , ↦⃖ηₓ₁ {eq = p}))
... | no  p = ⊥-elim (stuck (_ , ↦⃖ηₓ₂ {neq = p}))
Stuck {［ εₓ _    ∣ tt         ∣ κ ］◁}    stuck = ⊥-elim (stuck (_ , ↦⃖εₓ))
Stuck {⊠}                                 stuck = inj₂ (inj₂ refl)

-- Find next step of given the state
step : (st : State) → ∃[ st' ] (st ↦ st') ⊎ is-stuck st
step ⟨ unite₊l ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ uniti₊l ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ swap₊   ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ assocl₊ ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ assocr₊ ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ unite⋆l ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ uniti⋆l ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ swap⋆   ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ assocl⋆ ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ assocr⋆ ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ dist    ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ factor  ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₁)
step ⟨ id↔     ∣ v ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₂)
step ⟨ c₁ ⨾ c₂ ∣ v          ∣ κ ⟩▷ = inj₁ (⟨ c₁ ∣ v ∣ ☐⨾ c₂ • κ ⟩▷ , ↦⃗₃)
step ⟨ c₁ ⊕ c₂ ∣ inj₁ x     ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₄)
step ⟨ c₁ ⊕ c₂ ∣ inj₂ y     ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₅)
step ⟨ c₁ ⊗ c₂ ∣ (x , y)    ∣ κ ⟩▷ = inj₁ (_ , ↦⃗₆)
step ⟨ ε₊      ∣ inj₁ x     ∣ κ ⟩▷ = inj₁ (_ , ↦ε₊₁)
step ⟨ ε₊      ∣ inj₂ (- x) ∣ κ ⟩▷ = inj₁ (_ , ↦ε₊₂)
step ⟨ ηₓ _    ∣ tt         ∣ κ ⟩▷ = inj₁ (_ , ↦⃗ηₓ)
step ⟨ εₓ v    ∣ v' , ↻     ∣ κ ⟩▷ with v ≟ v'
... | yes p = inj₁ (_ , (↦⃗εₓ₁ {eq = p}))
... | no  p = inj₁ (_ , (↦⃗εₓ₂ {neq = p}))
step ［ c  ∣ v ∣ ☐ ］▷               = inj₂ (λ ())
step ［ c₁ ∣ v ∣ ☐⨾ c₂ • κ ］▷       = inj₁ (_ , ↦⃗₇)
step ［ c₂ ∣ v ∣ c₁ ⨾☐• κ ］▷        = inj₁ (_ , ↦⃗₁₀)
step ［ c₁ ∣ v ∣ ☐⊕ c₂ • κ ］▷       = inj₁ (_ , ↦⃗₁₁)
step ［ c₂ ∣ v ∣ c₁ ⊕☐• κ ］▷        = inj₁ (_ , ↦⃗₁₂)
step ［ c₁ ∣ v ∣ ☐⊗[ c₂ , x ]• κ ］▷ = inj₁ (_ , ↦⃗₈)
step ［ c₂ ∣ v ∣ [ c₁ , x ]⊗☐• κ ］▷ = inj₁ (_ , ↦⃗₉)
step ⟨ c ∣ v ∣ ☐ ⟩◁                = inj₂ (λ ())
step ⟨ c₁ ∣ v ∣ ☐⨾ c₂ • κ ⟩◁       = inj₁ (_ , ↦⃖₃)
step ⟨ c₂ ∣ v ∣ c₁ ⨾☐• κ ⟩◁        = inj₁ (_ , ↦⃖₇)
step ⟨ c₁ ∣ v ∣ ☐⊕ c₂ • κ ⟩◁       = inj₁ (_ , ↦⃖₄)
step ⟨ c₂ ∣ v ∣ c₁ ⊕☐• κ ⟩◁        = inj₁ (_ , ↦⃖₅)
step ⟨ c₁ ∣ v ∣ ☐⊗[ c₂ , x ]• κ ⟩◁ = inj₁ (_ , ↦⃖₆)
step ⟨ c₂ ∣ v ∣ [ c₁ , x ]⊗☐• κ ⟩◁ = inj₁ (_ , ↦⃖₈)
step ［ unite₊l ∣ v             ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ v ∣ _ ⟩◁ , ↦⃖₁)
step ［ uniti₊l ∣ inj₂ v        ∣ κ ］◁ = inj₁ (⟨ _ ∣ v ∣ _ ⟩◁ , ↦⃖₁)
step ［ swap₊   ∣ inj₁ x        ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ x ∣ _ ⟩◁ , ↦⃖₁)
step ［ swap₊   ∣ inj₂ y        ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ y ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocl₊ ∣ inj₁ (inj₁ x) ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ x ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocl₊ ∣ inj₁ (inj₂ y) ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ (inj₁ y) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocl₊ ∣ inj₂ z        ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ (inj₂ z) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocr₊ ∣ inj₁ x        ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ (inj₁ x) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocr₊ ∣ inj₂ (inj₁ y) ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ (inj₂ y) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocr₊ ∣ inj₂ (inj₂ z) ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ z ∣ _ ⟩◁ , ↦⃖₁)
step ［ unite⋆l ∣ v             ∣ κ ］◁ = inj₁ (⟨ _ ∣ tt , v ∣ _ ⟩◁ , ↦⃖₁)
step ［ uniti⋆l ∣ (tt , v)      ∣ κ ］◁ = inj₁ (⟨ _ ∣ v ∣ _ ⟩◁ , ↦⃖₁)
step ［ swap⋆   ∣ (x , y)       ∣ κ ］◁ = inj₁ (⟨ _ ∣ (y , x) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocl⋆ ∣ (x , y) , z   ∣ κ ］◁ = inj₁ (⟨ _ ∣ x , (y , z) ∣ _ ⟩◁ , ↦⃖₁)
step ［ assocr⋆ ∣ x , (y , z)   ∣ κ ］◁ = inj₁ (⟨ _ ∣ (x , y) , z ∣ _ ⟩◁ , ↦⃖₁)
step ［ dist    ∣ inj₁ (x , z)  ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ x , z ∣ _ ⟩◁ , ↦⃖₁)
step ［ dist    ∣ inj₂ (y , z)  ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ y , z ∣ _ ⟩◁ , ↦⃖₁)
step ［ factor  ∣ inj₁ x , z    ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₁ (x , z) ∣ _ ⟩◁ , ↦⃖₁)
step ［ factor  ∣ inj₂ y , z    ∣ κ ］◁ = inj₁ (⟨ _ ∣ inj₂ (y , z) ∣ _ ⟩◁ , ↦⃖₁)
step ［ id↔     ∣ v             ∣ κ ］◁ = inj₁ (_ , ↦⃖₂)
step ［ c₁ ⨾ c₂ ∣ v             ∣ κ ］◁ = inj₁ (_ , ↦⃖₁₀)
step ［ c₁ ⊕ c₂ ∣ inj₁ x        ∣ κ ］◁ = inj₁ (_ , ↦⃖₁₁)
step ［ c₁ ⊕ c₂ ∣ inj₂ y        ∣ κ ］◁ = inj₁ (_ , ↦⃖₁₂)
step ［ c₁ ⊗ c₂ ∣ (x , y)       ∣ κ ］◁ = inj₁ (_ , ↦⃖₉)
step ［ η₊      ∣ inj₁ x        ∣ κ ］◁ = inj₁ (_ , ↦η₊₁)
step ［ η₊      ∣ inj₂ (- x)    ∣ κ ］◁ = inj₁ (_ , ↦η₊₂)
step ［ ηₓ v    ∣ (v' , ↻)      ∣ κ ］◁ with v ≟ v'
... | yes p = inj₁ (_ , (↦⃖ηₓ₁ {eq = p}))
... | no  p = inj₁ (_ , (↦⃖ηₓ₂ {neq = p}))
step ［ εₓ _    ∣ tt            ∣ κ ］◁ = inj₁ (_ , ↦⃖εₓ)
step ⊠ = inj₂ (λ ())

-- Values tagged with direction
data Val (A B : 𝕌) : Set where
  _⃗ : ⟦ A ⟧ → Val A B
  _⃖ : ⟦ B ⟧ → Val A B

-- Termination is guaranteed by PiQ.NoRepeat and the finiteness of states
{-# TERMINATING #-}
run : (st₀ : State) → (init : is-initial st₀)
    → let (A , B , c) = getℂ st₀ (st-is-initial⇒st≢⊠ st₀ init)
      in  (Σ[ v ∈ ⟦ A ⟧ ] st₀ ↦* ⟨ c ∣ v ∣ ☐ ⟩◁)
       ⊎  (Σ[ v ∈ ⟦ B ⟧ ] st₀ ↦* ［ c ∣ v ∣ ☐ ］▷)
       ⊎  st₀ ↦* ⊠
run st₀ init = run' st₀ ◾
  where
    run' : (st : State) → st₀ ↦* st → let (A , B , c) = getℂ st₀ (st-is-initial⇒st≢⊠ st₀ init)
                                      in (Σ[ v ∈ ⟦ A ⟧ ] st₀ ↦* ⟨ c ∣ v ∣ ☐ ⟩◁)
                                       ⊎ (Σ[ v ∈ ⟦ B ⟧ ] st₀ ↦* ［ c ∣ v ∣ ☐ ］▷)
                                       ⊎  st₀ ↦* ⊠
    run' st rs with step st
    ... | inj₁ (st' , r) = run' st' (rs ++↦ (r ∷ ◾))
    ... | inj₂ stuck     with Stuck stuck
    ... | inj₁ (A , B , c , v , refl) with ℂInvariant* rs (st-is-initial⇒st≢⊠ st₀ init) (λ ())
    ... | refl = inj₁ (v , rs)
    run' st rs | inj₂ stuck | inj₂ (inj₁ (A , B , c , v , refl)) with ℂInvariant* rs (st-is-initial⇒st≢⊠ st₀ init) (λ ())
    ... | refl = inj₂ (inj₁ (v , rs))
    run' st rs | inj₂ stuck | inj₂ (inj₂ refl) = inj₂ (inj₂ rs)

-- Forward evaluator of PiQ
eval : ∀ {A B} → (A ↔ B) → Val A B → Maybe (Val B A)
eval c (v ⃗) = [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ (run ⟨ c ∣ v ∣ ☐ ⟩▷ (λ ()))
eval c (v ⃖) = [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ (run ［ c ∣ v ∣ ☐ ］◁ (λ ()))

-- Backward evaluator of PiQ
evalᵣₑᵥ : ∀ {A B} → (A ↔ B) → Val B A → Maybe (Val A B)
evalᵣₑᵥ c (v ⃖) = [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ (run ⟨ c ∣ v ∣ ☐ ⟩▷ (λ ()))
evalᵣₑᵥ c (v ⃗) = [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ (run ［ c ∣ v ∣ ☐ ］◁ (λ ()))

-- Evaluator which generate execution traces
convert↦ : ∀ {st st'} → st ↦* st' → List State
convert↦ (◾ {st}) = st L.∷ []
convert↦ (_∷_ {st} r rs) = st L.∷ convert↦ rs

evalₜᵣ : ∀ {A B} → (A ↔ B) → ⟦ A ⟧ → List State
evalₜᵣ c v with (run ⟨ c ∣ v ∣ ☐ ⟩▷ (λ ()))
... | inj₁ (_ , rs) = convert↦ rs
... | inj₂ (inj₁ (_ , rs)) = convert↦ rs
... | inj₂ (inj₂ rs) = convert↦ rs

-- Faster evaluator which does not carry the reduction trace.
-- Returns the result and the number of steps it takes
{-# TERMINATING #-}
eval' : ∀ {A B} → (A ↔ B) → ⟦ A ⟧ → Maybe (Σ[ t ∈ 𝕌 ] ⟦ t ⟧) × ℕ
eval' c v = run' ⟨ c ∣ v ∣ ☐ ⟩▷ 0
  where
  getV : State → Maybe (Σ[ t ∈ 𝕌 ] ⟦ t ⟧)
  getV ⟨ _ ∣ v ∣ _ ⟩▷ = just (_ , v)
  getV ［ _ ∣ v ∣ _ ］▷ = just (_ , v)
  getV ⟨ _ ∣ v ∣ _ ⟩◁ = just (_ , v)
  getV ［ _ ∣ v ∣ _ ］◁ = just (_ , v)
  getV ⊠ = nothing

  run' : State → ℕ → Maybe (Σ[ t ∈ 𝕌 ] ⟦ t ⟧) × ℕ
  run' st n with step st
  ... | inj₁ (st' , _) = run' st' (suc n)
  ... | inj₂ stuck     = getV st , n


------------------------------------------------------------------------
-- The Agda standard library
--
-- A different interface to the Kleene lists, designed to mimic
-- Data.List.
------------------------------------------------------------------------

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

module Data.List.Kleene.AsList where

open import Level as Level using (Level)

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

import Data.List.Kleene.Base as Kleene

------------------------------------------------------------------------
-- Here we import half of the functions from Data.KleeneList: the half
-- for possibly-empty lists.

open import Data.List.Kleene.Base public
  using ([])
  renaming
    ( _*                 to List
    ; foldr*             to foldr
    ; foldl*             to foldl
    ; _++*_              to _++_
    ; map*               to map
    ; mapMaybe*          to mapMaybe
    ; pure*              to pure
    ; _<*>*_             to _<*>_
    ; _>>=*_             to _>>=_
    ; mapAccumˡ*         to mapAccumˡ
    ; mapAccumʳ*         to mapAccumʳ
    ; _[_]*              to _[_]
    ; applyUpTo*         to applyUpTo
    ; upTo*              to upTo
    ; zipWith*           to zipWith
    ; unzipWith*         to unzipWith
    ; partitionSumsWith* to partitionSumsWith
    ; reverse*           to reverse
    )

------------------------------------------------------------------------
-- A pattern which mimics Data.List._∷_

infixr 5 _∷_
pattern _∷_ x xs = Kleene.∹ x Kleene.& xs

------------------------------------------------------------------------
-- The following functions change the type of the list (from ⁺ to * or vice
-- versa) in Data.KleeneList, so we reimplement them here to keep the
-- type the same.

scanr : (A → B → B) → B → List A → List B
scanr f b xs = Kleene.∹ Kleene.scanr* f b xs

scanl : (B → A → B) → B → List A → List B
scanl f b xs = Kleene.∹ Kleene.scanl* f b xs

tails : List A → List (List A)
tails xs = foldr (λ x xs → (Kleene.∹ x) ∷ xs) ([] ∷ []) (Kleene.tails* xs)


open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

record Eta : Set where
  constructor _,_
  field fst : Nat
        snd : Nat

open Eta

data ⊥ : Set where

hard-fail : (a : Eta) (x : Nat) → (fst a , x) ≡ a → ⊥
hard-fail a x ()  -- Should be error (refl is valid)

loop : ⊥
loop = hard-fail (0 , 0) 0 refl


------------------------------------------------------------------------
-- A compiler
------------------------------------------------------------------------

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

module Lambda.Simplified.Compiler where

open import Equality.Propositional.Cubical
open import Prelude

open import Vec.Function equality-with-J

open import Lambda.Simplified.Syntax
open import Lambda.Simplified.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

-- The compiler (which takes a code continuation).

comp : ∀ {n} → Tm n → Code n → Code n
comp (var x)   c = var x ∷ c
comp (ƛ t)     c = clo (comp t (ret ∷ [])) ∷ c
comp (t₁ · t₂) c = comp t₁ (comp t₂ (app ∷ c))

-- Environments and values can also be compiled.

mutual

  comp-env : ∀ {n} → T.Env n → C.Env n
  comp-env ρ n = comp-val (ρ n)

  comp-val : T.Value → C.Value
  comp-val (T.ƛ t ρ) = C.ƛ (comp t (ret ∷ [])) (comp-env ρ)

-- Compilation takes empty environments to empty environments.

comp-nil : comp-env nil ≡ nil
comp-nil = empty≡nil ext

-- Compilation commutes with cons.

comp-cons : ∀ {n} {ρ : T.Env n} {v} →
            comp-env (cons v ρ) ≡ cons (comp-val v) (comp-env ρ)
comp-cons = non-empty≡cons-head-tail ext _


{-# OPTIONS --type-in-type
            --guardedness-preserving-type-constructors #-}

module Issue690b where

open import Common.Coinduction

data Rec (A : ∞ Set) : Set where
  fold : (x : ♭ A) → Rec A

infixr 4 _,_

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

infix 4 _≡_

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

data ⊥ : Set where

{-# NON_TERMINATING #-}
D : Set
D = Rec (♯ Σ Set λ E → Σ (D ≡ E) λ _ → E → ⊥)

lam : (D → ⊥) → D
lam f = fold (D , refl , f)

app : D → D → ⊥
app (fold (.D , refl , f)) d = f d

omega : D
omega = lam (λ x → app x x)

Omega : ⊥
Omega = app omega omega


module Isos.TreeLike where

open import Isos.Isomorphism

open import Trees
open import Tuples
open import Equality

open import Data.Product
open import Data.Unit

------------------------------------------------------------------------
-- internal stuffs

private

  pattern ∅ = Empty tt
  ∅′ : BareBinTree
  ∅′ = Empty tt
  _,,_ : BareBinTree → BareBinTree → BareBinTree
  _,,_ = Node tt
  infixl 4 _,,_
  pattern [_,_] a b = Node tt a b

  tree⁷->tree : BareBinTree ⁷ → BareBinTree
  tree⁷->tree (∅ , ∅ , ∅ , ∅ , ∅ , ∅ , [ [ [ [ a , b ] , c ] , d ] , e ])
              = ∅′ ,, a ,, b ,, c ,, d ,, e
  tree⁷->tree (∅  , ∅  , ∅  , ∅  , ∅  , ∅  , a) = a
  tree⁷->tree (∅  , ∅  , ∅  , ∅  , ∅  , t₅ , t₆)
              = t₅ ,, t₆ ,, ∅′ ,, ∅′ ,, ∅′ ,, ∅′ ,, ∅′
  tree⁷->tree (∅  , ∅  , ∅  , ∅  , [ a , b ] , t₅ , t₆)
              = ∅′ ,, t₆ ,, t₅ ,, a ,, b
  tree⁷->tree (t₀ , t₁ , t₂ , t₃ , t₄ , t₅ , t₆)
              = t₆ ,, t₅ ,, t₄ ,, t₃ ,, t₂ ,, t₁ ,, t₀

  tree->tree⁷ : BareBinTree → BareBinTree ⁷
  tree->tree⁷ [ [ [ [ [ ∅ , a ] , b ] , c ] , d ] , e ]
              = ∅ , ∅ , ∅ , ∅ , ∅ , ∅ , (a ,, b ,, c ,, d ,, e)
  tree->tree⁷ [ [ [ [ [ t₆ , t₅ ] , ∅ ] , ∅ ] , ∅ ] , ∅ ]
              = ∅ , ∅ , ∅ , ∅ , ∅ , t₅ , t₆
  tree->tree⁷ [ [ [ [ ∅ , t₆ ] , t₅ ] , a ] , b ]
              = ∅ , ∅ , ∅ , ∅ , (a ,, b) , t₅ , t₆
  tree->tree⁷ [ [ [ [ [ [ t₆ , t₅ ] , t₄ ] , t₃ ] , t₂ ] , t₁ ] , t₀ ]
              = t₀ , t₁ , t₂ , t₃ , t₄ , t₅ , t₆
  tree->tree⁷ a = ∅ , ∅ , ∅ , ∅ , ∅ , ∅ , a

  tree⁷<=>tree : BareBinTree ⁷ ⇔ BareBinTree
  tree⁷<=>tree = ∧-intro tree⁷->tree tree->tree⁷

  -- too hard
  -- proofL : ∀ tree → tree⁷->tree (tree->tree⁷ tree) ≡ tree
  -- proofL [ [ [ [ [ ∅ , a ] , b ] , c ] , d ] , e ]
  --        = refl
  -- proofL [ [ [ [ [ Node x t₆ t7 , t₅ ] , ∅ ] , ∅ ] , ∅ ] , ∅ ]
  --        = {!!}
  -- proofL [ [ [ [ ∅ , t₆ ] , t₅ ] , a ] , b ]
  --        = refl
  -- proofL [ [ [ [ [ [ t₆ , t₅ ] , t₄ ] , t₃ ] , t₂ ] , t₁ ] , t₀ ]
  --        = {!!}
  -- proofL _ = {!!}

------------------------------------------------------------------------
-- public aliases

iso-seven-tree-in-one : BareBinTree ⁷ ⇔ BareBinTree
iso-seven-tree-in-one = tree⁷<=>tree


-- Andreas, 2018-06-14, issue #2513, surviving shape-irrelevance annotations.

record Foo (A : Set) : Set where
  field
    @shape-irrelevant foo : A

test : ∀ A → Foo A → A
test A = Foo.foo