------------------------------------------------------------------------
-- The Agda standard library
--
-- An example of how Data.Fin.Substitution can be used: a definition
-- of substitution for the untyped λ-calculus, along with some lemmas
------------------------------------------------------------------------

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

module Data.Fin.Substitution.Example where

open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Nat
open import Data.Fin using (Fin)
open import Data.Vec
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; sym; cong; cong₂)
open PropEq.≡-Reasoning
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (Star; ε; _◅_)

-- A representation of the untyped λ-calculus. Uses de Bruijn indices.

infixl 9 _·_

data Tm (n : ℕ) : Set where
  var : (x : Fin n) → Tm n
  ƛ   : (t : Tm (suc n)) → Tm n
  _·_ : (t₁ t₂ : Tm n) → Tm n

-- Code for applying substitutions.

module TmApp {ℓ} {T : ℕ → Set ℓ} (l : Lift T Tm) where
  open Lift l hiding (var)

  -- Applies a substitution to a term.

  infix 8 _/_

  _/_ : ∀ {m n} → Tm m → Sub T m n → Tm n
  var x   / ρ = lift (lookup ρ x)
  ƛ t     / ρ = ƛ (t / ρ ↑)
  t₁ · t₂ / ρ = (t₁ / ρ) · (t₂ / ρ)

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

  -- Some lemmas about _/_.

  ƛ-/✶-↑✶ : ∀ k {m n t} (ρs : Subs T m n) →
            ƛ t /✶ ρs ↑✶ k ≡ ƛ (t /✶ ρs ↑✶ suc k)
  ƛ-/✶-↑✶ k ε        = refl
  ƛ-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (ƛ-/✶-↑✶ k ρs) refl

  ·-/✶-↑✶ : ∀ k {m n t₁ t₂} (ρs : Subs T m n) →
            t₁ · t₂ /✶ ρs ↑✶ k ≡ (t₁ /✶ ρs ↑✶ k) · (t₂ /✶ ρs ↑✶ k)
  ·-/✶-↑✶ k ε        = refl
  ·-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (·-/✶-↑✶ k ρs) refl

tmSubst : TermSubst Tm
tmSubst = record { var = var; app = TmApp._/_ }

open TermSubst tmSubst hiding (var)

-- Substitution lemmas.

tmLemmas : TermLemmas Tm
tmLemmas = record
  { termSubst = tmSubst
  ; app-var   = refl
  ; /✶-↑✶     = Lemma./✶-↑✶
  }
  where
  module Lemma {T₁ T₂} {lift₁ : Lift T₁ Tm} {lift₂ : Lift T₂ Tm} where

    open Lifted lift₁ using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
    open Lifted lift₂ using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)

    /✶-↑✶ : ∀ {m n} (ρs₁ : Subs T₁ m n) (ρs₂ : Subs T₂ m n) →
            (∀ k x → var x /✶₁ ρs₁ ↑✶₁ k ≡ var x /✶₂ ρs₂ ↑✶₂ k) →
             ∀ k t → t     /✶₁ ρs₁ ↑✶₁ k ≡ t     /✶₂ ρs₂ ↑✶₂ k
    /✶-↑✶ ρs₁ ρs₂ hyp k (var x) = hyp k x
    /✶-↑✶ ρs₁ ρs₂ hyp k (ƛ t)   = begin
      ƛ t /✶₁ ρs₁ ↑✶₁ k        ≡⟨ TmApp.ƛ-/✶-↑✶ _ k ρs₁ ⟩
      ƛ (t /✶₁ ρs₁ ↑✶₁ suc k)  ≡⟨ cong ƛ (/✶-↑✶ ρs₁ ρs₂ hyp (suc k) t) ⟩
      ƛ (t /✶₂ ρs₂ ↑✶₂ suc k)  ≡⟨ sym (TmApp.ƛ-/✶-↑✶ _ k ρs₂) ⟩
      ƛ t /✶₂ ρs₂ ↑✶₂ k        ∎
    /✶-↑✶ ρs₁ ρs₂ hyp k (t₁ · t₂) = begin
      t₁ · t₂ /✶₁ ρs₁ ↑✶₁ k                    ≡⟨ TmApp.·-/✶-↑✶ _ k ρs₁ ⟩
      (t₁ /✶₁ ρs₁ ↑✶₁ k) · (t₂ /✶₁ ρs₁ ↑✶₁ k)  ≡⟨ cong₂ _·_ (/✶-↑✶ ρs₁ ρs₂ hyp k t₁)
                                                            (/✶-↑✶ ρs₁ ρs₂ hyp k t₂) ⟩
      (t₁ /✶₂ ρs₂ ↑✶₂ k) · (t₂ /✶₂ ρs₂ ↑✶₂ k)  ≡⟨ sym (TmApp.·-/✶-↑✶ _ k ρs₂) ⟩
      t₁ · t₂ /✶₂ ρs₂ ↑✶₂ k                    ∎

open TermLemmas tmLemmas public hiding (var)


module DTGP.State where
open import Data.Product

infixl 1 _>>=_ _=<<_

data State (S A : Set) : Set where
  state : (S → A × S) → State S A

runState : ∀ {S A} → State S A → S → A × S
runState (state f) = f

return : ∀ {S A} → A → State S A
return a = state (λ s → a , s)

_>>=_ : {S A B : Set} → State S A → (A → State S B) → State S B
state h >>= f = state λ s →
  let a,newState = h s
      stateg = f (proj₁ a,newState)
  in
  runState stateg (proj₂ a,newState)

_=<<_ : {S A B : Set} → (A → State S B) → State S A → State S B
f =<< stateh = stateh >>= f


{-# OPTIONS --without-K --safe #-}
module Source.Term where

open import Source.Size as S using
  ( Size ; _<_ ; Δ ; Δ′ ; Δ″ ; Ω ; Ω′ ; Ω″ ; n ; m ; o ; b ; v0 ; v1 ; ⋆ )
open import Source.Size.Substitution.Theory
open import Source.Size.Substitution.Canonical as SC using () renaming
  ( Sub⊢ to Subₛ⊢ )
open import Source.Size.Substitution.Universe as SU using
  ( ⟨_⟩ ) renaming
  ( Sub⊢ᵤ to Subₛ⊢ᵤ )
open import Source.Type as T using
  ( Type ; Ctx ; T ; U ; V ; Γ ; Γ′ ; Γ″ ; Ψ ; Ψ′ ; Ψ″ ; SubTheory-Type
  ; SubTheory-Ctx )
open import Util.Prelude hiding (id ; _∘_)

open Ctx
open S.Ctx
open S.Size
open S.Var
open Type

infix  0 _,_⊢_∶_ _,_⊢ₓ_∶_ Sub⊢
infix  3 _⊇_
infixl 5 sub-syntax-Termₛ sub-syntax-Subₛ sub-syntax-Term sub-syntax-⊇
infixr 6 Λ_,_ Λₛ_,_
infixl 7 _·_ _·ₛ_

Var : Set
Var = ℕ

variable x y : Var

data Term Δ : Set where
  var : (x : Var) → Term Δ
  Λ_,_ : (T : Type Δ) (t : Term Δ) → Term Δ
  _·_ : (t u : Term Δ) → Term Δ
  Λₛ_,_ : (n : Size Δ) (t : Term (Δ ∙ n)) → Term Δ
  _·ₛ_ : (t : Term Δ) (m : Size Δ) → Term Δ
  zero : (n : Size Δ) → Term Δ
  suc : (n m : Size Δ) (i : Term Δ) → Term Δ
  cons : (i : Term Δ) (n : Size Δ) (is : Term Δ) → Term Δ
  head : (n : Size Δ) (is : Term Δ) → Term Δ
  tail : (n : Size Δ) (is : Term Δ) (m : Size Δ) → Term Δ
  caseNat : (T : Type Δ) (n : Size Δ) (i : Term Δ) (z : Term Δ) (s : Term Δ)
    → Term Δ
  fix : (T : Type (Δ ∙ ⋆)) (t : Term Δ) (n : Size Δ) → Term Δ

variable t u v w i is z s t′ u′ v′ w′ i′ is′ z′ s′ : Term Δ

data _,_⊢ₓ_∶_ : ∀ Δ (Γ : Ctx Δ) (x : Var) (T : Type Δ) → Set where
  zero
    : Δ , Γ ∙ T ⊢ₓ zero ∶ T
  suc
    : (⊢x : Δ , Γ ⊢ₓ x ∶ T)
    → Δ , Γ ∙ U ⊢ₓ suc x ∶ T

data _,_⊢_∶_ : ∀ Δ (Γ : Ctx Δ) (t : Term Δ) (T : Type Δ) → Set where
  var
    : (⊢x : Δ , Γ ⊢ₓ x ∶ T)
    → Δ , Γ ⊢ var x ∶ T
  abs
    : (⊢t : Δ , Γ ∙ T ⊢ t ∶ U)
    → Δ , Γ ⊢ Λ T , t ∶ T ⇒ U
  app
    : (⊢t : Δ , Γ ⊢ t ∶ T ⇒ U)
    → (⊢u : Δ , Γ ⊢ u ∶ T)
    → Δ , Γ ⊢ t · u ∶ U
  absₛ
    : (⊢t : Δ ∙ n , Ψ ⊢ t ∶ T)
    → Ψ ≡ Γ [ SC.Wk ]
    → Δ , Γ ⊢ Λₛ n , t ∶ Π n , T
  appₛ
    : (m<n : m < n)
    → (⊢t : Δ , Γ ⊢ t ∶ (Π n , T))
    → U ≡ T [ SC.Sing m ]
    → Δ , Γ ⊢ t ·ₛ m ∶ U
  zero
    : (n<⋆ : n < ⋆)
    → Δ , Γ ⊢ zero n ∶ Nat n
  suc
    : (n<⋆ : n < ⋆)
    → (m<n : m < n)
    → (⊢i : Δ , Γ ⊢ i ∶ Nat m)
    → Δ , Γ ⊢ suc n m i ∶ Nat n
  cons
    : (n<⋆ : n < ⋆)
    → (⊢i : Δ , Γ ⊢ i ∶ Nat ∞)
    → (⊢is : Δ , Γ ⊢ is ∶ Π n , Stream v0)
    → Δ , Γ ⊢ cons i n is ∶ Stream n
  head
    : (n<⋆ : n < ⋆)
    → (⊢is : Δ , Γ ⊢ is ∶ Stream n)
    → Δ , Γ ⊢ head n is ∶ Nat ∞
  tail
    : (n<⋆ : n < ⋆)
    → (m<n : m < n)
    → (⊢is : Δ , Γ ⊢ is ∶ Stream n)
    → Δ , Γ ⊢ tail n is m ∶ Stream m
  caseNat
    : (n<⋆ : n < ⋆)
    → (⊢i : Δ , Γ ⊢ i ∶ Nat n)
    → (⊢z : Δ , Γ ⊢ z ∶ T)
    → (⊢s : Δ , Γ ⊢ s ∶ Π n , Nat v0 ⇒ U)
    → U ≡ T [ SC.Wk ]
    → Δ , Γ ⊢ caseNat T n i z s ∶ T
  fix
    : (n<⋆ : n < ⋆)
    → (⊢t : Δ , Γ ⊢ t ∶ Π ⋆ , (Π v0 , U) ⇒ T)
    → U ≡ T [ SC.Skip ]
    → V ≡ T [ SC.Sing n ]
    → Δ , Γ ⊢ fix T t n ∶ V

subₛ : SC.Sub Δ Ω → Term Ω → Term Δ
subₛ σ (var x) = var x
subₛ σ (Λ T , t) = Λ T [ σ ] , subₛ σ t
subₛ σ (t · u) = subₛ σ t · subₛ σ u
subₛ σ (Λₛ n , t) = Λₛ n [ σ ] , subₛ (SC.Lift σ) t
subₛ σ (t ·ₛ m) = subₛ σ t ·ₛ (m [ σ ])
subₛ σ (zero n) = zero (n [ σ ])
subₛ σ (suc n m i) = suc (n [ σ ]) (m [ σ ]) (subₛ σ i)
subₛ σ (cons i n is) = cons (subₛ σ i) (n [ σ ]) (subₛ σ is)
subₛ σ (head n is) = head (n [ σ ]) (subₛ σ is)
subₛ σ (tail n is m) = tail (n [ σ ]) (subₛ σ is) (m [ σ ])
subₛ σ (caseNat T n i z s)
  = caseNat (T [ σ ]) (n [ σ ]) (subₛ σ i) (subₛ σ z) (subₛ σ s)
subₛ σ (fix T t n) = fix (T [ SC.Lift σ ]) (subₛ σ t) (n [ σ ])

sub-syntax-Termₛ = subₛ

syntax sub-syntax-Termₛ σ t = t [ σ ]ₛ

abstract
  subₛ-resp-⊢ₓ : ∀ {σ}
    → σ ∶ Δ ⇒ Ω
    → Ω , Γ ⊢ₓ x ∶ T
    → Δ , Γ [ σ ] ⊢ₓ x ∶ T [ σ ]
  subₛ-resp-⊢ₓ ⊢σ zero = zero
  subₛ-resp-⊢ₓ ⊢σ (suc ⊢x) = suc (subₛ-resp-⊢ₓ ⊢σ ⊢x)

  subₛ-resp-⊢ : ∀ {σ}
    → σ ∶ Δ ⇒ Ω
    → Ω , Γ ⊢ t ∶ T
    → Δ , Γ [ σ ] ⊢ subₛ σ t ∶ T [ σ ]
  subₛ-resp-⊢ ⊢σ (var ⊢x) = var (subₛ-resp-⊢ₓ ⊢σ ⊢x)
  subₛ-resp-⊢ ⊢σ (abs ⊢t) = abs (subₛ-resp-⊢ ⊢σ ⊢t)
  subₛ-resp-⊢ ⊢σ (app ⊢t ⊢u) = app (subₛ-resp-⊢ ⊢σ ⊢t) (subₛ-resp-⊢ ⊢σ ⊢u)
  subₛ-resp-⊢ {Δ} {Γ = Γ} {σ = σ} ⊢σ (absₛ {Ψ = Ψ} ⊢t p)
    = absₛ (subₛ-resp-⊢ (SC.Lift⊢ ⊢σ refl) ⊢t) eq
    where
      eq : Ψ [ SC.Lift σ ] ≡ Γ [ σ ] [ SC.Wk ]
      eq = trans (cong (λ Ψ → Ψ [ SC.Lift σ ]) p)
        ([>>]″ (SC.Lift σ) SC.Wk SC.Wk σ Γ SC.Lift>>Wk)
  subₛ-resp-⊢ {σ = σ} ⊢σ (appₛ {m = m} {T = T} {U = U} m<n ⊢t p)
    = appₛ (SC.sub-resp-< ⊢σ m<n) (subₛ-resp-⊢ ⊢σ ⊢t) eq
    where
      eq : U [ σ ] ≡ T [ SC.Lift σ ] [ SC.Sing (m [ σ ]) ]
      eq = trans (cong (λ U → U [ σ ]) p)
        ([>>]″ _ _ _ _ _ (sym (SC.Sing>>Lift m)))
  subₛ-resp-⊢ ⊢σ (zero n<⋆)
    = zero (SC.sub-resp-< ⊢σ n<⋆)
  subₛ-resp-⊢ ⊢σ (suc n<⋆ m<n ⊢i)
    = suc (SC.sub-resp-< ⊢σ n<⋆) (SC.sub-resp-< ⊢σ m<n) (subₛ-resp-⊢ ⊢σ ⊢i)
  subₛ-resp-⊢ ⊢σ (cons n<⋆ ⊢i ⊢is)
    = cons (SC.sub-resp-< ⊢σ n<⋆) (subₛ-resp-⊢ ⊢σ ⊢i) (subₛ-resp-⊢ ⊢σ ⊢is)
  subₛ-resp-⊢ ⊢σ (head n<⋆ ⊢is)
    = head (SC.sub-resp-< ⊢σ n<⋆) (subₛ-resp-⊢ ⊢σ ⊢is)
  subₛ-resp-⊢ ⊢σ (tail n<⋆ m<n ⊢is)
    = tail (SC.sub-resp-< ⊢σ n<⋆) (SC.sub-resp-< ⊢σ m<n) (subₛ-resp-⊢ ⊢σ ⊢is)
  subₛ-resp-⊢ {σ = σ} ⊢σ (caseNat {T = T} {U = U} n<⋆ ⊢i ⊢z ⊢s p)
    = caseNat (SC.sub-resp-< ⊢σ n<⋆) (subₛ-resp-⊢ ⊢σ ⊢i) (subₛ-resp-⊢ ⊢σ ⊢z)
        (subₛ-resp-⊢ ⊢σ ⊢s) eq
    where
      eq : U [ SC.Lift σ ] ≡ T [ σ ] [ SC.Wk ]
      eq = trans (cong (λ U → U [ SC.Lift σ ]) p)
        ([>>]″ _ _ _ _ _ SC.Lift>>Wk)
  subₛ-resp-⊢ {σ = σ} ⊢σ (fix {n = n} {U = U} {T = T} {V = V} n<⋆ ⊢t p q)
    = fix (SC.sub-resp-< ⊢σ n<⋆) (subₛ-resp-⊢ ⊢σ ⊢t) eq₀ eq₁
    where
      eq₀ : U [ SC.Lift (SC.Lift σ) ] ≡ T [ SC.Lift σ ] [ SC.Skip ]
      eq₀ = trans (cong (λ U → U [ SC.Lift (SC.Lift σ) ]) p)
        ([>>]″ _ _ _ _ _ SC.LiftLift>>Skip)

      eq₁ : V [ σ ] ≡ T [ SC.Lift σ ] [ SC.Sing (n [ σ ]) ]
      eq₁ = trans (cong (λ V → V [ σ ]) q)
        ([>>]″ _ _ _ _ _ (sym (SC.Sing>>Lift n)))

  subₛ-Id : (t : Term Δ) → subₛ SC.Id t ≡ t
  subₛ-Id (var x) = refl
  subₛ-Id (Λ T , t) = cong₂ Λ_,_ ([Id] T) (subₛ-Id t)
  subₛ-Id (t · u) = cong₂ _·_ (subₛ-Id t) (subₛ-Id u)
  subₛ-Id (Λₛ n , t)
    rewrite [Id] n | subₛ-Id t
    = refl
  subₛ-Id (t ·ₛ m) = cong₂ _·ₛ_ (subₛ-Id t) ([Id] m)
  subₛ-Id (zero n) = cong zero ([Id] n)
  subₛ-Id (suc n m i)
    rewrite [Id] n | [Id] m | subₛ-Id i
    = refl
  subₛ-Id (cons i n is)
    rewrite subₛ-Id i | [Id] n | subₛ-Id is
    = refl
  subₛ-Id (head n is) = cong₂ head ([Id] n) (subₛ-Id is)
  subₛ-Id (tail n is m)
    rewrite [Id] n | subₛ-Id is | [Id] m
    = refl
  subₛ-Id (caseNat T n i z s)
    rewrite [Id] T | [Id] n | subₛ-Id i | subₛ-Id z | subₛ-Id s
    = refl
  subₛ-Id (fix T t n)
    rewrite [Id] T | subₛ-Id t | [Id] n
    = refl

  subₛ->> : ∀ (σ : SC.Sub Δ Δ′) (τ : SC.Sub Δ′ Δ″) t
    → subₛ (σ SC.>> τ) t ≡ subₛ σ (subₛ τ t)
  subₛ->> σ τ (var x) = refl
  subₛ->> σ τ (Λ T , t) = cong₂ Λ_,_ ([>>] σ τ T) (subₛ->> σ τ t)
  subₛ->> σ τ (t · u) = cong₂ _·_ (subₛ->> σ τ t) (subₛ->> σ τ u)
  subₛ->> σ τ (Λₛ n , t)
    rewrite [>>] σ τ n
    = cong (λ t → Λₛ SC.sub σ (SC.sub τ n) , t)
        (trans (cong (λ σ → subₛ σ t) (sym (SC.Lift>>Lift {n = n [ τ ]})))
          (subₛ->> (SC.Lift σ) (SC.Lift τ) t))
  subₛ->> σ τ (t ·ₛ m)
    = cong₂ _·ₛ_ (subₛ->> σ τ t) ([>>] σ τ m)
  subₛ->> σ τ (zero n) = cong zero ([>>] σ τ n)
  subₛ->> σ τ (suc n m i)
    rewrite [>>] σ τ n | [>>] σ τ m | subₛ->> σ τ i
    = refl
  subₛ->> σ τ (cons i n is)
    rewrite subₛ->> σ τ i | [>>] σ τ n | subₛ->> σ τ is
    = refl
  subₛ->> σ τ (head n is)
    rewrite [>>] σ τ n | subₛ->> σ τ is
    = refl
  subₛ->> σ τ (tail n is m)
    rewrite [>>] σ τ n | subₛ->> σ τ is | [>>] σ τ m
    = refl
  subₛ->> σ τ (caseNat T n i z s)
    rewrite [>>] σ τ T | [>>] σ τ n | subₛ->> σ τ i | subₛ->> σ τ z
      | subₛ->> σ τ s
    = refl
  subₛ->> σ τ (fix T t n)
    rewrite subₛ->> σ τ t | [>>] σ τ n
    = cong (λ T → fix T (subₛ σ (subₛ τ t)) (n [ τ ] [ σ ]))
        ([>>]′ _ _ _ _ (sym SC.Lift>>Lift))

subₛᵤ : SU.Sub Δ Ω → Term Ω → Term Δ
subₛᵤ σ = subₛ ⟨ σ ⟩

abstract
  subₛᵤ-resp-⊢ : ∀ {σ}
    → σ ∶ Δ ⇒ᵤ Ω
    → Ω , Γ ⊢ t ∶ T
    → Δ , Γ [ σ ]ᵤ ⊢ subₛᵤ σ t ∶ T [ σ ]ᵤ
  subₛᵤ-resp-⊢ ⊢σ ⊢t = subₛ-resp-⊢ (SU.⟨⟩-resp-⊢ ⊢σ) ⊢t

  subₛᵤ-Id : (t : Term Δ) → subₛᵤ SU.Id t ≡ t
  subₛᵤ-Id t = subₛ-Id t

  subₛᵤ->> : ∀ (σ : SU.Sub Δ Δ′) (τ : SU.Sub Δ′ Δ″) t
    → subₛᵤ (σ SU.>> τ) t ≡ subₛᵤ σ (subₛᵤ τ t)
  subₛᵤ->> σ τ t = subₛ->> ⟨ σ ⟩ ⟨ τ ⟩ t

data _⊇_ {Δ} : (Γ Ψ : Ctx Δ) → Set where
  [] : [] ⊇ []
  keep : (α : Γ ⊇ Ψ) (T : Type Δ) → Γ ∙ T ⊇ Ψ ∙ T
  weak : (α : Γ ⊇ Ψ) (T : Type Δ) → Γ ∙ T ⊇ Ψ

variable α β γ : Γ ⊇ Ψ

sub⊇ : (σ : SC.Sub Δ Ω) → Γ ⊇ Ψ → Γ [ σ ] ⊇ Ψ [ σ ]
sub⊇ σ [] = []
sub⊇ σ (keep α T) = keep (sub⊇ σ α) (T [ σ ])
sub⊇ σ (weak α T) = weak (sub⊇ σ α) (T [ σ ])

sub-syntax-⊇ = sub⊇

syntax sub-syntax-⊇ σ α = α [ σ ]α

renV : Γ ⊇ Ψ → Var → Var
renV [] x = x -- impossible if x is well-scoped
renV (keep α T) zero = zero
renV (keep α T) (suc x) = suc (renV α x)
renV (weak α T) x = suc (renV α x)

ren : {Γ Ψ : Ctx Δ} → Γ ⊇ Ψ → Term Δ → Term Δ
ren α (var x) = var (renV α x)
ren α (Λ T , t) = Λ T , ren (keep α T) t
ren α (t · u) = ren α t · ren α u
ren α (Λₛ n , t) = Λₛ n , ren (α [ SC.Wk ]α) t
ren α (t ·ₛ m) = ren α t ·ₛ m
ren α (zero n) = zero n
ren α (suc n m i) = suc n m (ren α i)
ren α (cons i n is) = cons (ren α i) n (ren α is)
ren α (head n is) = head n (ren α is)
ren α (tail n is m) = tail n (ren α is) m
ren α (caseNat T n i z s) = caseNat T n (ren α i) (ren α z) (ren α s)
ren α (fix T t n) = fix T (ren α t) n

abstract
  renV-resp-⊢ₓ
    : (α : Γ ⊇ Ψ)
    → Δ , Ψ ⊢ₓ x ∶ T
    → Δ , Γ ⊢ₓ renV α x ∶ T
  renV-resp-⊢ₓ (keep α T) zero = zero
  renV-resp-⊢ₓ (keep α T) (suc ⊢x) = suc (renV-resp-⊢ₓ α ⊢x)
  renV-resp-⊢ₓ (weak α T) ⊢x = suc (renV-resp-⊢ₓ α ⊢x)

  ren-resp-⊢
    : (α : Γ ⊇ Ψ)
    → Δ , Ψ ⊢ t ∶ T
    → Δ , Γ ⊢ ren α t ∶ T
  ren-resp-⊢ α (var ⊢x) = var (renV-resp-⊢ₓ α ⊢x)
  ren-resp-⊢ α (abs ⊢t)
    = abs (ren-resp-⊢ (keep α _) ⊢t)
  ren-resp-⊢ α (app ⊢t ⊢u) = app (ren-resp-⊢ α ⊢t) (ren-resp-⊢ α ⊢u)
  ren-resp-⊢ α (absₛ ⊢t refl)
    = absₛ (ren-resp-⊢ (α [ SC.Wk ]α) ⊢t) refl
  ren-resp-⊢ α (appₛ m<n ⊢t p) = appₛ m<n (ren-resp-⊢ α ⊢t) p
  ren-resp-⊢ α (zero n<⋆) = zero n<⋆
  ren-resp-⊢ α (suc n<⋆ m<n ⊢i) = suc n<⋆ m<n (ren-resp-⊢ α ⊢i)
  ren-resp-⊢ α (cons n<⋆ ⊢i ⊢is)
    = cons n<⋆ (ren-resp-⊢ α ⊢i) (ren-resp-⊢ α ⊢is)
  ren-resp-⊢ α (head n<⋆ ⊢is) = head n<⋆ (ren-resp-⊢ α ⊢is)
  ren-resp-⊢ α (tail n<⋆ m<n ⊢is) = tail n<⋆ m<n (ren-resp-⊢ α ⊢is)
  ren-resp-⊢ α (caseNat n<⋆ ⊢i ⊢z ⊢s p)
    = caseNat n<⋆ (ren-resp-⊢ α ⊢i) (ren-resp-⊢ α ⊢z) (ren-resp-⊢ α ⊢s) p
  ren-resp-⊢ α (fix n<⋆ ⊢t p q) = fix n<⋆ (ren-resp-⊢ α ⊢t) p q

Id⊇ : (Γ : Ctx Δ) → Γ ⊇ Γ
Id⊇ [] = []
Id⊇ (Γ ∙ T) = keep (Id⊇ Γ) T

Wk⊇ : ∀ (Γ : Ctx Δ) T → Γ ∙ T ⊇ Γ
Wk⊇ Γ T = weak (Id⊇ Γ) _

data Sub {Δ} (Γ : Ctx Δ) : (Ψ : Ctx Δ) → Set where
  [] : Sub Γ []
  Snoc : (ν : Sub Γ Ψ) (t : Term Δ) → Sub Γ (Ψ ∙ T)

variable ν φ : Sub Γ Ψ

data Sub⊢ {Δ} (Γ : Ctx Δ) : ∀ Ψ → Sub Γ Ψ → Set where
  [] : Sub⊢ Γ [] []
  Snoc : (⊢ν : Sub⊢ Γ Ψ ν) (⊢t : Δ , Γ ⊢ t ∶ T) → Sub⊢ Γ (Ψ ∙ T) (Snoc ν t)

syntax Sub⊢ Γ Ψ ν = ν ∶ Γ ⇛ Ψ

Weaken : Sub Γ Ψ → Sub (Γ ∙ T) Ψ
Weaken [] = []
Weaken {Γ = Γ} {T = T} (Snoc ν t) = Snoc (Weaken ν) (ren (Wk⊇ Γ T) t)

abstract
  Weaken⊢ : ν ∶ Γ ⇛ Ψ → Weaken ν ∶ Γ ∙ T ⇛ Ψ
  Weaken⊢ [] = []
  Weaken⊢ (Snoc ⊢ν ⊢t)
    = Snoc (Weaken⊢ ⊢ν) (ren-resp-⊢ (Wk⊇ _ _) ⊢t)

Lift : Sub Γ Ψ → ∀ T → Sub (Γ ∙ T) (Ψ ∙ T)
Lift σ T = Snoc (Weaken σ) (var zero)

abstract
  Lift⊢ : ν ∶ Γ ⇛ Ψ → Lift ν T ∶ Γ ∙ T ⇛ Ψ ∙ T
  Lift⊢ ⊢ν = Snoc (Weaken⊢ ⊢ν) (var zero)

Id : Sub Γ Γ
Id {Γ = []} = []
Id {Γ = Γ ∙ T} = Lift Id T

abstract
  Id⊢ : Id ∶ Γ ⇛ Γ
  Id⊢ {Γ = []} = []
  Id⊢ {Γ = Γ ∙ T} = Snoc (Weaken⊢ Id⊢) (var zero)

Wk : Sub (Γ ∙ T) Γ
Wk = Weaken Id

abstract
  Wk⊢ : Wk ∶ Γ ∙ T ⇛ Γ
  Wk⊢ = Weaken⊢ Id⊢

Fill : ∀ (Γ : Ctx Δ) T → Term Δ → Sub Γ (Γ ∙ T)
Fill Γ T t = Snoc Id t

abstract
  Fill⊢ : Δ , Γ ⊢ t ∶ T → Fill Γ T t ∶ Γ ⇛ Γ ∙ T
  Fill⊢ ⊢t = Snoc Id⊢ ⊢t

subν : (σ : SC.Sub Δ Ω) → Sub Γ Ψ → Sub (Γ [ σ ]) (Ψ [ σ ])
subν σ [] = []
subν σ (Snoc ν t) = Snoc (subν σ ν) (t [ σ ]ₛ)

abstract
  subν-resp-⊢ : ∀ {σ} → σ ∶ Δ ⇒ Ω → ν ∶ Γ ⇛ Ψ → subν σ ν ∶ Γ [ σ ] ⇛ Ψ [ σ ]
  subν-resp-⊢ ⊢σ [] = []
  subν-resp-⊢ ⊢σ (Snoc ⊢ν ⊢t) = Snoc (subν-resp-⊢ ⊢σ ⊢ν) (subₛ-resp-⊢ ⊢σ ⊢t)

sub-syntax-Subₛ = subν

syntax sub-syntax-Subₛ σ ν = ν [ σ ]ν

subV : Sub {Δ} Γ Ψ → Var → Term Δ
subV [] x = var x -- impossible if x is well-scoped
subV (Snoc ν t) zero = t
subV (Snoc ν t) (suc x) = subV ν x

sub : Sub {Δ} Γ Ψ → Term Δ → Term Δ
sub ν (var x) = subV ν x
sub ν (Λ T , t) = Λ T , sub (Lift ν T) t
sub ν (t · u) = sub ν t · sub ν u
sub ν (Λₛ n , t) = Λₛ n , sub (ν [ SC.Wk ]ν) t
sub ν (t ·ₛ m) = sub ν t ·ₛ m
sub ν (zero n) = zero n
sub ν (suc n m i) = suc n m (sub ν i)
sub ν (cons i n is) = cons (sub ν i) n (sub ν is)
sub ν (head n is) = head n (sub ν is)
sub ν (tail n is m) = tail n (sub ν is) m
sub ν (caseNat T n i z s) = caseNat T n (sub ν i) (sub ν z) (sub ν s)
sub ν (fix T t n) = fix T (sub ν t) n

sub-syntax-Term = sub

syntax sub-syntax-Term ν t = t [ ν ]t

abstract
  subV-resp-⊢
    : ν ∶ Γ ⇛ Ψ
    → Δ , Ψ ⊢ₓ x ∶ T
    → Δ , Γ ⊢ subV ν x ∶ T
  subV-resp-⊢ (Snoc ⊢ν ⊢t) zero = ⊢t
  subV-resp-⊢ (Snoc ⊢ν ⊢t) (suc ⊢x) = subV-resp-⊢ ⊢ν ⊢x

  sub-resp-⊢
    : ν ∶ Γ ⇛ Ψ
    → Δ , Ψ ⊢ t ∶ T
    → Δ , Γ ⊢ sub ν t ∶ T
  sub-resp-⊢ ⊢ν (var ⊢x)
    = subV-resp-⊢ ⊢ν ⊢x
  sub-resp-⊢ ⊢ν (abs ⊢t)
    = abs (sub-resp-⊢ (Lift⊢ ⊢ν) ⊢t)
  sub-resp-⊢ ⊢ν (app ⊢t ⊢u)
    = app (sub-resp-⊢ ⊢ν ⊢t) (sub-resp-⊢ ⊢ν ⊢u)
  sub-resp-⊢ ⊢ν (absₛ ⊢t refl)
    = absₛ (sub-resp-⊢ (subν-resp-⊢ SC.Wk⊢ ⊢ν) ⊢t) refl
  sub-resp-⊢ ⊢ν (appₛ m<n ⊢t p)
    = appₛ m<n (sub-resp-⊢ ⊢ν ⊢t) p
  sub-resp-⊢ ⊢ν (zero n<⋆)
    = zero n<⋆
  sub-resp-⊢ ⊢ν (suc n<⋆ m<n ⊢i)
    = suc n<⋆ m<n (sub-resp-⊢ ⊢ν ⊢i)
  sub-resp-⊢ ⊢ν (cons n<⋆ ⊢i ⊢is)
    = cons n<⋆ (sub-resp-⊢ ⊢ν ⊢i) (sub-resp-⊢ ⊢ν ⊢is)
  sub-resp-⊢ ⊢ν (head n<⋆ ⊢is)
    = head n<⋆ (sub-resp-⊢ ⊢ν ⊢is)
  sub-resp-⊢ ⊢ν (tail n<⋆ m<n ⊢is)
    = tail n<⋆ m<n (sub-resp-⊢ ⊢ν ⊢is)
  sub-resp-⊢ ⊢ν (caseNat n<⋆ ⊢i ⊢z ⊢s p)
    = caseNat n<⋆ (sub-resp-⊢ ⊢ν ⊢i) (sub-resp-⊢ ⊢ν ⊢z) (sub-resp-⊢ ⊢ν ⊢s) p
  sub-resp-⊢ ⊢ν (fix n<⋆ ⊢t p q)
    = fix n<⋆ (sub-resp-⊢ ⊢ν ⊢t) p q


module Function.DomainRaise where

open import Data
open import Data.Boolean
import      Functional as Fn
import      Lvl
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Syntax.Number
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T X Y Z : Type{ℓ}
private variable n : ℕ

-- Repeated function type like an n-ary operator.
-- Examples:
--   (a →̂ b)(0) = (b)
--   (a →̂ b)(1) = (a → b)
--   (a →̂ b)(2) = (a → a → b)
--   (a →̂ b)(3) = (a → a → a → b)
--   (a →̂ b)(4) = (a → a → a → a → b)
_→̂_ : Type{ℓ₁} → Type{ℓ₂} → (n : ℕ) → Type{if positive?(n) then (ℓ₁ Lvl.⊔ ℓ₂) else ℓ₂} -- TODO: Is the level thing really working?
(A →̂ B)(𝟎)       = B
(A →̂ B)(𝐒(𝟎))    = A → B
(A →̂ B)(𝐒(𝐒(n))) = A → (A →̂ B)(𝐒(n))

open import Data.Tuple
open import Data.Tuple.Raise

apply₁ : let _ = n in X → (X →̂  Y)(𝐒(n)) → (X →̂  Y)(n)
apply₁ {𝟎}   = Fn.apply
apply₁ {𝐒 _} = Fn.apply

apply₊ : let _ = n in (X ^ n) → (X →̂  Y)(n) → Y
apply₊ {𝟎}       <>        f = f
apply₊ {𝐒(𝟎)}    x         f = f(x)
apply₊ {𝐒(𝐒(n))} (x , xs)  f = apply₊ {𝐒(n)} xs (f(x))

-- Applies the same argument on all arguments.
-- Examples:
--   f : (a →̂ b)(5)
--   applyRepeated{0} f(x) = f
--   applyRepeated{1} f(x) = f(x)
--   applyRepeated{2} f(x) = f(x)(x)
--   applyRepeated{3} f(x) = f(x)(x)(x)
--   applyRepeated{2}(applyRepeated{3} f(x)) (y) = f(x)(x)(y)(y)(y)
applyRepeated : let _ = n in (X →̂ Y)(n) → (X → Y)
applyRepeated{𝟎}       f(x) = f
applyRepeated{𝐒(𝟎)}    f(x) = f(x)
applyRepeated{𝐒(𝐒(n))} f(x) = applyRepeated{𝐒(n)} (f(x)) (x)

{-
  -- Applies arguments from a function.
  -- Almost (not really) like a composition operation.
  -- Examples:
  --   f : (a →̂ b)(3)
  --   applyFn f g = f (g(2)) (g(1)) (g(0))
  applyFn : ∀{n}{T₁}{T₂} → (T₁ →̂ T₂)(n) → (𝕟(n) → T₁) → T₂
  applyFn{𝟎}    f g = f
  applyFn{𝐒(n)} f g = applyFn{n} (f(g(ℕ-to-𝕟 (n) {𝐒(n)} ⦃ [<?]-𝐒 {n} ⦄))) (g ∘ (bound-𝐒{n}))

  -- TODO: Examples:
  --   swapReverse {3} f (y₂) (y₁) (y₀)
  --   = swapReverse {2} (f(y₂)) (y₁) (y₀)
  --   = swapReverse {1} (f(y₂) (y₁)) (y₀)
  --   = swapReverse {0} (f(y₂) (y₁) (y₀))
  --   = f(y₂) (y₁) (y₀)
  -- swapReverse : ∀{n}{T₁}{T₂} → (T₁ →̂ T₂)(n) → (T₁ →̂ T₂)(n)
  -- swapReverse {𝟎}    y₀   = y₀
  -- swapReverse {𝐒(n)} f(yₙ) = (swapReverse {n} f) ∘ (f(yₙ))

  -- directOp : ∀{n}{X}{Y} → ((X → Y) →̂ ((X ^ n) → (Y ^ n)))(n)
-}

-- Function composition on a multi-argument function (Like PrimitiveRecursion.Composition).
-- Examples:
--   (f ∘₄ g) x₁ x₂ x₃ x₄
--   = (f ∘₃ g x₁) x₂ x₃ x₄
--   = (f ∘₂ g x₁ x₂) x₃ x₄
--   = (f ∘₁ g x₁ x₂ x₃) x₄
--   = (f ∘ g x₁ x₂ x₃) x₄
--   = f(g x₁ x₂ x₃ x₄)
_∘_ : let _ = n ; _ = X ; _ = Y ; _ = Z in (Y → Z) → (X →̂ Y)(n) → (X →̂ Z)(n)
_∘_ {𝟎}       = Fn.id
_∘_ {𝐒(𝟎)}    = Fn._∘_
_∘_ {𝐒(𝐒(n))} = Fn._∘_ Fn.∘ (_∘_) -- (f ∘ₙ₊₂ g)(x) = f ∘ₙ₊₁ g(x)

_∘[_]_ : let _ = X ; _ = Y ; _ = Z in (Y → Z) → (n : ℕ) → (X →̂ Y)(n) → (X →̂ Z)(n)
f ∘[ n ] g = _∘_ {n = n} f g

_∘₀_ = _∘_ {0}
_∘₁_ = _∘_ {1}
_∘₂_ = _∘_ {2}
_∘₃_ = _∘_ {3}
_∘₄_ = _∘_ {4}
_∘₅_ = _∘_ {5}
_∘₆_ = _∘_ {6}
_∘₇_ = _∘_ {7}
_∘₈_ = _∘_ {8}
_∘₉_ = _∘_ {9}

-- TODO: Flip the arguments and make n explicit
-- Single function composition on every argument.
-- (f on g)(y₁)(y₂).. = g (f(y₁)) (f(y₂)) ..
-- Examples:
--   _on_ {3} f g (y₂) (y₁) (y₀)
--   = _on_ {2} f (g (f(y₂))) (y₁) (y₀)
--   = _on_ {1} f (g (f(y₂)) (f(y₁))) (y₀)
--   = _on_ {0} f (g (f(y₂)) (f(y₁)) (f(y₀)))
--   = g (f(y₂)) (f(y₁)) (f(y₀))
on : let _ = n ; _ = X ; _ = Y ; _ = Z in (Y →̂ Z)(n) → (X → Y) → (X →̂ Z)(n)
on {n = 𝟎}               = Fn.const
on {n = 𝐒(𝟎)}            = Fn._∘_
on {n = 𝐒(𝐒(n))} f g(yₙ) = on {n = 𝐒(n)} (f(g(yₙ))) g

-- applyOnFn : ∀{n}{X}{Y} → (Y →̂ Y)(n) → ((X → Y) →̂ (X → Y))(n)
-- applyOnFn

-- Constructs a left-associated n-ary operator from a binary operator.
-- Example:
--   naryₗ{3} (_▫_) x₁ x₂ x₃ x₄ x₅
--   = ((naryₗ{2} (_▫_)) Fn.∘ (x₁ ▫_)) x₂ x₃ x₄
--   = (naryₗ{2} (_▫_) (x₁ ▫ x₂)) x₃ x₄ x₅
--   = ((naryₗ{1} (_▫_)) Fn.∘ ((x₁ ▫ x₂) ▫_)) x₃ x₄ x₅
--   = (naryₗ{1} (_▫_) ((x₁ ▫ x₂) ▫ x₃)) x₄ x₅
--   = ((naryₗ{0} (_▫_)) Fn.∘ (((x₁ ▫ x₂) ▫ x₃) ▫_)) x₃ x₄ x₅
--   = (naryₗ{0} (_▫_) (((x₁ ▫ x₂) ▫ x₃) ▫ x₄)) x₅
--   = ((_▫_) (((x₁ ▫ x₂) ▫ x₃) ▫ x₄)) x₅
--   = ((((x₁ ▫ x₂) ▫ x₃) ▫ x₄) ▫_) x₅
--   = (((x₁ ▫ x₂) ▫ x₃) ▫ x₄) x₅
naryₗ : (n : ℕ) → (X → X → X) → (X →̂ X)(𝐒(𝐒(n)))
naryₗ(𝟎)    (_▫_)   = (_▫_)
naryₗ(𝐒(n)) (_▫_) x = (naryₗ(n) (_▫_)) Fn.∘ (x ▫_)

-- Constructs a right-associated n-ary operator from a binary operator.
-- Example:
--   naryᵣ{3} (_▫_) x₁ x₂ x₃ x₄ x₅
--   = ((x₁ ▫_) ∘[ 4 ] (naryᵣ{2} (_▫_))) x₂ x₃ x₄ x₅
--   = x₁ ▫ (naryᵣ{2} (_▫_) x₂ x₃ x₄ x₅)
--   = x₁ ▫ (((x₂ ▫_) ∘[ 3 ] (naryᵣ{1} (_▫_))) x₃ x₄ x₅)
--   = x₁ ▫ (x₂ ▫ (naryᵣ{1} (_▫_) x₃ x₄ x₅))
--   = x₁ ▫ (x₂ ▫ (((x₃ ▫_) ∘[ 2 ] (naryᵣ{0} (_▫_))) x₄ x₅))
--   = x₁ ▫ (x₂ ▫ (x₃ ▫ (naryᵣ{0} (_▫_) x₄ x₅)))
--   = x₁ ▫ (x₂ ▫ (x₃ ▫ ((_▫_) x₄ x₅)))
--   = x₁ ▫ (x₂ ▫ (x₃ ▫ (x₄ ▫ x₅)))
naryᵣ : (n : ℕ) → (X → X → X) → (X →̂ X)(𝐒(𝐒(n)))
naryᵣ(𝟎)    (_▫_)   = (_▫_)
naryᵣ(𝐒(n)) (_▫_) x = (x ▫_) ∘[ 𝐒(𝐒(n)) ] (naryᵣ(n) (_▫_))

{-
[→̂]-to-[⇉] : (n : ℕ) → ∀{X : Type{ℓ₁}}{Y : Type{ℓ₂}} → (X →̂ Y)(n) → (RaiseType.repeat(n) X ⇉ Y)
[→̂]-to-[⇉] 0         f = f
[→̂]-to-[⇉] 1         f = f
[→̂]-to-[⇉] (𝐒(𝐒(n))) f = [→̂]-to-[⇉] (𝐒(n)) ∘ f
-}


{-# OPTIONS --cubical --safe --guardedness #-}
module Cubical.Codata.M where

open import Cubical.Foundations.Prelude

-- TODO move
module Helpers where
  module _ {ℓ ℓ'} {A : Type ℓ} {x : A} (P : ∀ y → x ≡ y → Type ℓ') (d : P x refl) where
    -- A version with y as an explicit argument can be used to make Agda
    -- infer the family P.
    J' : ∀ y (p : x ≡ y) → P y p
    J' y p = J P d p

  lem-transp : ∀ {ℓ} {A : Type ℓ} (i : I) → (B : Type ℓ) (P : A ≡ B) → (p : P i) → PathP (\ j → P j) (transp (\ k → P (~ k ∧ i)) (~ i) p)
                                                                                (transp (\ k → P (k ∨ i)) i p)
  lem-transp {A = A} i = J' _ (\ p j → transp (\ _ → A) ((~ j ∧ ~ i) ∨ (j ∧ i)) p )

  transp-over : ∀ {ℓ} (A : I → Type ℓ) (i j : I) → A i → A j
  transp-over A i k p = transp (\ j → A ((~ j ∧ i) ∨ (j ∧ k))) (~ i ∧ ~ k) p

  transp-over-1 : ∀ {ℓ} (A : I → Type ℓ) (i j : I) → A i → A j
  transp-over-1 A i k p = transp (\ j → A ((j ∨ i) ∧ (~ j ∨ k))) (i ∧ k) p

  compPathD : {ℓ ℓ' : _} {X : Type ℓ} (F : X → Type ℓ') {A B C : X} (P : A ≡ B) (Q : B ≡ C)
              → ∀ {x y z} → (\ i → F (P i)) [ x ≡ y ] → (\ i → F (Q i)) [ y ≡ z ] → (\ i → F ((P ∙ Q) i)) [ x ≡ z ]
  compPathD F {A = A} P Q {x} p q i =
     comp (\ j → F (hfill (λ j → \ { (i = i0) → A ; (i = i1) → Q j })
                          (inS (P i))
                          j))
          (λ j → \ { (i = i0) → x; (i = i1) → q j })
          (p i)

open Helpers

IxCont : Type₀ → Type₁
IxCont X = Σ (X → Type₀) \ S → ∀ x → S x → X → Type₀

⟦_⟧ : ∀ {X : Type₀} → IxCont X → (X → Type₀) → (X → Type₀)
⟦ (S , P) ⟧ X x = Σ (S x) \ s → ∀ y → P x s y → X y

record M {X : Type₀} (C : IxCont X) (x : X) : Type₀ where
  coinductive
  field
    head : C .fst x
    tails : ∀ y → C .snd x head y → M C y

open M public

module _ {X : Type₀} {C : IxCont X} where

  private
    F = ⟦ C ⟧

  out : ∀ x → M C x → F (M C) x
  out x a = (a .head) , (a .tails)

  mapF : ∀ {A B} → (∀ x → A x → B x) → ∀ x → F A x → F B x
  mapF f x (s , t) = s , \ y p → f _ (t y p)

  unfold : ∀ {A} (α : ∀ x → A x → F A x) → ∀ x → A x → M C x
  unfold α x a .head = α x a .fst
  unfold α x a .tails y p = unfold α y (α x a .snd y p)

  -- We generalize the type to avoid upsetting --guardedness by
  -- transporting after the corecursive call.
  -- Recognizing hcomp/transp as guardedness-preserving could be a better solution.
  unfold-η' : ∀ {A} (α : ∀ x → A x → F A x) → (h : ∀ x → A x → M C x)
                     → (∀ (x : X) (a : A x) → out x (h x a) ≡ mapF h x (α x a))
                     → ∀ (x : X) (a : A x) m → h x a ≡ m → m ≡ unfold α x a
  unfold-η' α h eq x a m eq' = let heq = cong head (sym eq') ∙ cong fst (eq x a)
                               in \ where
                                    i .head → heq i
                                    i .tails y p →
                                     let  p0 = (transp-over-1 (\ k → C .snd x (heq k) y) i i1 p)
                                          p1 = (transp-over (\ k → C .snd x (heq k) y) i i0 p)
                                          pe = lem-transp i _ (\ k → C .snd x (heq k) y) p
                                          tl = compPathD (λ p → C .snd x p y → M C y)
                                                         (cong head (sym eq')) (cong fst (eq x a))
                                                         (cong (\ f → f .tails y) (sym eq'))
                                                         (cong (\ f → f .snd   y) (eq x a))
                                     in unfold-η' α h eq y (α x a .snd y p0)
                                                           (m .tails y p1)
                                                           (sym (\ k → tl k (pe k)))
                                                           i

  unfold-η : ∀ {A} (α : ∀ x → A x → F A x) → (h : ∀ x → A x → M C x)
                     → (∀ (x : X) (a : A x) → out x (h x a) ≡ mapF h x (α x a))
                     → ∀ (x : X) (a : A x) → h x a ≡ unfold α x a
  unfold-η α h eq x a = unfold-η' α h eq x a _ refl


{-# OPTIONS --without-K #-}
module Universe.Utility.General where

open import lib.Basics
open import lib.NType2

open import lib.types.Nat hiding (_+_)
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Unit

-- A readable notation for the join of universe levels.
infixr 8  _⊔_

_⊔_ : ULevel → ULevel → ULevel
_⊔_ = lmax

-- Important detail: addition operator adjustment.
_+_ : ℕ → ℕ → ℕ
a + b = b lib.types.Nat.+ a  -- n + 1 should mean S n (author preference)!

{- Since natural numbers and universe levels use
   different types, we require a translation operation. -}
｢_｣ : ℕ → ULevel
｢ 0   ｣ = lzero
｢ S n ｣ = lsucc ｢ n ｣

{- The (function) exponentiation operator. For convenience, we
   choose to define it via postcomposition in the recursion step. -}
infix 10 _^_

_^_ : ∀ {i} {A : Set i} → (A → A) → ℕ → A → A
f ^ 0   = idf _
f ^ S n = f ^ n ∘ f

{- The rest of this file contains the remainder of the library type material
   that could not yet be merged into the community's HoTT library due to
   organizational issues. -}

module _ {i j} {A : Type i} {B : A → Type j} where
  module _ (h : is-contr A) where
    Π₁-contr : Π A B ≃ B (fst h)
    Π₁-contr = Π₁-Unit ∘e equiv-Π-l _ (snd (contr-equiv-Unit h ⁻¹)) ⁻¹

    Σ₁-contr : Σ A B ≃ B (fst h)
    Σ₁-contr = Σ₁-Unit ∘e equiv-Σ-fst _ (snd (contr-equiv-Unit h ⁻¹)) ⁻¹

  module _ (h : (a : A) → is-contr (B a)) where
    Σ₂-contr : Σ A B ≃ A
    Σ₂-contr = Σ₂-Unit ∘e equiv-Σ-snd (λ _ → contr-equiv-Unit (h _))

    Π₂-contr : Π A B ≃ ⊤
    Π₂-contr = Π₂-Unit ∘e equiv-Π-r (λ _ → contr-equiv-Unit (h _))

×-comm : ∀ {i j} {A : Type i} {B : Type j} → (A × B) ≃ (B × A)
×-comm = equiv (λ {(a , b) → (b , a)})
               (λ {(b , a) → (a , b)})
               (λ _ → idp) (λ _ → idp)

Σ-comm-snd : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
           → Σ (Σ A B) (λ ab → C (fst ab)) ≃ Σ (Σ A C) (λ ac → B (fst ac))
Σ-comm-snd {A = A} {B} {C} =
  Σ (Σ A B) (λ ab → C (fst ab))  ≃⟨ Σ-assoc ⟩
  Σ A (λ a → B a × C a)          ≃⟨ equiv-Σ-snd (λ _ → ×-comm) ⟩
  Σ A (λ a → C a × B a)          ≃⟨ Σ-assoc ⁻¹ ⟩
  Σ (Σ A C) (λ ac → B (fst ac))  ≃∎

flip : ∀ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k}
       → ((a : A) (b : B) → C a b) → ((b : B) (a : A) → C a b)
flip = –> (curry-equiv ∘e equiv-Π-l _ (snd ×-comm) ∘e curry-equiv ⁻¹)

module _ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k} where
  ↓-cst→app-equiv : {x x' : A} {p : x == x'} {u : (b : B) → C x b} {u' : (b : B) → C x' b}
                  → ((b : B) → u b == u' b [ (λ x → C x b) ↓ p ]) ≃ (u == u' [ (λ x → (b : B) → C x b) ↓ p ])
  ↓-cst→app-equiv {p = idp} = equiv λ= app= (! ∘ λ=-η) (λ= ∘ app=-β)

module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} where
  ↓-cst2-equiv : {x y : A} (p : x == y) {b : C x} {c : C y}
    (q : b == c [ C ↓ p ]) {u : B x} {v : B y}
    → (u == v [ B ↓ p ]) ≃ (u == v [ (λ xy → B (fst xy)) ↓ (pair= p q) ])
  ↓-cst2-equiv idp idp = ide _

module _ {i} {A B : Type i} (e : A ≃ B) {u : A} {v : B} where
  ↓-idf-ua-equiv : (–> e u == v) ≃ (u == v [ (λ x → x) ↓ (ua e) ])
  ↓-idf-ua-equiv = to-transp-equiv _ _ ⁻¹ ∘e (_ , pre∙-is-equiv (ap (λ z → z u) (ap coe (ap-idf (ua e)) ∙ ap –> (coe-equiv-β e))))

-- On propositions, equivalence coincides with logical equivalence.
module _ {i j} {A : Type i} {B : Type j} where
  prop-equiv' : (B → is-prop A) → (A → is-prop B) → (A → B) → (B → A) → A ≃ B
  prop-equiv' h k f g = equiv f g (λ b → prop-has-all-paths (k (g b)) _ _)
                                  (λ a → prop-has-all-paths (h (f a)) _ _)

  prop-equiv : is-prop A → is-prop B → (A → B) → (B → A) → A ≃ B
  prop-equiv h k f g = prop-equiv' (cst h) (cst k) f g

-- Equivalent types have equivalent truncatedness propositions.
equiv-level : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂}
            → A ≃ B → has-level n A ≃ has-level n B
equiv-level u = prop-equiv has-level-is-prop
                           has-level-is-prop
                           (equiv-preserves-level u)
                           (equiv-preserves-level (u ⁻¹))

prop-equiv-inhab-to-contr : ∀ {i} {A : Type i} → is-prop A ≃ (A → is-contr A)
prop-equiv-inhab-to-contr = prop-equiv is-prop-is-prop
                                       (Π-level (λ _ → is-contr-is-prop))
                                       (flip inhab-prop-is-contr)
                                       inhab-to-contr-is-prop


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

open import Function using (_∘_)
open import Data.Empty using (⊥-elim)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; trans; sym; cong; cong₂)
open Relation.Binary.PropositionalEquality.≡-Reasoning
open import Data.Product using (Σ-syntax; _,_)
open import Data.Unit using (tt)
open import Relation.Nullary using (yes; no)

import Data.Nat as ℕ
import Data.Nat.Properties as ℕₚ
import Data.Fin as Fin
import Data.Fin.Properties as Finₚ

open ℕ using (ℕ; zero; suc)
open Fin using (Fin; zero; suc)

open import PiCalculus.Syntax
open Scoped
open import PiCalculus.Semantics

module PiCalculus.Semantics.Properties where
private
  variable
    n : ℕ
    i j : Fin n
    P : Scoped n

lift-lower : (i : Fin (suc n)) (P : Scoped (suc n)) (uP : Unused i P)
           → lift i (lower i P uP) ≡ P
lift-lower i 𝟘 uP = refl
lift-lower i (ν P) uP
  rewrite lift-lower (suc i) P uP = refl
lift-lower i (P ∥ Q) (uP , uQ)
  rewrite lift-lower i P uP
  | lift-lower i Q uQ = refl
lift-lower i (x ⦅⦆ P) (i≢x , uP)
  rewrite lift-lower (suc i) P uP
  | Finₚ.punchIn-punchOut i≢x = refl
lift-lower i (x ⟨ y ⟩ P) (i≢x , i≢y , uP)
  rewrite lift-lower i P uP
  | Finₚ.punchIn-punchOut i≢x
  | Finₚ.punchIn-punchOut i≢y = refl

substFin-suc : (i j x : Fin n) → (suc x) [ suc i ↦ suc j ]' ≡ suc (x [ i ↦ j ]')
substFin-suc i j x with i Finₚ.≟ x
substFin-suc i j x | yes p = refl
substFin-suc i j x | no ¬p = refl

exchangeFin-suc : (i : Fin n) (x : Fin (suc n)) → suc (exchangeFin i x) ≡ exchangeFin (suc i) (suc x)
exchangeFin-suc i x with Fin.inject₁ i Finₚ.≟ x
exchangeFin-suc i .(Fin.inject₁ i) | yes refl = cong suc (cong suc (Finₚ.lower₁-irrelevant _ _ _))
exchangeFin-suc i x | no ¬p with (suc i) Fin.≟ x
exchangeFin-suc i x | no ¬p | yes q = refl
exchangeFin-suc i x | no ¬p | no ¬q = refl

exchangeFin-injectˡ : (i : Fin n) → exchangeFin i (Fin.inject₁ i) ≡ suc i
exchangeFin-injectˡ zero = refl
exchangeFin-injectˡ (suc i) rewrite sym (exchangeFin-suc i (Fin.inject₁ i)) = cong suc (exchangeFin-injectˡ i)

exchangeFin-injectʳ : (i : Fin n) → exchangeFin i (suc i) ≡ Fin.inject₁ i
exchangeFin-injectʳ zero = refl
exchangeFin-injectʳ (suc i) rewrite sym (exchangeFin-suc i (suc i)) = cong suc (exchangeFin-injectʳ i)

exchangeFin-neq : (i j : Fin n) → i ≢ j → Fin.inject₁ i ≢ suc j → exchangeFin i (suc j) ≡ suc j
exchangeFin-neq zero zero i≢j ii≢sj = ⊥-elim (i≢j refl)
exchangeFin-neq zero (suc zero) i≢j ii≢sj = refl
exchangeFin-neq zero (suc (suc j)) i≢j ii≢sj = refl
exchangeFin-neq (suc zero) zero i≢j ii≢sj = ⊥-elim (ii≢sj refl)
exchangeFin-neq (suc (suc i)) zero i≢j ii≢sj = refl
exchangeFin-neq (suc i) (suc j) i≢j ii≢sj
  rewrite sym (exchangeFin-suc i (suc j))
  = cong suc (exchangeFin-neq i j (i≢j ∘ cong suc) (ii≢sj ∘ cong suc))

exchangeFin-exchangeFin : ∀ (i : Fin n) (x : Fin (suc n)) → exchangeFin i (exchangeFin i x) ≡ x
exchangeFin-exchangeFin i x with Fin.inject₁ i Fin.≟ x
exchangeFin-exchangeFin i x | yes p with Fin.inject₁ i Finₚ.≟ (suc (Fin.lower₁ x (notMax i x p)))
exchangeFin-exchangeFin i .(Fin.inject₁ i) | yes refl | yes q = ⊥-elim (ℕₚ.1+n≢n (begin
  suc (Fin.toℕ i)                              ≡˘⟨ cong (suc ∘ Fin.toℕ) (Finₚ.lower₁-inject₁ i) ⟩
  suc (Fin.toℕ (Fin.lower₁ (Fin.inject₁ i) _)) ≡⟨ cong (suc ∘ Fin.toℕ) (Finₚ.lower₁-irrelevant _ _ _) ⟩
  suc (Fin.toℕ (Fin.lower₁ (Fin.inject₁ i) _)) ≡˘⟨ cong Fin.toℕ q ⟩
  Fin.toℕ (Fin.inject₁ i)                      ≡⟨ Finₚ.toℕ-inject₁ i ⟩
  Fin.toℕ i                                    ∎
  ))
exchangeFin-exchangeFin i x | yes p | no ¬q with i Finₚ.≟ Fin.lower₁ x (notMax i x p)
exchangeFin-exchangeFin i x | yes p | no ¬q | yes r = p
exchangeFin-exchangeFin i x | yes refl | no ¬q | no ¬r = ⊥-elim (¬r (begin
  i                            ≡˘⟨ Finₚ.lower₁-inject₁ i ⟩
  Fin.lower₁ (Fin.inject₁ i) _ ≡⟨ Finₚ.lower₁-irrelevant _ _ _ ⟩
  Fin.lower₁ (Fin.inject₁ i) _ ∎))
exchangeFin-exchangeFin i x | no ¬p with (suc i) Fin.≟ x
exchangeFin-exchangeFin i x | no ¬p | yes q with Fin.inject₁ i Fin.≟ Fin.inject₁ i
exchangeFin-exchangeFin i x | no ¬p | yes refl | yes refl = begin
  suc (Fin.lower₁ (Fin.inject₁ i) _)
    ≡⟨ cong suc (Finₚ.lower₁-irrelevant _ _ _) ⟩
  suc (Fin.lower₁ (Fin.inject₁ i) _)
    ≡⟨ cong suc (Finₚ.lower₁-inject₁ i) ⟩
  suc i
    ∎
exchangeFin-exchangeFin i x | no ¬p | yes q | no ¬r = ⊥-elim (¬r refl)
exchangeFin-exchangeFin i x | no ¬p | no ¬q with Fin.inject₁ i Fin.≟ x
exchangeFin-exchangeFin i x | no ¬p | no ¬q | yes r = ⊥-elim (¬p r)
exchangeFin-exchangeFin i x | no ¬p | no ¬q | no ¬r with (suc i) Fin.≟ x
exchangeFin-exchangeFin i x | no ¬p | no ¬q | no ¬r | yes s = ⊥-elim (¬q s)
exchangeFin-exchangeFin i x | no ¬p | no ¬q | no ¬r | no ¬s = refl

exchange-exchange : ∀ (i : Fin n) (P : Scoped (suc n)) → exchange i (exchange i P) ≡ P
exchange-exchange i 𝟘 = refl
exchange-exchange i (ν P) rewrite exchange-exchange (suc i) P = refl
exchange-exchange i (P ∥ Q) rewrite exchange-exchange i P | exchange-exchange i Q = refl
exchange-exchange i (x ⦅⦆ P) rewrite exchangeFin-exchangeFin i x | exchange-exchange (suc i) P = refl
exchange-exchange i (x ⟨ y ⟩ P) rewrite exchangeFin-exchangeFin i x | exchangeFin-exchangeFin i y | exchange-exchange i P = refl


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

open import Cubical.HITs.Colimit.Base public
open import Cubical.HITs.Colimit.Examples public


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

module SEquivSCPermEquiv where

-- Data types from standard library

open import Level        using (zero)
open import Data.Nat     using (ℕ; _+_)
open import Data.Fin     using (Fin; inject+; raise)
open import Data.Sum     using (inj₁; inj₂)
open import Data.Product using (_,_; proj₁; proj₂)
open import Data.Vec     using (tabulate) renaming (_++_ to _++V_)
open import Function     using (_∘_; id)

-- Properties from standard library

open import Data.Vec.Properties using    (lookup∘tabulate)
open import Relation.Binary     using    (Setoid)
open import Function.Equality   using    (_⇨_; _⟨$⟩_; _⟶_)
                                renaming (_∘_ to _⊚_; id to id⊚)

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; setoid; →-to-⟶;
         module ≡-Reasoning)

-- Next are imports from our libraries of Proofs (FiniteFunctions and
-- VectorLemmas)

open import Proofs using (finext; _!!_; tabulate-split)

-- Next we import our notions of equivalences

open import Equiv using (_∼_; module qinv; mkqinv; _≃_)

-- Next we import sets equipped with equivalence relations and
-- specialize to our notions of equivalence

open import SetoidEquiv
  using (
  ≃S-Setoid;        -- statement of thm2
  _≃S_;             -- statement of thm2
  module _≃S_;      -- proof of thm2
  module _≋_;       -- proof of thm2
  equiv;            -- proof of thm2
  equivS;           -- proof of thm2
  _≋_              -- proof of thm2
--  id≃S
--  0≃S;
--  _≃S≡_;
--  _⊎≃S_
  )

-- Finally we import our definition of permutations. We start with Vec
-- (Fin m) n for arbitrary m and n which---if well-formed---would
-- define a permutation in the Cauchy representation. These vectors
-- assume a canonical enumeration of the finite sets which we make
-- explicit in the module Enumeration. To ensure these vectors are
-- well-formed, we define a concrete permutation as a pair of two such
-- vectors with two proofs that they compose to the identity
-- permutation.

open import FinVec using (_∘̂_; 1C)
open import FinVecProperties using (~⇒≡; !!⇒∘̂; 1C!!i≡i; cauchyext)
open import EnumEquiv using (Enum; 0E; _⊕e_; eval-left; eval-right)
open import FiniteType using (FiniteType; ∣_∣)
open import ConcretePermutation -- using (CPerm; cp; p≡; 0p; idp; _⊎p_) -- ; SCPerm)
open import ConcretePermutationProperties -- using (CPerm; cp; p≡; 0p; idp; _⊎p_) -- ; SCPerm)

------------------------------------------------------------------------------
-- The big (semantic) theorem!

thm2 : ∀ {A B : Set} → (a : FiniteType A) → (b : FiniteType B) →
  (≃S-Setoid A B) ≃S (SCPerm ∣ b ∣ ∣ a ∣)
thm2 {A} {B} (n , (enumA , mkqinv labelA αA βA))
             (m , (enumB , mkqinv labelB αB βB)) =
  equiv fwd' bwd' α β
  where
    open ≡-Reasoning
    AS = setoid A
    BS = setoid B
    A≃Fn : A ≃ Fin n
    A≃Fn = (enumA , mkqinv labelA αA βA)
    B≃Fn : B ≃ Fin m
    B≃Fn = (enumB , mkqinv labelB αB βB)
    CP⇨ = SCPerm m n ⇨ SCPerm m n

    fwd : (AS ≃S BS) → CPerm m n
    fwd A≃B = cp (tabulate f) (tabulate g) (~⇒≡ β) (~⇒≡ α)
      where
        module A≃SB = _≃S_ A≃B
        f : Fin n → Fin m
        f j = enumB (A≃SB.f ⟨$⟩ labelA j)

        g : Fin m → Fin n
        g j =  enumA (A≃SB.g ⟨$⟩ labelB j)

        α : f ∘ g ∼ id
        α i =
          begin
            (enumB (A≃SB.f ⟨$⟩ (labelA (enumA (A≃SB.g ⟨$⟩ labelB i))))
                ≡⟨ cong (λ x → enumB (A≃SB.f ⟨$⟩ x)) (βA ((A≃SB.g  ⟨$⟩ labelB i))) ⟩
            enumB (A≃SB.f ⟨$⟩ (A≃SB.g  ⟨$⟩ labelB i))
                ≡⟨ cong enumB (A≃SB.α refl) ⟩
            enumB (labelB i)
                ≡⟨ αB i ⟩
            i ∎)

        β : g ∘ f ∼ id
        β i =
          begin (
            enumA (A≃SB.g ⟨$⟩ labelB (enumB (A≃SB.f ⟨$⟩ labelA i)))
                ≡⟨ cong (λ x → enumA (A≃SB.g ⟨$⟩ x)) (βB _) ⟩
            enumA (A≃SB.g ⟨$⟩ (A≃SB.f ⟨$⟩ labelA i))
                ≡⟨ cong enumA (A≃SB.β refl) ⟩
            enumA (labelA i)
               ≡⟨ αA i ⟩
            i ∎)

    fwd' : ≃S-Setoid A B ⟶ setoid (CPerm m n)
    fwd' = record
     { _⟨$⟩_ = fwd
      ; cong = λ {i} {j} i≋j → p≡ (finext (λ k → cong enumB (f≡ i≋j (labelA k)) ))
     }
       where open _≋_

    bwd : CPerm m n → (AS ≃S BS)
    bwd (cp p₁ p₂ αp βp) = equiv f g α β
      where
        f : AS ⟶ BS
        f = →-to-⟶ (λ a → labelB (p₁ !! enumA a))

        g : BS ⟶ AS
        g = →-to-⟶ (λ b → labelA (p₂ !! (enumB b)))

        α : Setoid._≈_ (BS ⇨ BS) (f ⊚ g) id⊚
        α {b} {.b} refl =
          begin (
            labelB (p₁ !! (enumA (labelA (p₂ !! (enumB b)))))
              ≡⟨ cong (λ x → labelB (p₁ !! x)) (αA _) ⟩
            labelB (p₁ !! (p₂ !! enumB b))
              ≡⟨ cong labelB (!!⇒∘̂ _ _ (enumB b)) ⟩
            labelB ((p₂ ∘̂ p₁) !! enumB b)
              ≡⟨ cong (λ x → (labelB (x !! enumB b))) βp ⟩
           labelB (1C !! enumB b)
              ≡⟨ cong labelB 1C!!i≡i ⟩
           labelB (enumB b)
              ≡⟨ βB b ⟩
            b ∎)

        β : Setoid._≈_ (AS ⇨ AS) (g ⊚ f) id⊚
        β {a} {.a} refl =
          begin (
            labelA (p₂ !! (enumB (labelB (p₁ !! enumA a))))
              ≡⟨ cong (λ x → labelA (p₂ !! x)) (αB _) ⟩
            labelA (p₂ !! (p₁ !! enumA a))
              ≡⟨ cong labelA (!!⇒∘̂ _ _ (enumA a)) ⟩
            labelA ((p₁ ∘̂ p₂) !! enumA a)
              ≡⟨ cong (λ x → labelA (x !! enumA a)) αp ⟩
            labelA (1C !! enumA a)
              ≡⟨ cong labelA 1C!!i≡i ⟩
            labelA (enumA a)
              ≡⟨ βA a ⟩
            a ∎)

    bwd' : setoid (CPerm m n) ⟶ ≃S-Setoid A B
    bwd' = record
      { _⟨$⟩_ = bwd
      ; cong = λ { {π} {.π} refl → equivS (λ _ → refl) (λ _ → refl) }
      }

    α : Setoid._≈_ CP⇨ (fwd' ⊚ bwd') id⊚
    α {cp π πᵒ αp βp} refl = p≡ (trans (finext pf₁) (cauchyext π))
      where
        pf₁ : (j : Fin n) → enumB (labelB (π !! enumA (labelA j))) ≡ π !! j
        pf₁ j =
          begin (
            enumB (labelB (π !! enumA (labelA j)))
              ≡⟨ αB _ ⟩
            π !! enumA (labelA j)
              ≡⟨ cong (_!!_ π) (αA _) ⟩
            π !! j ∎)

    β : {x y : AS ≃S BS} → x ≋ y → ((bwd' ⊚ fwd') ⟨$⟩ x) ≋ y
    β {equiv f g α β} {equiv f₁ g₁ α₁ β₁} (equivS f≡ g≡) =
      equivS (λ a → trans (pf₁ a) (f≡ a)) (λ b → trans (pf₂ b) (g≡ b))
      where
        pf₁ : ∀ a → labelB (tabulate (λ j → enumB (f ⟨$⟩ labelA j)) !! (enumA a)) ≡ f ⟨$⟩ a
        pf₁ a =
          begin (
            labelB (tabulate (λ j → enumB (f ⟨$⟩ labelA j)) !! enumA a)
              ≡⟨ cong labelB (lookup∘tabulate _ (enumA a)) ⟩
            labelB (enumB (f ⟨$⟩ labelA (enumA a)))
              ≡⟨ βB _ ⟩
            f ⟨$⟩ labelA (enumA a)
              ≡⟨ cong (_⟨$⟩_ f) (βA _) ⟩
            f ⟨$⟩ a ∎)
        pf₂ : ∀ b → labelA (tabulate (λ j → enumA (g ⟨$⟩ labelB j)) !! (enumB b)) ≡ g ⟨$⟩ b
        pf₂ b =
          begin (
            labelA (tabulate (λ j → enumA (g ⟨$⟩ labelB j)) !! enumB b)
              ≡⟨ cong labelA (lookup∘tabulate _ (enumB b)) ⟩
            labelA (enumA (g ⟨$⟩ labelB (enumB b)))
              ≡⟨ βA _ ⟩
            g ⟨$⟩ labelB (enumB b)
              ≡⟨ cong (_⟨$⟩_ g) (βB _) ⟩
            g ⟨$⟩ b ∎ )

-- Start proving some of the transport lemmas.
-- Need to do:
-- 1. prove that we have a bijective morphism of carriers: done, this is thm2 (fwd is the morphism)
-- 2.  prove that it preserves:
--   a. id (done)
--   b. 0 (done)
--   c. + (done)
--   d. *

{--

Is this still important or has it been subsumed by the categorical work ???

Still important, I believe.  It will be used in proving the categorical
components of CPermCat.

open _≃S_

lemma_1a : ∀ {n} {A : Set} → (EA : Enum A n) → f (thm2 EA EA) ⟨$⟩ id≃S ≡ idp
lemma_1a (f' , mkqinv g α _) = p≡ (trans (finext α) F.reveal1C)

-- this is redundant, as it follows from lemma_1a.
lemma_1b : ∀ {n} {A : Set} → (EA : Enum A n) → (g (thm2 EA EA) ⟨$⟩ idp) ≋ id≃S
lemma_1b (enumA , mkqinv g _ β) =
  equivS (λ x → trans (cong g 1C!!i≡i) (β x)) (λ x → trans (cong g 1C!!i≡i) (β x))

lemma2 : f (thm2 0E 0E) ⟨$⟩ 0≃S ≡ 0p
lemma2 = p≡ F.reveal0C -- p≡ refl

lemma3 : ∀ {n₁ n₂} {A B C D : Set} {EA : Enum A n₁} {EB : Enum B n₁}
  {EC : Enum C n₂} {ED : Enum D n₂} → (x : A ≃S≡ B) → (y : C ≃S≡ D) →
   f (thm2 (EA ⊕e EC) (EB ⊕e ED)) ⟨$⟩ (x ⊎≃S y) ≡
   (f (thm2 EA EB) ⟨$⟩ x) ⊎p (f (thm2 EC ED) ⟨$⟩ y)
lemma3 {n₁} {n₂} {EA = EA} {EB} {EC} {ED} (equiv f₄ g₄ α₄ β₄) (equiv f₅ g₅ α₅ β₅) =
  p≡ (
    begin (
       CPerm.π (f (thm2 (EA ⊕e EC) (EB ⊕e ED)) ⟨$⟩ (x ⊎≃S y))
         ≡⟨ refl ⟩ -- inline f, fwd and π
       tabulate {n₁ + n₂} (λ j → enumBD (x⊎y.f ⟨$⟩ qAC.g j))
         ≡⟨ tabulate-split {n₁} {n₂} {f =  λ j → enumBD (x⊎y.f ⟨$⟩ qAC.g j)} ⟩
       tabulate {n₁} (λ j → enumBD (x⊎y.f ⟨$⟩ qAC.g (inject+ n₂ j))) ++V
       tabulate {n₂} (λ j → enumBD (x⊎y.f ⟨$⟩ qAC.g (raise n₁ j)))
         ≡⟨ cong₂ _++V_ (finext {n₁} pf₁) (finext pf₂) ⟩
       tabulate {n₁} (λ j → inject+ n₂ (tabulate (λ i → enumB (f₄ ⟨$⟩ qA.g i)) !! j)) ++V
       tabulate {n₂} (λ j → raise n₁ (tabulate (λ i → enumD (f₅ ⟨$⟩ qC.g i)) !! j))
         ≡⟨ sym F.reveal⊎c ⟩ -- going up, inline f, fwd, ⊎p and π
       CPerm.π ((f (thm2 EA EB) ⟨$⟩ x) ⊎p (f (thm2 EC ED) ⟨$⟩ y)) ∎))
  where
    open ≡-Reasoning
    x = equiv f₄ g₄ α₄ β₄
    y = equiv f₅ g₅ α₅ β₅
    enumB = proj₁ EB
    enumD = proj₁ ED
    enumAC = proj₁ (EA ⊕e EC)
    module qAC = qinv (proj₂ (EA ⊕e EC))
    module qA = qinv (proj₂ EA)
    module qC = qinv (proj₂ EC)
    enumBD = proj₁ (EB ⊕e ED)
    module x⊎y = _≃S_ (x ⊎≃S y)

    pf₁ :  (i : Fin n₁) →
      enumBD (x⊎y.f ⟨$⟩ qAC.g (inject+ n₂ i)) ≡
      inject+ n₂ (tabulate (λ i₁ → enumB (f₄ ⟨$⟩ qA.g i₁)) !! i)
    pf₁ i =
      begin (
        enumBD (x⊎y.f ⟨$⟩ qAC.g (inject+ n₂ i))
          ≡⟨ cong (λ j → enumBD (x⊎y.f ⟨$⟩ j)) (eval-left {eA = EA} {EC} i) ⟩
        enumBD (x⊎y.f ⟨$⟩ inj₁ (qA.g i))
          ≡⟨ refl ⟩ -- once the inj₁ is exposed, the rest happens by β-reduction
        inject+ n₂ (enumB (f₄ ⟨$⟩ qA.g i))
           ≡⟨ cong (inject+ n₂) (sym (lookup∘tabulate _ i)) ⟩
        inject+ n₂ (tabulate (λ j → enumB (f₄ ⟨$⟩ qA.g j)) !! i) ∎)

    pf₂ :  (i : Fin n₂) →
      enumBD (x⊎y.f ⟨$⟩ qAC.g (raise n₁ i)) ≡
      raise n₁ (tabulate (λ i₁ → enumD (f₅ ⟨$⟩ qC.g i₁)) !! i)
    pf₂ i =
      begin (
           enumBD (x⊎y.f ⟨$⟩ qAC.g (raise n₁ i))
             ≡⟨ cong (λ j → enumBD (x⊎y.f ⟨$⟩ j)) (eval-right {eA = EA} {EC} i) ⟩
           enumBD (x⊎y.f ⟨$⟩ inj₂ (qC.g i))
             ≡⟨ refl ⟩
           raise n₁ (enumD (f₅ ⟨$⟩ qC.g i))
             ≡⟨ cong (raise n₁) (sym (lookup∘tabulate _ i)) ⟩
           raise n₁ (tabulate (λ i₁ → enumD (f₅ ⟨$⟩ qC.g i₁)) !! i) ∎)
-}


module Selective.Libraries.ReceiveSublist where

open import Selective.ActorMonad public
open import Prelude

accept-sublist-unwrapped : (xs ys zs : InboxShape) → ∀{MT} → MT ∈ (xs ++ ys ++ zs) → Bool
accept-sublist-unwrapped [] [] zs p = false
accept-sublist-unwrapped [] (y ∷ ys) zs Z = true
accept-sublist-unwrapped [] (y ∷ ys) zs (S p) = accept-sublist-unwrapped [] ys zs p
accept-sublist-unwrapped (x ∷ xs) ys zs Z = false
accept-sublist-unwrapped (x ∷ xs) ys zs (S p) = accept-sublist-unwrapped xs ys zs p

accept-sublist : (xs ys zs : InboxShape) → MessageFilter (xs ++ ys ++ zs)
accept-sublist xs ys zs (Msg received-message-type received-fields) = accept-sublist-unwrapped xs ys zs received-message-type

record AcceptSublistDependent (IS : InboxShape) (accepted-type : MessageType) : Set₁ where
  field
    accepted-which : accepted-type ∈ IS
    fields : All receive-field-content accepted-type

receive-sublist : {i : Size} →
                  {Γ : TypingContext} →
                  (xs ys zs : InboxShape) →
                  ∞ActorM i (xs ++ ys ++ zs)
                            (Message ys)
                            Γ
                            (add-references Γ)
receive-sublist xs ys zs = do
    record { msg = Msg {MT} p f ; msg-ok = msg-ok } ← selective-receive (accept-sublist xs ys zs)
    let record {accepted-which = aw ; fields = fields } = rewrap-message xs ys zs p f msg-ok
    return₁ (Msg {MT = MT} aw fields)
  where
    rewrap-message : ∀{MT} →
                     (xs ys zs : InboxShape) →
                     (p : MT ∈ (xs ++ ys ++ zs)) →
                     All receive-field-content MT →
                     (accept-sublist-unwrapped xs ys zs p) ≡ true →
                     AcceptSublistDependent ys MT
    rewrap-message [] [] zs p f ()
    rewrap-message [] (x ∷ ys) zs Z f q = record { accepted-which = Z ; fields = f }
    rewrap-message [] (x ∷ ys) zs (S p) f q =
      let
        rec = rewrap-message [] ys zs p f q
        open AcceptSublistDependent
      in record { accepted-which = S (rec .accepted-which) ; fields = rec .fields }
    rewrap-message (x ∷ xs) ys zs Z f ()
    rewrap-message (x ∷ xs) ys zs (S p) f q = rewrap-message xs ys zs p f q


module Basic.Axiomatic.Partial where

open import Data.Bool hiding (not; if_then_else_; _∧_)
open import Data.Vec hiding ([_]; _++_; split)
open import Function
open import Relation.Binary.PropositionalEquality
open import Data.Product
import Level as L

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

{-

Here we define a Hoare logic for partial correctness of While programs (chapter 6.2).

The most important point here is the choice of representation for predicates.

The book mention intensional and extensional approaches. In the intensional approach,
we define a separate assertion language. However, the assertion language has to be powerful
enough to be able to express useful properties of the program state, and it takes quite a bit
of work to define such a language. An advatange of the intensional approach is that we could reuse
the same assertion language to extend the object language in other ways.

The book uses the extensional approach, and so do we. We go a bit further than the book though:
the book has boolean predicates over the program state, while we have type theoretic
"(State n → Set)" predicates. This means that our predicates can be proof-relevant and contain data,
so they can express computations and transformations on states.

However, the higher-order nature of the "(State n → Set)" representation of predicates also makes
type inference quite hard. I attepmeted to do some correctness proofs with the Hoare logics, and
it's certainly feasible, but we would need a lot more machinery and lots of helper functions to
make it convenient enough.

It's interesting to note that manual proof-writing is generally easier with Hoare logics than with
raw semantics, but here in Agda it's the opposite: the proofs in raw semantics (see e. g. the
factorial proofs in Basic.SmallStep, Basic.BigStep and Extended.FunRetRec) are pretty neat convenient,
since Agda keeps track of the program state for us and hides lots of unnecessary details.

Side note: we could have made our definition universe polymorphic. It would be a trivial extension;
the reason we don't have it is that we don't need that much power of expression for any of our proofs.
Just using "Set" suffices.

-}

{-
Predicate combinators: these just lift conjunction and implication into the State environment.
-}
_∧_ :
  ∀ {α β γ}{A : Set α}
  → (A → Set β)
  → (A → Set γ)
  → (A → Set _)
_∧_ f g x = f x × g x

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

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

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

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

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

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

  while :
                   ∀ {P b S} →
          〈 (T ∘ ⟦ b ⟧ᵉ) ∧ P 〉 S 〈 P 〉
    → ----------------------------------------
      〈 P 〉 while b do S 〈 (F ∘ ⟦ b ⟧ᵉ) ∧ P 〉

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

{-
A part of exercise 6.13 (associativity of statement composition with respect to our logic).
-}

split :
  ∀ {n P R}{S₁ S₂ : St n}
  → 〈 P 〉 S₁ , S₂ 〈 R 〉
  → ∃ λ Q
  → (〈 P 〉 S₁ 〈 Q 〉) × (〈 Q 〉 S₂ 〈 R 〉)
split (p , p₁) = _ , (p , p₁)
split (cons x p y) with split p
... | Q , (p1 , p2)  = Q , (cons x p1 id , cons id p2 y)

ex-613a :
  ∀ {n P Q}{S₁ S₂ S₃ : St n}
  → 〈 P 〉 S₁ , (S₂ , S₃) 〈 Q 〉
  → 〈 P 〉 (S₁ , S₂) , S₃ 〈 Q 〉
ex-613a (p , p₁) with split p₁
... | _ , (p₁₁ , p₁₂) = (p , p₁₁) , p₁₂
ex-613a (cons x p x₁) = cons x (ex-613a p) x₁

ex-613b :
  ∀ {n P Q}{S₁ S₂ S₃ : St n}
  → 〈 P 〉 (S₁ , S₂) , S₃ 〈 Q 〉
  → 〈 P 〉 S₁ , (S₂ , S₃) 〈 Q 〉
ex-613b (p₁ , p₂) with split p₁
... | _ , (p₁₁ , p₁₂) = p₁₁ , (p₁₂ , p₂)
ex-613b (cons x p x₁) = cons x (ex-613b p) x₁

{-
Now we set out to prove soundess and completeness of our Hoare logic (see chapter 6.3).

Note that we express validity of a Hoare triple in terms of the weakest liberal precondition:

  ⊨ₚ { P } S { Q }  :=   (P ==> wlp S Q)

This is just a notational conveneince, but for some reason I also find it pleasing to the eye.

-}

-- Weakest liberal precondition
------------------------------------------------------------

wlp : ∀ {n} → St n → (State n → Set) → State n → Set
wlp S Q s = ∀ {s'} → ⟨ S , s ⟩⟱ s' → Q s'

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

{-
This proof is the same as in the book, because it's rather simple and there's not
much choice.
-}

sound : ∀ {n}{S : St n}{P Q} → 〈 P 〉 S 〈 Q 〉 → (P ==> wlp S Q)
sound skip ps skip                         = ps
sound ass ps ass                           = ps
sound (p , p₁) ps (run , run₁)             = sound p₁ (sound p ps run) run₁
sound (if p p₁) ps (if-true x run)         = sound p (x , ps) run
sound (if p p₁) ps (if-false x run)        = sound p₁ (x , ps) run
sound (while p) ps (while-true x run run₁) = sound (while p) (sound p (x , ps) run) run₁
sound (while p) ps (while-false x)         = x , ps
sound (cons x p x₁) ps run                 = x₁ (sound p (x ps) run)

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

{-
This one differs from the book proof.

The book proves the following:

  ∀ S Q → 〈 wlp S Q 〉 S 〈 Q 〉

then uses "cons" and the definition of "wlp" to infer 〈 P 〉 S 〈 Q 〉 from (P ==> wlp S Q).

We instead prove completeness directly. Our job here is essentially to recurse on sub-statements,
while making the postcondition of that statement equal to the weakest precondition of the following
statement.

As a result, the proofs for the "if_then_else_" , composition and "while" cases are all
a bit simpler than the book proofs.

In the case of "while", the book makes an unnecessary twist. It uses the law of excluded middle
on "〈 while b do S , s' 〉⟶ s''" derivations, but there's actually no need for that. It would be
indeed ugly in Agda, where we would have to assume classical logic and destroy constructivity
in order to be able to write that proof.

-}

complete : ∀ {n}(S : St n){P Q} → (P ==> wlp S Q) → 〈 P 〉 S 〈 Q 〉
complete (x := a) f = cons (λ z → f z ass) ass id
complete skip     f = cons (λ z → f z skip) skip id

complete (S , S₁){P}{Q} f =
    complete S {P} {wlp S₁ Q} (λ ps runS runS₁ → f ps (runS , runS₁))
  , complete S₁ id

complete (if b then S else S₁){P}{Q} f =
  if (complete S  {(T ∘ ⟦ b ⟧ᵉ) ∧ P} {Q} (λ {(pb , pP) → λ runS → f pP (if-true pb runS)}))
     (complete S₁ {(F ∘ ⟦ b ⟧ᵉ) ∧ P} {Q} (λ {(pb , pP) → λ runS₁ → f pP (if-false pb runS₁)}))

complete (while b do S){P}{Q} f =
  cons f
    (while
      (complete S {(T ∘ ⟦ b ⟧ᵉ) ∧ W} {W}
        (λ {(pb , pw) → λ runS runW → pw (while-true pb runS runW)})))
    (λ {(pb , pw) → pw (while-false pb)})
  where W = wlp (while b do S) Q


module Generic.Lib.Decidable where

open import Relation.Nullary public
open import Relation.Nullary.Decidable hiding (map) public
open import Relation.Binary using (Decidable) public

open import Generic.Lib.Intro
open import Generic.Lib.Equality.Propositional
open import Generic.Lib.Equality.Heteroindexed
open import Generic.Lib.Data.Sum
open import Generic.Lib.Data.Product

open import Relation.Nullary
import Data.String as String

infix 3 _#_

IsSet : ∀ {α} -> Set α -> Set α
IsSet A = Decidable {A = A} _≡_

record Eq {α} (A : Set α) : Set α where
  infixl 5 _≟_ _==_

  field _≟_ : IsSet A

  _==_ : A -> A -> Bool
  x == y = ⌊ x ≟ y ⌋
open Eq {{...}} public

record _↦_ {α} (A B : Set α) : Set α where
  constructor packInj
  field
    to      : A -> B
    from    : B -> A
    from-to : from ∘ to ≗ id

-- Can't make it an instance, because otherwise it unreasonably breaks instance search.
viaInj : ∀ {α} {A B : Set α} {{bEq : Eq B}} -> A ↦ B -> Eq A
viaInj {A = A} {B} inj = record
  { _≟_ = flip (via-injection {A = ≡-Setoid A} {B = ≡-Setoid B}) _≟_ $ record
      { to        = record
          { _⟨$⟩_ = to
          ; cong  = cong to
          }
      ; injective = λ q -> right (from-to _) (trans (cong from q) (from-to _))
      }
  } where open _↦_ inj

_#_ : ∀ {α} {A : Set α} -> A -> A -> Set
x # y = Dec (x ≡ y)

delim : ∀ {α π} {A : Set α} {P : Dec A -> Set π}
      -> (∀ x -> P (yes x)) -> (∀ c -> P (no c)) -> (d : Dec A) -> P d
delim f g (yes x) = f x
delim f g (no  c) = g c

drec : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> (¬ A -> B) -> Dec A -> B
drec = delim

dmap : ∀ {α β} {A : Set α} {B : Set β} -> (A -> B) -> (¬ A -> ¬ B) -> Dec A -> Dec B
dmap f g = drec (yes ∘ f) (no ∘ g)

sumM2 : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ}
      -> (A -> Dec C) -> (B -> Dec C) -> (¬ A -> ¬ B -> Dec C) -> Dec A -> Dec B -> Dec C
sumM2 f g h d e = drec f (λ c -> drec g (h c) e) d

prodM2 : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ}
       -> (A -> B -> Dec C) -> (¬ A -> Dec C) -> (¬ B -> Dec C) -> Dec A -> Dec B -> Dec C
prodM2 h f g d e = drec (λ x -> drec (h x) g e) f d

sumF2 : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ}
      -> (A -> C) -> (B -> C) -> (¬ A -> ¬ B -> ¬ C) -> Dec A -> Dec B -> Dec C
sumF2 f g h = sumM2 (yes ∘ f) (yes ∘ g) (no % ∘ h)

prodF2 : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ}
       -> (A -> B -> C) -> (¬ A -> ¬ C) -> (¬ B -> ¬ C) -> Dec A -> Dec B -> Dec C
prodF2 h f g = prodM2 (yes % ∘ h) (no ∘ f) (no ∘ g)

dcong : ∀ {α β} {A : Set α} {B : Set β} {x y}
      -> (f : A -> B) -> (f x ≡ f y -> x ≡ y) -> x # y -> f x # f y
dcong f inj = dmap (cong f) (_∘ inj)

dcong₂ : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ} {x₁ x₂ y₁ y₂}
       -> (f : A -> B -> C)
       -> (f x₁ y₁ ≡ f x₂ y₂ -> x₁ ≡ x₂ × y₁ ≡ y₂)
       -> x₁ # x₂
       -> y₁ # y₂
       -> f x₁ y₁ # f x₂ y₂
dcong₂ f inj = prodF2 (cong₂ f) (λ c -> c ∘ proj₁ ∘ inj) (λ c -> c ∘ proj₂ ∘ inj)

dhcong₂ : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : Set γ} {x₁ x₂ y₁ y₂}
        -> (f : ∀ x -> B x -> C)
        -> (f x₁ y₁ ≡ f x₂ y₂ -> [ B ] y₁ ≅ y₂)
        -> x₁ # x₂
        -> (∀ y₂ -> y₁ # y₂)
        -> f x₁ y₁ # f x₂ y₂
dhcong₂ f inj (yes refl) q = dcong (f _) (homo ∘ inj) (q _)
dhcong₂ f inj (no  c)    q = no (c ∘ inds ∘ inj)

dsubst : ∀ {α β γ} {A : Set α} {x y}
       -> (B : A -> Set β)
       -> (C : ∀ {x} -> B x -> Set γ)
       -> x # y
       -> (z : B x)
       -> ((z : B y) -> C z)
       -> (x ≢ y -> C z)
       -> C z
dsubst B C (yes refl) z g h = g z
dsubst B C (no  c)    z g h = h c

dsubst′ : ∀ {α β γ} {A : Set α} {C : Set γ} {x y}
        -> (B : A -> Set β) -> x # y -> B x -> (B y -> C) -> (x ≢ y -> C) -> C
dsubst′ B = dsubst B _

,-inj : ∀ {α β} {A : Set α} {B : A -> Set β} {x₁ x₂} {y₁ : B x₁} {y₂ : B x₂}
      -> (x₁ , y₁) ≡ (x₂ , y₂) -> [ B ] y₁ ≅ y₂
,-inj refl = irefl

inj₁-inj : ∀ {α β} {A : Set α} {B : Set β} {x₁ x₂ : A}
         -> inj₁ {B = B} x₁ ≡ inj₁ x₂ -> x₁ ≡ x₂
inj₁-inj refl = refl

inj₂-inj : ∀ {α β} {A : Set α} {B : Set β} {y₁ y₂ : B}
         -> inj₂ {A = A} y₁ ≡ inj₂ y₂ -> y₁ ≡ y₂
inj₂-inj refl = refl

-- _<,>ᵈ_ : ∀ {α β} {A : Set α} {B : Set β} {x₁ x₂ : A} {y₁ y₂ : B}
--        -> x₁ # x₂ -> y₁ # y₂ -> x₁ , y₁ # x₂ , y₂
-- _<,>ᵈ_ = dcong₂ _,_ (inds-homo ∘ ,-inj)

-- _<,>ᵈᵒ_ : ∀ {α β} {A : Set α} {B : A -> Set β} {x₁ x₂} {y₁ : B x₁} {y₂ : B x₂}
--         -> x₁ # x₂ -> (∀ y₂ -> y₁ # y₂) -> x₁ , y₁ # x₂ , y₂
-- _<,>ᵈᵒ_ = dhcong₂ _,_ ,-inj

decSum : ∀ {α β} {A : Set α} {B : Set β}
       -> IsSet A -> IsSet B -> IsSet (A ⊎ B)
decSum f g (inj₁ x₁) (inj₁ x₂) = dcong inj₁ inj₁-inj (f x₁ x₂)
decSum f g (inj₂ y₁) (inj₂ y₂) = dcong inj₂ inj₂-inj (g y₁ y₂)
decSum f g (inj₁ x₁) (inj₂ y₂) = no λ()
decSum f g (inj₂ y₁) (inj₁ x₂) = no λ()

decProd : ∀ {α β} {A : Set α} {B : A -> Set β}
        -> IsSet A -> (∀ {x} -> IsSet (B x)) -> IsSet (Σ A B)
decProd f g (x₁ , y₁) (x₂ , y₂) = dhcong₂ _,_ ,-inj (f x₁ x₂) (g y₁)

module _ where
  import Relation.Binary.PropositionalEquality as B

  liftBase : ∀ {α} {A : Set α} {x y : A} -> x B.≡ y -> x ≡ y
  liftBase B.refl = refl

  lowerBase : ∀ {α} {A : Set α} {x y : A} -> x ≡ y -> x B.≡ y
  lowerBase refl = B.refl

  viaBase : ∀ {α} {A : Set α} -> Decidable (B._≡_ {A = A}) -> Eq A
  viaBase d = record
    { _≟_ = flip (via-injection {A = ≡-Setoid _} {B = B.setoid _}) d $ record
        { to = record
            { _⟨$⟩_ = id
            ; cong  = lowerBase
            }
        ; injective = liftBase
        }
    }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Core lemmas for division and modulus operations
------------------------------------------------------------------------

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

module Data.Nat.DivMod.Core where

open import Agda.Builtin.Nat using ()
  renaming (div-helper to divₕ; mod-helper to modₕ)

open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality

open ≡-Reasoning

-------------------------------------------------------------------------
-- mod lemmas

modₕ-skipTo0 : ∀ acc n a b → modₕ acc n (b + a) a ≡ modₕ (a + acc) n b 0
modₕ-skipTo0 acc n zero    b = cong (λ v → modₕ acc n v 0) (+-identityʳ b)
modₕ-skipTo0 acc n (suc a) b = begin
  modₕ acc n (b + suc a) (suc a) ≡⟨ cong (λ v → modₕ acc n v (suc a)) (+-suc b a) ⟩
  modₕ acc n (suc b + a) (suc a) ≡⟨⟩
  modₕ (suc acc) n (b + a) a     ≡⟨ modₕ-skipTo0 (suc acc) n a b ⟩
  modₕ (a + suc acc) n b 0       ≡⟨ cong (λ v → modₕ v n b 0) (+-suc a acc) ⟩
  modₕ (suc a + acc) n b 0       ∎

modₕ-skipToEnd : ∀ acc n a b → modₕ acc n a (a + b) ≡ acc + a
modₕ-skipToEnd acc n zero    b = sym (+-identityʳ acc)
modₕ-skipToEnd acc n (suc a) b = begin
  modₕ (suc acc) n a (a + b) ≡⟨ modₕ-skipToEnd (suc acc) n a b ⟩
  suc acc + a                ≡⟨ sym (+-suc acc a) ⟩
  acc + suc a                ∎

a[modₕ]1≡0 : ∀ a → modₕ 0 0 a 0 ≡ 0
a[modₕ]1≡0 zero    = refl
a[modₕ]1≡0 (suc a) = a[modₕ]1≡0 a

n[modₕ]n≡0 : ∀ acc v → modₕ acc (acc + v) (suc v) v ≡ 0
n[modₕ]n≡0 acc v = modₕ-skipTo0 acc (acc + v) v 1

a[modₕ]n<n : ∀ acc d n → modₕ acc (acc + n) d n ≤ acc + n
a[modₕ]n<n acc zero    n       = m≤m+n acc n
a[modₕ]n<n acc (suc d) zero    = a[modₕ]n<n zero d (acc + 0)
a[modₕ]n<n acc (suc d) (suc n)
           rewrite +-suc acc n = a[modₕ]n<n (suc acc) d n

modₕ-idem : ∀ acc a n → modₕ 0 (acc + n) (modₕ acc (acc + n) a n) (acc + n) ≡ modₕ acc (acc + n) a n
modₕ-idem acc zero    n       = modₕ-skipToEnd 0 (acc + n) acc n
modₕ-idem acc (suc a) zero    rewrite +-identityʳ acc = modₕ-idem 0 a acc
modₕ-idem acc (suc a) (suc n) rewrite +-suc acc n = modₕ-idem (suc acc) a n

a+n[modₕ]n≡a[modₕ]n : ∀ acc a n → modₕ acc (acc + n) (acc + a + suc n) n ≡ modₕ acc (acc + n) a n
a+n[modₕ]n≡a[modₕ]n acc zero n rewrite +-identityʳ acc = begin
  modₕ acc (acc + n) (acc + suc n) n   ≡⟨ cong (λ v → modₕ acc (acc + n) v n) (+-suc acc n) ⟩
  modₕ acc (acc + n) (suc acc + n) n   ≡⟨ modₕ-skipTo0 acc (acc + n) n (suc acc) ⟩
  modₕ (acc + n) (acc + n) (suc acc) 0 ≡⟨⟩
  modₕ 0 (acc + n) acc (acc + n)       ≡⟨ modₕ-skipToEnd 0 (acc + n) acc n ⟩
  acc                                  ∎
a+n[modₕ]n≡a[modₕ]n acc (suc a) zero rewrite +-identityʳ acc = begin
  modₕ acc acc (acc + suc a + 1)   0   ≡⟨ cong (λ v → modₕ acc acc v 0) (+-comm (acc + suc a) 1) ⟩
  modₕ acc acc (1 + (acc + suc a)) 0   ≡⟨⟩
  modₕ 0   acc (acc + suc a)       acc ≡⟨ cong (λ v → modₕ 0 acc v acc) (+-comm acc (suc a)) ⟩
  modₕ 0   acc (suc a + acc)       acc ≡⟨ cong (λ v → modₕ 0 acc v acc) (sym (+-suc a acc)) ⟩
  modₕ 0   acc (a + suc acc)       acc ≡⟨ a+n[modₕ]n≡a[modₕ]n 0 a acc ⟩
  modₕ 0   acc a                   acc ∎
a+n[modₕ]n≡a[modₕ]n acc (suc a) (suc n) rewrite +-suc acc n = begin
  mod₁ (acc + suc a + (2 + n)) (suc n) ≡⟨ cong (λ v → mod₁ (v + suc (suc n)) (suc n)) (+-suc acc a) ⟩
  mod₁ (suc acc + a + (2 + n)) (suc n) ≡⟨⟩
  mod₂ (acc + a + (2 + n))     n       ≡⟨ cong (λ v → mod₂ v n) (sym (+-assoc (acc + a) 1 (suc n))) ⟩
  mod₂ (acc + a + 1 + suc n)   n       ≡⟨ cong (λ v → mod₂ (v + suc n) n) (+-comm (acc + a) 1) ⟩
  mod₂ (suc acc + a + suc n)   n       ≡⟨ a+n[modₕ]n≡a[modₕ]n (suc acc) a n ⟩
  mod₂ a                       n       ∎
  where
  mod₁ = modₕ acc       (suc acc + n)
  mod₂ = modₕ (suc acc) (suc acc + n)

-------------------------------------------------------------------------
-- division lemmas

-- The quotient and remainder are related to the dividend and
-- divisor in the right way.

division-lemma : ∀ accᵐ accᵈ d n →
    accᵐ + accᵈ * suc (accᵐ + n) + d ≡
    modₕ accᵐ (accᵐ + n) d n + divₕ accᵈ (accᵐ + n) d n * suc (accᵐ + n)
division-lemma accᵐ accᵈ zero    n    = +-identityʳ _
division-lemma accᵐ accᵈ (suc d) zero rewrite +-identityʳ accᵐ = begin
  accᵐ + accᵈ * suc accᵐ + suc d          ≡⟨ +-suc _ d ⟩
  suc accᵈ * suc accᵐ + d                 ≡⟨ division-lemma zero (suc accᵈ) d accᵐ ⟩
  modₕ 0          accᵐ d accᵐ +
  divₕ (suc accᵈ) accᵐ d accᵐ * suc accᵐ  ≡⟨⟩
  modₕ accᵐ accᵐ (suc d) 0 +
  divₕ accᵈ accᵐ (suc d) 0 * suc accᵐ     ∎
division-lemma accᵐ accᵈ (suc d) (suc n) rewrite +-suc accᵐ n = begin
  accᵐ + accᵈ * m + suc d             ≡⟨ +-suc _ d ⟩
  suc (accᵐ + accᵈ * m + d)           ≡⟨ division-lemma (suc accᵐ) accᵈ d n ⟩
  modₕ _ _ d n + divₕ accᵈ _ d n * m  ∎
  where
  m = 2 + accᵐ + n


{-# OPTIONS --cubical --no-import-sorts --postfix-projections #-}
module Cubical.Codata.M.Bisimilarity where

open import Cubical.Core.Everything
open import Cubical.Codata.M
open import Cubical.Foundations.Equiv.Fiberwise
open import Cubical.Foundations.Everything
open Helpers using (J')

-- Bisimilarity as a coinductive record type.
record _≈_ {X : Type₀} {C : IxCont X} {x : X} (a b : M C x) : Type₀ where
  coinductive
  constructor _,_
  field
    head≈ : a .head ≡ b .head
    tails≈ : ∀ y → (pa : C .snd x (a .head) y) (pb : C .snd x (b .head) y)
             → (\ i → C .snd x (head≈ i) y) [ pa ≡ pb ]
             → a .tails y pa ≈ b .tails y pb

open _≈_ public

module _ {X : Type₀} {C : IxCont X} where

  -- Here we show that `a ≡ b` and `a ≈ b` are equivalent.
  --
  -- A direct construction of an isomorphism, like we do for streams,
  -- would be complicated by the type dependencies between the fields
  -- of `M C x` and even more so between the fields of the bisimilarity relation itself.
  --
  -- Instead we rely on theorem 4.7.7 of the HoTT book (fiberwise equivalences) to show that `misib` is an equivalence.

  misib : {x : X} (a b : M C x) → a ≡ b → a ≈ b
  misib a b eq .head≈ i          = eq i .head
  misib a b eq .tails≈ y pa pb q = misib (a .tails y pa) (b .tails y pb) (\ i → eq i .tails y (q i))

  -- With `a` fixed, `misib` is a fiberwise transformation between (a ≡_) and (a ≈_).
  --
  -- We show that the induced map on the total spaces is an
  -- equivalence because it is a map of contractible types.
  --
  -- The domain is the HoTT singleton type, so contractible, while the
  -- codomain is shown to be contractible by `contr-T` below.

  T : ∀ {x} → M C x → Type _
  T a = Σ (M C _) \ b → a ≈ b

  private
    lemma : ∀ {A} (B : Type₀) (P : A ≡ B) (pa : P i0) (pb : P i1) (peq : PathP (\ i → P i) pa pb)
          → PathP (\ i → PathP (\ j → P j) (transp (\ k → P (~ k ∧ i)) (~ i) (peq i)) pb)
                  peq
                  (\ j → transp (\ k → P (~ k ∨ j)) j pb)
    lemma {A} = J' _ \ pa → J' _ \ { i j → transp (\ _ → A) (~ i ∨ j) pa }

  -- We predefine `u'` so that Agda will agree that `contr-T-fst` is productive.
  private
    module Tails x a φ (u : Partial φ (T {x} a)) y (p : C .snd x (hcomp (λ i .o → u o .snd .head≈ i) (a .head)) y) where
      q = transp (\ i → C .snd x (hfill (\ i o → u o .snd .head≈ i) (inS (a .head)) (~ i)) y) i0 p
      a' = a .tails y q
      u' : Partial φ (T a')
      u' (φ = i1) = u 1=1 .fst .tails y p
                  , u 1=1 .snd .tails≈ y q p \ j → transp (\ i → C .snd x (u 1=1 .snd .head≈ (~ i ∨ j)) y) j p

  contr-T-fst : ∀ x a φ → Partial φ (T {x} a) → M C x
  contr-T-fst x a φ u .head      = hcomp (\ i o → u o .snd .head≈ i) (a .head)
  contr-T-fst x a φ u .tails y p = contr-T-fst y a' φ u'
    where
      open Tails x a φ u y p

  -- `contr-T-snd` is productive as the corecursive call appears as
  -- the main argument of transport, which is guardedness-preserving.
  {-# TERMINATING #-}
  contr-T-snd : ∀ x a φ → (u : Partial φ (T {x} a)) → a ≈ contr-T-fst x a φ u
  contr-T-snd x a φ u .head≈ i = hfill (λ { i (φ = i1) → u 1=1 .snd .head≈ i }) (inS (a .head)) i
  contr-T-snd x a φ u .tails≈ y pa pb peq =
    let r = contr-T-snd y (a .tails y pa) φ (\ { (φ = i1) → u 1=1 .fst .tails y pb , u 1=1 .snd .tails≈ y pa pb peq }) in
      transport (\ i → a .tails y pa
                ≈ contr-T-fst y (a .tails y (sym (fromPathP (\ i → peq (~ i))) i)) φ
                  (\ { (φ = i1) → u 1=1 .fst .tails y pb , u 1=1 .snd .tails≈ y
                                  ((fromPathP (\ i → peq (~ i))) (~ i)) pb
                                  \ j → lemma _ (λ h → C .snd x (u _ .snd .head≈ h) y) pa pb peq i j })) r

  contr-T : ∀ x a φ → Partial φ (T {x} a) → T a
  contr-T x a φ u .fst = contr-T-fst x a φ u
  contr-T x a φ u .snd = contr-T-snd x a φ u

  contr-T-φ-fst : ∀ x a → (u : Partial i1 (T {x} a)) → contr-T x a i1 u .fst ≡ u 1=1 .fst
  contr-T-φ-fst x a u i .head = u 1=1 .fst .head
  contr-T-φ-fst x a u i .tails y p
   = let
        q = (transp (\ i → C .snd x (hfill (\ i o → u o .snd .head≈ i) (inS (a .head)) (~ i)) y) i0 p)
      in contr-T-φ-fst y (a .tails y q)
                       (\ o → u o .fst .tails y p
                            , u o .snd .tails≈ y q p \ j → transp (\ i → C .snd x (u 1=1 .snd .head≈ (~ i ∨ j)) y) j p)
                       i

  -- `contr-T-φ-snd` is productive as the corecursive call appears as
  -- the main argument of transport, which is guardedness-preserving (even for paths of a coinductive type).
  {-# TERMINATING #-}
  contr-T-φ-snd : ∀ x a → (u : Partial i1 (T {x} a)) → (\ i → a ≈ contr-T-φ-fst x a u i) [ contr-T x a i1 u .snd ≡ u 1=1 .snd ]
  contr-T-φ-snd x a u i .head≈ = u _ .snd .head≈
  contr-T-φ-snd x a u i .tails≈ y pa pb peq = let
    eqh = u 1=1 .snd .head≈
    r = contr-T-φ-snd y (a .tails y pa) (\ o → u o .fst .tails y pb , u 1=1 .snd .tails≈ y pa pb peq)
    F : I → Type _
    F k = a .tails y pa
        ≈ contr-T-fst y
            (a .tails y (transp (λ j → C .snd x (eqh (k ∧ ~ j)) y) (~ k) (peq k)))
            i1
            (λ _ → u _ .fst .tails y pb
                 , u _ .snd .tails≈ y
                       (transp (λ j → C .snd x (eqh (k ∧ ~ j)) y) (~ k) (peq k))
                       pb
                       (λ j → lemma (C .snd x (u 1=1 .fst .head) y) (λ h → C .snd x (eqh h) y) pa pb peq k j)
             )
    u0 = contr-T-snd y (a .tails y pa) i1 (λ o → u o .fst .tails y pb , u o .snd .tails≈ y pa pb peq)
   in transport
         (λ l → PathP
           (λ z → a .tails y pa
                ≈ contr-T-φ-fst y
                   (a .tails y (transp (λ k → C .snd x (u 1=1 .snd .head≈ (~ k ∧ l)) y) (~ l) (peq l)))
                   (λ _ → u _ .fst .tails y pb
                        , u _ .snd .tails≈ y (transp (λ k → C .snd x (u _ .snd .head≈ (~ k ∧ l)) y) (~ l) (peq l)) pb
                               \ j → lemma (C .snd x (u 1=1 .fst .head) y) (λ h → C .snd x (eqh h) y) pa pb peq l j)
                   z)
           (transpFill {A = F i0} i0 (\ i → inS (F i)) u0 l)
           (u _ .snd .tails≈ y pa pb peq))
         r
         i

  contr-T-φ : ∀ x a → (u : Partial i1 (T {x} a)) → contr-T x a i1 u ≡ u 1=1
  contr-T-φ x a u i .fst = contr-T-φ-fst x a u i
  contr-T-φ x a u i .snd = contr-T-φ-snd x a u i

  contr-T' : ∀ {x} a → isContr (T {x} a)
  contr-T' a = isContrPartial→isContr (contr-T _ a) \ u → sym (contr-T-φ _ a (\ _ → u))

  bisimEquiv : ∀ {x} {a b : M C x} → isEquiv (misib a b)
  bisimEquiv = isContrToUniv _≈_ (misib _ _) contr-T'


open import Level using (_⊔_)
open import Data.Maybe using (Maybe; nothing; just)
open import Data.List.Any as A hiding (map)
open import Relation.Binary.PropositionalEquality.Core as PropEq
open import Relation.Binary

open import Prelude hiding (map)
open Eq {{...}}

module RW.Data.PMap (A : Set){{eqA : Eq A}} where

  private
    _≟_ : (a₁ a₂ : A) → Dec (a₁ ≡ a₂)
    a₁ ≟ a₂ = Eq.cmp eqA a₁ a₂

  -- Naive Partial Map representation
  to_ : ∀{b} → Set b → Set b
  to B = List (A × B)

  to_default : ∀{b} → Set b → Set b
  to B default = B × List (A × B)

  onDef : ∀{b c}{B : Set b}{C : Set c}
        → (m : to B → C) → to B default → C
  onDef f (_ , m) = f m

  onDef' : ∀{b}{B : Set b}
         → (m : to B → to B) → to B default → to B default
  onDef' f (def , m) = def , f m

  empty : ∀{b}{B : Set b}
        → to B
  empty = []

  -- Membership
  _∈_ : ∀{b}{B : Set b}
      → A → (to B) → Set _
  a ∈ m = A.Any ((_≡_ a) ∘ p1) m

  _∉_ : ∀{b}{B : Set b}
      → A → (to B) → Set _
  a ∉ m = (a ∈ m) → ⊥

  -- Decidable membership
  dec∈ : ∀{b}{B : Set b}
       → (a : A) → (m : to B) → Dec (a ∈ m)
  dec∈ a [] = no (λ ())
  dec∈ a (x ∷ m) with a ≟ (p1 x)
  ...| yes a≡x = yes (here a≡x)
  ...| no  a≢x with dec∈ a m
  ...| yes a∈m = yes (there a∈m)
  ...| no  a∉m = no (a∉m ∘ tail a≢x)

  -- Look up
  lkup : ∀{b}{B : Set b} → A → (to B) → Maybe B
  lkup k [] = nothing
  lkup k ((h , r) ∷ ts)
    with k ≟ h
  ...| yes _ = just r
  ...| no  _ = lkup k ts

  -- Look up in a map with a default value
  lkupDef : ∀{b}{B : Set b} → A → to B default → B
  lkupDef a (b , m) = maybe id b (lkup a m)

  -- Total version
  lkup' : ∀{b}{B : Set b}
        → (a : A) → (m : to B) → a ∈ m → B
  lkup' a (m ∷ _)  (here px)   = p2 m
  lkup' a (_ ∷ ms) (there prf) = lkup' a ms prf

  -- Insertion / Removal
  alter : ∀{b}{B : Set b}
        → (Maybe B → Maybe B) → A → (to B) → (to B)
  alter f a [] with f nothing
  ...| just b  = (a , b) ∷ []
  ...| nothing = []
  alter f a (x ∷ m) with a ≟ p1 x
  ...| no  _ = x ∷ alter f a m
  ...| yes _ with f $ just (p2 x)
  ...| nothing = m
  ...| just b  = (a , b) ∷ m

  alterPrf : ∀{b}{B : Set b}
           → B → (a : A) → (m : to B) → Σ (to B) (_∈_ a)
  alterPrf b a m with dec∈ a m
  ...| yes a∈m = m , a∈m
  ...| no  a∉m = (a , b) ∷ m , here refl

  insert : ∀{b}{B : Set b}
         → A → B → (to B) → (to B)
  insert a b m = alter (const $ just b) a m

  delete : ∀{b}{B : Set b}
         → A → (to B) → (to B)
  delete a m = alter (const nothing) a m

  -- Map
  map : ∀{b}{B B′ : Set b} → (B → B′) → (to B) → (to B′)
  map f [] = []
  map f ((a , b) ∷ m) = (a , f b) ∷ map f m


-- Andreas, 2017-10-04, ignore irrelevant arguments during with-abstraction
-- Feature request by xekoukou

{-# OPTIONS --allow-unsolved-metas --show-irrelevant #-}

-- {-# OPTIONS -v tc.abstract:100 #-}

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

not : Bool → Bool
not true  = false
not false = true

but : Bool → .(Bool → Bool) → Bool
but true  f = false
but false f = true

test : (x : Bool) → but x not ≡ true
test x with but x not' where
  not' : Bool → Bool
  not' true  = false
  not' false = true
test x | true = refl
test x | false = _  -- unsolved meta ok


------------------------------------------------------------------------
-- The Agda standard library
--
-- N-ary products
------------------------------------------------------------------------

-- Vectors (as in Data.Vec) also represent n-ary products, so what is
-- the point of this module? The n-ary products below are intended to
-- be used with a fixed n, in which case the nil constructor can be
-- avoided: pairs are represented as pairs (x , y), not as triples
-- (x , y , unit).

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

module Data.Product.N-ary where

open import Data.Nat as Nat hiding (_^_)
open import Data.Fin hiding (lift)
open import Data.Product as P using (_×_ ; _,_ ; ∃₂ ; uncurry)
open import Data.Sum using (_⊎_)
open import Data.Unit
open import Data.Empty
open import Function
open import Level using (Lift; lift)
open import Relation.Binary.PropositionalEquality using (_≡_)

-- Types and patterns
------------------------------------------------------------------------

pattern 2+_ n = suc (suc n)

infix 8 _^_
_^_ : ∀ {ℓ} → Set ℓ → ℕ → Set ℓ
A ^ 0    = Lift _ ⊤
A ^ 1    = A
A ^ 2+ n = A × A ^ suc n

pattern [] = lift tt

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

  infix 3 _∈[_]_
  _∈[_]_ : A → ∀ n → A ^ n → Set a
  a ∈[ 0    ] as      = Lift _ ⊥
  a ∈[ 1    ] a′      = a ≡ a′
  a ∈[ 2+ n ] a′ , as = a ≡ a′ ⊎ a ∈[ suc n ] as

-- Basic operations
------------------------------------------------------------------------

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

  cons : ∀ n → A → A ^ n → A ^ suc n
  cons 0       a _  = a
  cons (suc n) a as = a , as

  uncons : ∀ n → A ^ suc n → A × A ^ n
  uncons 0        a        = a , lift tt
  uncons (suc n)  (a , as) = a , as

  head : ∀ n → A ^ suc n → A
  head n as = P.proj₁ (uncons n as)

  tail : ∀ n → A ^ suc n → A ^ n
  tail n as = P.proj₂ (uncons n as)

  lookup : ∀ {n} (k : Fin n) → A ^ n → A
  lookup {suc n} zero    = head n
  lookup {suc n} (suc k) = lookup k ∘′ tail n

  replicate : ∀ n → A → A ^ n
  replicate 0      a = []
  replicate 1      a = a
  replicate (2+ n) a = a , replicate (suc n) a

  tabulate : ∀ n → (Fin n → A) → A ^ n
  tabulate 0      f = []
  tabulate 1      f = f zero
  tabulate (2+ n) f = f zero , tabulate (suc n) (f ∘′ suc)

  append : ∀ m n → A ^ m → A ^ n → A ^ (m Nat.+ n)
  append 0      n xs       ys = ys
  append 1      n x        ys = cons n x ys
  append (2+ m) n (x , xs) ys = x , append (suc m) n xs ys

  splitAt : ∀ m n → A ^ (m Nat.+ n) → A ^ m × A ^ n
  splitAt 0       n xs = [] , xs
  splitAt (suc m) n xs =
    let (ys , zs) = splitAt m n (tail (m Nat.+ n) xs) in
    cons m (head (m Nat.+ n) xs) ys , zs

-- Manipulating N-ary products
------------------------------------------------------------------------

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

  map : (A → B) → ∀ n → A ^ n → B ^ n
  map f 0      as       = lift tt
  map f 1      a        = f a
  map f (2+ n) (a , as) = f a , map f (suc n) as

  ap : ∀ n → (A → B) ^ n → A ^ n → B ^ n
  ap 0      fs       ts       = []
  ap 1      f        t        = f t
  ap (2+ n) (f , fs) (t , ts) = f t , ap (suc n) fs ts

module _ {a p} {A : Set a} {P : ℕ → Set p} where

  foldr : P 0 → (A → P 1) → (∀ n → A → P (suc n) → P (2+ n)) →
          ∀ n → A ^ n → P n
  foldr p0 p1 p2+ 0      as       = p0
  foldr p0 p1 p2+ 1      a        = p1 a
  foldr p0 p1 p2+ (2+ n) (a , as) = p2+ n a (foldr p0 p1 p2+ (suc n) as)

foldl : ∀ {a p} {A : Set a} (P : ℕ → Set p) →
        P 0 → (A → P 1) → (∀ n → A → P (suc n) → P (2+ n)) →
        ∀ n → A ^ n → P n
foldl P p0 p1 p2+ 0      as       = p0
foldl P p0 p1 p2+ 1      a        = p1 a
foldl P p0 p1 p2+ (2+ n) (a , as) = let p1′ = p1 a in
  foldl (P ∘′ suc) p1′ (λ a → p2+ 0 a p1′) (p2+ ∘ suc) (suc n) as

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

  reverse : ∀ n → A ^ n → A ^ n
  reverse = foldl (A ^_) [] id (λ n → _,_)

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

  zipWith : (A → B → C) → ∀ n → A ^ n → B ^ n → C ^ n
  zipWith f 0      as       bs       = []
  zipWith f 1      a        b        = f a b
  zipWith f (2+ n) (a , as) (b , bs) = f a b , zipWith f (suc n) as bs

  unzipWith : (A → B × C) → ∀ n → A ^ n → B ^ n × C ^ n
  unzipWith f 0      as       = [] , []
  unzipWith f 1      a        = f a
  unzipWith f (2+ n) (a , as) = P.zip _,_ _,_ (f a) (unzipWith f (suc n) as)

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

  zip : ∀ n → A ^ n → B ^ n → (A × B) ^ n
  zip = zipWith _,_

  unzip : ∀ n → (A × B) ^ n → A ^ n × B ^ n
  unzip = unzipWith id


{-

This file contains:

- Properties of 2-groupoid truncations

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.2GroupoidTruncation.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.HITs.2GroupoidTruncation.Base

rec2GroupoidTrunc : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (gB : is2Groupoid B) → (A → B) → (∥ A ∥₂ → B)
rec2GroupoidTrunc gB f ∣ x ∣₂ = f x
rec2GroupoidTrunc gB f (squash₂ _ _ _ _ _ _ t u i j k l) =
  gB _ _ _ _ _ _
    (λ m n o → rec2GroupoidTrunc gB f (t m n o))
    (λ m n o → rec2GroupoidTrunc gB f (u m n o))
    i j k l

g2TruncFib : ∀ {ℓ ℓ'} {A : Type ℓ} (P : A → Type ℓ')
             {a b : A} (sPb : is2Groupoid (P b))
             {p q : a ≡ b} {r s : p ≡ q} {u v : r ≡ s} (w : u ≡ v) {a1 : P a} {b1 : P b}
             {p1 : PathP (λ i → P (p i)) a1 b1}
             {q1 : PathP (λ i → P (q i)) a1 b1}
             {r1 : PathP (λ i → PathP (λ j → P (r i j)) a1 b1) p1 q1}
             {s1 : PathP (λ i → PathP (λ j → P (s i j)) a1 b1) p1 q1}
             (u1 : PathP (λ i → PathP (λ j → PathP (λ k → P (u i j k)) a1 b1) p1 q1) r1 s1)
             (v1 : PathP (λ i → PathP (λ j → PathP (λ k → P (v i j k)) a1 b1) p1 q1) r1 s1)
           → PathP (λ i → PathP (λ j → PathP (λ k → PathP (λ l → P (w i j k l)) a1 b1) p1 q1) r1 s1) u1 v1
g2TruncFib {A} P {a} {b} sPb {p} {q} {r} {s} {u} {v} w
           {a1} {b1} {p1} {q1} {r1} {s1} u1 v1 i j k l
  = hcomp (λ m → λ { (i = i0) → u1 j k l
                   ; (i = i1) → v1 j k l
                   ; (j = i0) → r1 k l
                   ; (j = i1) → s1 k l
                   ; (k = i0) → p1 l
                   ; (k = i1) → q1 l
                   ; (l = i0) → a1
                   ; (l = i1) → sPb b1 b1 refl refl refl refl L refl m i j k
                   })
          (Lb i j k l)
  where
  L : Path (Path (b1 ≡ b1) refl refl) refl refl
  L i j k = comp (λ l → P (w i j k l))
                 (λ l → λ { (i = i0) → u1 j k l
                          ; (i = i1) → v1 j k l
                          ; (j = i0) → r1 k l
                          ; (j = i1) → s1 k l
                          ; (k = i0) → p1 l
                          ; (k = i1) → q1 l
                          })
                 a1
  Lb : PathP (λ i → PathP (λ j → PathP (λ k → PathP (λ l → P (w i j k l)) a1 (L i j k)) p1 q1) r1 s1) u1 v1
  Lb i j k l = fill (λ l → P (w i j k l))
                    (λ l → λ { (i = i0) → u1 j k l
                             ; (i = i1) → v1 j k l
                             ; (j = i0) → r1 k l
                             ; (j = i1) → s1 k l
                             ; (k = i0) → p1 l
                             ; (k = i1) → q1 l
                             })
                    (inS a1) l

g2TruncElim : ∀ {ℓ ℓ'} (A : Type ℓ) (B : ∥ A ∥₂ → Type ℓ')
                    (bG : (x : ∥ A ∥₂) → is2Groupoid (B x))
                    (f : (x : A) → B ∣ x ∣₂) (x : ∥ A ∥₂) → B x
g2TruncElim A B bG f ∣ x ∣₂ = f x
g2TruncElim A B bG f (squash₂ x y p q r s u v i j k l) =
  g2TruncFib {A = ∥ A ∥₂} B {x} {y} (bG y) {p} {q} {r} {s} {u} {v}
               (squash₂ x y p q r s u v)
               {g2TruncElim A B bG f x}
               {g2TruncElim A B bG f y}
               {λ i → g2TruncElim A B bG f (p i)}
               {λ i → g2TruncElim A B bG f (q i)}
               {λ i j → g2TruncElim A B bG f (r i j)}
               {λ i j → g2TruncElim A B bG f (s i j)}
               (λ i j k → g2TruncElim A B bG f (u i j k))
               (λ i j k → g2TruncElim A B bG f (v i j k))
               i j k l


open import Agda.Builtin.Equality
open import Agda.Builtin.Size

postulate
  P : (A : Set₁) → A → Set₁
  p : (i : Size) (f : {_ : Size< i} → Set) (x : _) →
      P ({_ : Size< i} → Set) f


-- Andreas, 2018-04-10, issue #3581, reported by 3abc, test case by Andrea

-- Regression in the termination checker introduced together
-- with collecting function calls also in the type signatures
-- (fix of #1556).

open import Agda.Builtin.Bool
open import Agda.Builtin.Nat

I = Bool
i0 = true
i1 = false

record PathP {l} (A : I → Set l) (x : A i0) (y : A i1) : Set l where
  field
    apply : ∀ i → A i

open PathP

_[_≡_] = PathP

_≡_ : ∀ {l} {A : Set l} → A → A → Set l
_≡_ {A = A} = PathP (\ _ → A)

refl : ∀ {l} {A : Set l} {x : A} → x ≡ x
refl {x = x} .apply _ = x

cong' : ∀ {l ℓ'} {A : Set l}{B : A → Set ℓ'} (f : (a : A) → B a) {x y} (p : x ≡ y)
     → PathP (λ i → B (p .apply i)) (f (p .apply i0)) (f (p .apply i1))
cong' f p .apply = λ i → f (p .apply i)

foo : Nat → Nat
foo zero = zero
foo (suc n) = Z .apply true .apply true
 where
 postulate
   Z : (\ _ → foo n ≡ foo n) [ (cong' foo (refl {x = n})) ≡ (\ { .apply i → cong' foo (refl {x = n}) .apply i }) ]


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

open import lib.Basics

module C1 {@♭ i₁ j₁ : ULevel}
          (@♭ I : Type i₁)
          (@♭ R : I → Type j₁)
          (@♭ r₀ : (index : I) → R index) where
  -- We assume the family R satisfies Axiom C0
  open import Axiom.C0 {i₁} {j₁} I R

  open import Basics
  open import Flat
  open import Sharp
  open import lib.types.Bool
  open import Bool

  open import lib.Equivalence2
  open import lib.types.Coproduct

  _is-discrete-C0 : {i : ULevel} (A : Type i) → Type _
  _is-discrete-C0 {i} A = (index : I) → (is-equiv {i = i} (λ (a : A) → (λ (r : R index) → a)))

  discrete-C0-eq : {i : ULevel} {A : Type i} (p : A is-discrete-C0) (index : I)
                   → A ≃ ((R index) → A)
  discrete-C0-eq p index = _ , (p index)

  prop-is-discrete-C0 : {i : ULevel} (P : PropT i) → (P holds) is-discrete-C0
  prop-is-discrete-C0 P =
    (λ index →
      is-eq to
            fro
            (λ f → λ= (λ r → prop-path (P holds-is-a-prop) (f (r₀ index)) (f r)))
            (λ p → prop-path (P holds-is-a-prop) (fro {index} (to p)) p))
      where
        to : {index : I} → P holds → (r : R index) → P holds
        to = λ p _ → p

        fro : {index : I} → ((r : R index) → P holds) → P holds
        fro {index} = λ f → f (r₀ index)

  crisp-prop-is-discrete : {@♭ i : ULevel} (@♭ P : PropT i) → (P holds) is-discrete
  crisp-prop-is-discrete P = C0 (P holds) (prop-is-discrete-C0 P)

  ⊥-is-discrete : ⊥ is-discrete
  ⊥-is-discrete = crisp-prop-is-discrete False

  -- Mapping into a C0 discrete gives a C0 discrete space.
  -- The argument is by swapping the order of application.
  Π-♭-C0 : {i j : ULevel} {A : Type i}
           {B : A → Type j} (p : (a : A) → (B a) is-discrete-C0)
           → ((a : A) → B a) is-discrete-C0
  Π-♭-C0 {A = A} {B = B} p =
    λ index → _ is-an-equivalence-because
      (fro index) is-inverse-by
        to-fro index and fro-to index
    where
      fro : (index : I) → ((R index) → (a : A) → B a) → (a : A) → B a
      fro index f a = (<– (discrete-C0-eq (p a) index)) (λ r → f r a)

      abstract
        to-fro : ∀ index f → (λ _ → fro index f) == f
        to-fro index f = -- We swap the order of r and a and use the discreteness of B a
          λ= $ λ r →
            λ= $ λ a →
              app= (lemma a) r
          where
            lemma : ∀ a → (λ _ → fro index f a) == (λ r → f r a)
            lemma a = <–-inv-r (discrete-C0-eq (p a) index) $ λ r → f r a

        fro-to : ∀ index f → (fro index (λ _ → f)) == f
        fro-to index f =
          λ= $ λ a →
            <–-inv-l (discrete-C0-eq (p a) index) $ f a

  -- Crisp propositions are codiscrete
  crisp-prop-is-codiscrete : {@♭ i : ULevel} (@♭ P : PropT i) → (P holds) is-codiscrete
  crisp-prop-is-codiscrete P =
    (P holds) is-codiscrete-because -- We give the map going the other way:
      ♯ (P holds) –⟨ map₁ ⟩→ ♭ (♯ (P holds)) –⟨ map₂ ⟩→ ♭ (P holds) –⟨ _↓♭ ⟩→ P holds →∎
        is-retract-by (λ _ → prop-path (snd P) _ _)
    where
      map₁ : ♯ (P holds) → ♭ (♯ (P holds))
      map₁ = <– (discrete-eq (crisp-prop-is-discrete (♯ₙ P)))

      map₂ : ♭ (♯ (P holds)) → ♭ (P holds)
      map₂ = –> ♭♯-eq

  ¬-is-codiscrete : ∀ {i} (A : Type i) → (¬ A) is-codiscrete
  ¬-is-codiscrete {i} A = -- mapping into a codiscrete is codiscrete.
    replete (Π-codisc {A = A} (λ _ → ⊥)) (lemma₁ ⁻¹)
    where
      lemma₁ : (A → ⊥) ≃ (A → ♯ ⊥)-- ⊥ is codiscrete b/c it is crisp.
      lemma₁ = post∘-equiv (codisc-eq (crisp-prop-is-codiscrete False))

      open import lib.types.Modality
      replete = (Modality.local-is-replete {i}) ♯-modality

  ♭-commutes-with-¬ : {@♭ i : ULevel} {@♭ A : Type i} → ♭ (¬ A) ≃ ¬ (♭ A)
  ♭-commutes-with-¬ {i = i} {A = A} =
                    ♭ (¬ A)
                  ≃⟨ ♭→e {A = ¬ A} {B = A → ♯ ⊥} lemma₁ ⟩
                    ♭ (A → ♯ ⊥)
                  ≃⟨ ♭♯-adjoint ⁻¹ ⟩
                     ♭ (¬ (♭ A))
                  ≃⟨ discrete-eq (crisp-prop-is-discrete (¬ (♭ A) , proof)) ⟩
                     ¬ (♭ A)
                  ≃∎
    where
      lemma₁ : (A → ⊥) ≃ (A → ♯ ⊥)-- ⊥ is codiscrete b/c it is crisp.
      lemma₁ = post∘-equiv (codisc-eq (crisp-prop-is-codiscrete False))

      proof : ¬ (♭ A) is-a-prop
      proof = mapping-into-prop-is-a-prop (λ _ → False holds-is-a-prop)

  -- Hereafter, we use LEM
  open import LEM
  open import NotNot

  module _ {@♭ i : ULevel} where
    record Γ : Type (lsucc i) where
      constructor ctx
      field
        ᶜP : PropT i
        ᶜnnp : ¬¬ (ᶜP holds) holds
    open Γ

    ♯-prop-is-¬¬ : (P : PropT i) → ((♯ₙ P) holds) ≃ ((¬¬ (P holds)) holds)
    ♯-prop-is-¬¬ P =
      iff-to-≃ {P = ♯ₙ P} {Q = ¬¬ (P holds)}
        -- ⇒
        (♯ₙ P holds
          –⟨ (λ a → let♯ u ^♯:= a in♯ ((continue u) ^♯)) ⟩→
        ♯ₙ (¬¬ (P holds)) holds
          –⟨ un♯ (¬-is-codiscrete (¬ (P holds))) ⟩→
        ¬¬ (P holds) holds
          →∎)
      -- ⇐
        (λ nnp → {!let♯ γ ::= (ctx P nnp) in♯ (helper (ᶜP γ) (ᶜnnp γ)) ^^♯-in-family (λ (@♭ γ : Γ) → (ᶜP γ) holds) !})
      where
        helper : (@♭ P : PropT i) → ((¬¬ (P holds)) holds) ::→ (P holds)
        helper P nnp = (un¬¬-crisp {P = P} nnp)


{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness
            --no-subtyping #-}

module Agda.Builtin.Equality.Erase where

open import Agda.Builtin.Equality

primitive primEraseEquality : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≡ y


{-# OPTIONS --safe --no-sized-types #-}

open import Agda.Builtin.Size

record Stream (A : Set) (i : Size) : Set where
  coinductive
  field
    head : A
    tail : {j : Size< i} → Stream A j

open Stream

destroy-guardedness : ∀ {A i} → Stream A i → Stream A i
destroy-guardedness xs .head = xs .head
destroy-guardedness xs .tail = xs .tail

repeat : ∀ {A i} → A → Stream A i
repeat x .head = x
repeat x .tail = destroy-guardedness (repeat x)


module TAlgebra where

open import Level
open import Data.Product
open import Relation.Binary
open Setoid

open import Basic
open import Category
import Functor
import Nat
import Adjoint
open import Monad

open Category.Category
open Functor.Functor
open Nat.Nat
open Nat.Export
open Adjoint.Export
open Monad.Monad

record TAlgebra {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} (T : Monad C) : Set (C₀ ⊔ C₁ ⊔ ℓ) where
  field
    Tobj : Obj C
    Tmap : Hom C (fobj (MFunctor T) Tobj) Tobj

  field
    join-fmap-alg : C [ C [ Tmap ∘ component (Mjoin T) Tobj ] ≈ C [ Tmap ∘ fmap (MFunctor T) Tmap ] ]
    map-unit : C [ C [ Tmap ∘ component (Munit T) Tobj ] ≈ id C ]

open TAlgebra

record TAlgMap {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} {T : Monad C} (a b : TAlgebra T) : Set (C₁ ⊔ ℓ) where
  field
    Thom : Hom C (Tobj a) (Tobj b)

  field
    hom-comm : C [ C [ Tmap b ∘ fmap (MFunctor T) Thom ] ≈ C [ Thom ∘ Tmap a ] ]

open TAlgMap

compose : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} {T : Monad C} {a b c : TAlgebra T} → TAlgMap b c → TAlgMap a b → TAlgMap a c
compose {C = C} {T} {a} {b} {c} f g = record {
  Thom = C [ Thom f ∘ Thom g ] ;
  hom-comm = begin⟨ C ⟩
    C [ Tmap c ∘ fmap (MFunctor T) (C [ Thom f ∘ Thom g ]) ] ≈⟨ ≈-composite C (refl-hom C) (preserveComp (MFunctor T)) ⟩
    C [ Tmap c ∘ C [ fmap (MFunctor T) (Thom f) ∘ fmap (MFunctor T) (Thom g) ] ] ≈⟨ sym-hom C (assoc C) ⟩
    C [ C [ Tmap c ∘ fmap (MFunctor T) (Thom f) ] ∘ fmap (MFunctor T) (Thom g) ] ≈⟨ ≈-composite C (hom-comm f) (refl-hom C) ⟩
    C [ C [ Thom f ∘ Tmap b ] ∘ fmap (MFunctor T) (Thom g) ] ≈⟨ assoc C ⟩
    C [ Thom f ∘ C [ Tmap b ∘ fmap (MFunctor T) (Thom g) ] ] ≈⟨ ≈-composite C (refl-hom C) (hom-comm g) ⟩
    C [ Thom f ∘ C [ Thom g ∘ Tmap a ] ] ≈⟨ sym-hom C (assoc C) ⟩
    C [ C [ Thom f ∘ Thom g ] ∘ Tmap a ]
  ∎ }

identity : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} {T : Monad C} {a : TAlgebra T} → TAlgMap a a
identity {C = C} {T} {a} = record {
  Thom = id C ;
  hom-comm = begin⟨ C ⟩
    C [ Tmap a ∘ fmap (MFunctor T) (id C) ] ≈⟨ ≈-composite C (refl-hom C) (preserveId (MFunctor T)) ⟩
    C [ Tmap a ∘ id C ] ≈⟨ rightId C ⟩
    Tmap a ≈⟨ sym-hom C (leftId C) ⟩
    C [ id C ∘ Tmap a ]
  ∎ }

T-Algs : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} (T : Monad C) → Category _ _ _
T-Algs {C = C} T = record {
  Obj = TAlgebra T;
  Homsetoid = λ a b → record {
    Carrier = TAlgMap a b ;
    _≈_ = λ f g → C [ Thom f ≈ Thom g ] ;
    isEquivalence = record { refl = refl-hom C ; sym = sym-hom C ; trans = trans-hom C } };
  comp = compose;
  id = identity;
  leftId = leftId C;
  rightId = rightId C;
  assoc = assoc C;
  ≈-composite = ≈-composite C }

Free-TAlg : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} (T : Monad C) → Functor.Functor C (T-Algs T)
Free-TAlg {C = C} T = record {
  fobj = λ x → record {
    Tobj = fobj (MFunctor T) x ;
    Tmap = component (Mjoin T) x ;
    join-fmap-alg = join_join T ;
    map-unit = unit_MFunctor T } ;
  fmapsetoid = λ {a} {b} → record {
    mapping = λ x → record {
      Thom = fmap (MFunctor T) x ;
      hom-comm = naturality (Mjoin T) } ;
    preserveEq = Functor.preserveEq (MFunctor T) } ;
  preserveId = preserveId (MFunctor T) ;
  preserveComp = preserveComp (MFunctor T) }

Forgetful-TAlg : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} (T : Monad C) → Functor.Functor (T-Algs T) C
Forgetful-TAlg {C = C} T = record {
  fobj = Tobj ;
  fmapsetoid = record { mapping = Thom ; preserveEq = λ x≈y → x≈y } ;
  preserveId = refl-hom C ;
  preserveComp = refl-hom C }

Free⊣Forgetful-TAlg : ∀ {C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} (T : Monad C) → Free-TAlg T ⊣ Forgetful-TAlg T
Free⊣Forgetful-TAlg {C = C} T = Adjoint.unit-triangular-holds-adjoint {C = C} {D = T-Algs T} {FT} {GT} ηT εT triL (λ {a} → triR {a})
  where
    FT = Free-TAlg T
    GT = Forgetful-TAlg T
    ηT = record {
      component = component (Munit T) ;
      naturality = naturality (Munit T) }
    εT = record {
      component = λ X → record {
        Thom = Tmap X ;
        hom-comm = sym-hom C (join-fmap-alg X) } ;
      naturality = λ {a} {b} {f} → hom-comm f }

    triL : [ C , T-Algs T ] [ Nat.compose (Nat.compose Nat.leftIdNat→ (εT N∘F FT)) (Nat.compose (Nat.assocNat← {F = FT} {GT} {FT}) (Nat.compose (FT F∘N ηT) Nat.rightIdNat←)) ≈ id [ C , T-Algs T ] ]
    triL = λ {a} → begin⟨ C ⟩
      C [ C [ id C ∘ Thom (component εT (fobj FT a)) ] ∘ C [ id C ∘ C [ Thom (fmap FT (component ηT a)) ∘ id C ] ] ] ≈⟨ ≈-composite C (leftId C) (trans-hom C (leftId C) (rightId C)) ⟩
      C [ component (Mjoin T) a ∘ fmap (MFunctor T) (component (Munit T) a) ] ≈⟨ MFunctor_unit T ⟩
      id C
      ∎

    triR : [ T-Algs T , C ] [ Nat.compose (Nat.compose Nat.rightIdNat→ (GT F∘N εT)) (Nat.compose (Nat.assocNat→ {F = GT} {FT} {GT}) (Nat.compose (ηT N∘F GT) Nat.leftIdNat←)) ≈ id [ T-Algs T , C ] ]
    triR = λ {a} → begin⟨ C ⟩
      C [ C [ id C ∘ fmap GT (component εT a) ] ∘ C [ id C ∘ C [ component ηT (fobj GT a) ∘ id C ] ] ] ≈⟨ ≈-composite C (leftId C) (trans-hom C (leftId C) (rightId C)) ⟩
      C [ fmap GT (component εT a) ∘ component ηT (fobj GT a) ] ≈⟨ refl-hom C ⟩
      C [ component (GT F∘N εT) a ∘ component (Munit T) (Tobj a) ] ≈⟨ map-unit a ⟩
      id C
      ∎


-- Andreas, 2011-10-02
{-# OPTIONS --show-implicit #-}
module Issue483a where

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

data Empty : Set where

postulate A : Set

abort : .Empty → A
abort ()

test : let X : .Set1 → A
           X = _
       in  (x : Empty) → X Set ≡ abort x
test x = refl

-- this should fail with message like
--
--  Cannot instantiate the metavariable _16 to abort x since it
--  contains the variable x which is not in scope of the metavariable
--  when checking that the expression refl has type _16 _ ≡ abort x
--
-- a solution like X = λ _ → abort x : Set1 → A
-- would be invalid even though x is irrelevant, because there is no
-- term of type Set1 → A