module BTA4 where
-- specialize two-level typed terms to untyped lambda calculus

open import Data.Nat hiding (_<_)
open import Data.Bool
open import Data.Fin hiding (_≤_ ; pred; _+_)
open import Data.List
open import Data.Product

open import Function
open import Algebra.FunctionProperties using (Commutative; Identity; RightIdentity)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; cong₂)
open PropEq.≡-Reasoning
open import Data.Nat.Properties

open import Relation.Nullary

-- Binding times
data BT : Set where
  S : BT
  D : BT

-- defining a data type [BT],where two members are
-- [S] standing for "static" and [D] standing for dynamic.

-- ``subsumption'' binding times; static can be treated as dynamic,
-- but not vice versa
_≼_ : BT → BT → Bool
_≼_ D S  = false
_≼_ _ _  = true

record True : Set where
data False : Set where

isTrue : Bool → Set
isTrue true  = True
isTrue false = False

-- an inductive type describing bt subsumption
data _⊑_ : BT → BT → Set where
  bt-leq-refl : ∀ {bt} → bt ⊑ bt
  bt-leq-dyn  : ∀ {bt} → bt ⊑ D

bt-reify : ∀ bt1 bt2 → isTrue (bt1 ≼ bt2) → bt1 ⊑ bt2
bt-reify S S p = bt-leq-refl
bt-reify S D p = bt-leq-dyn
bt-reify D S ()
bt-reify D D p = bt-leq-refl

bt-reflect : ∀ bt1 bt2 → bt1 ⊑ bt2 → isTrue (bt1 ≼ bt2)
bt-reflect S S p = _
bt-reflect S D p = _
bt-reflect D S ()
bt-reflect D D p = _

-- More general purpose definitions (should also be in standard library)
-- list membership
infix 4 _∈_
data _∈_ {A : Set} : A → List A → Set where
  hd : ∀ {x xs} → x ∈ (x ∷ xs)
  tl : ∀ {x y xs} → x ∈ xs → x ∈ (y ∷ xs)

-- Types of the calculus
mutual
  -- s ^ BT
  data AType : Set where
    Ann : BT → SType → AType

  -- int | t -> t
  data SType : Set where
    SInt  : SType
    SFun  : AType → AType → SType

-- aux definitions
ATInt : BT → AType
ATInt bt = Ann bt SInt
ATFun  : BT → AType → AType → AType
ATFun  bt at1 at2 = Ann bt (SFun at1 at2)

-- projection: get the BT from a type
btof : AType → BT
btof (Ann bt _) = bt

-- an alternative: have only wf types from the start
data AType' : BT → Set where
  AInt : (bt : BT) → AType' bt
  AFun : (bt : BT) → ∀ {bt1 bt2} → AType' bt1 → AType' bt2 → bt ⊑ bt1 → bt ⊑ bt2 → AType' bt

forget-wft : ∀ {bt} → AType' bt → AType
forget-wft {bt} (AInt .bt) = ATInt bt
forget-wft {bt} (AFun .bt at at₁ x x₁) = ATFun bt (forget-wft at) (forget-wft at₁)

data LEQ-Problem : Set where
  LEQ-not-D⊑S : LEQ-Problem

data WF-Problem : Set where
  WF-LEQ-right : LEQ-Problem → WF-Problem
  WF-LEQ-left : LEQ-Problem → WF-Problem
  WF-WF-left : WF-Problem → WF-Problem
  WF-WF-right : WF-Problem → WF-Problem

data Inferred (E A : Set) : Set where
  Ok : A → Inferred E A
  Error : E → Inferred E A

infer-bt-leq : ∀ bt1 bt2 → Inferred LEQ-Problem (bt1 ⊑ bt2)
infer-bt-leq S S = Ok bt-leq-refl
infer-bt-leq S D = Ok bt-leq-dyn
infer-bt-leq D S = Error LEQ-not-D⊑S
infer-bt-leq D D = Ok bt-leq-refl

-- insufficiently constrained ...
infer-wft' : (α : AType) → Inferred WF-Problem (AType' (btof α))
infer-wft' (Ann x SInt) = Ok (AInt x)
infer-wft' (Ann x (SFun x₁ x₂)) with infer-wft' x₁ | infer-wft' x₂ | infer-bt-leq x (btof x₁) | infer-bt-leq x (btof x₂)
infer-wft' (Ann x₄ (SFun x₁ x₂)) | Ok x | Ok x₃ | Ok x₅ | Ok x₆ = Ok (AFun x₄ x x₃ x₅ x₆)
infer-wft' (Ann x₄ (SFun x₁ x₂)) | Ok x | Ok x₃ | Ok x₅ | Error x₆ = Error (WF-LEQ-right x₆)
infer-wft' (Ann x₄ (SFun x₁ x₂)) | Ok x | Ok x₃ | Error x₅ | okbt2 = Error (WF-LEQ-left x₅)
infer-wft' (Ann x₄ (SFun x₁ x₂)) | Ok x | Error x₃ | _ | _ = Error (WF-WF-right x₃)
infer-wft' (Ann x₃ (SFun x₁ x₂)) | Error x | r2 | _ | _ = Error (WF-WF-left x)

-- might be easier to infer a Σ type
check-wft : (α : AType) → Inferred WF-Problem (∃ λ α' → α ≡ forget-wft {btof α} α')
check-wft (Ann x SInt) = Ok (AInt x , refl)
check-wft (Ann x (SFun x₁ x₂)) with check-wft x₁ | check-wft x₂ | infer-bt-leq x (btof x₁) | infer-bt-leq x (btof x₂)
... | Ok (α₁ , pr₁) | Ok (α₂ , pr₂) | Ok leq₁ | Ok leq₂ = Ok (AFun x α₁ α₂ leq₁ leq₂ , cong₂ (λ x₃ x₄ → Ann x (SFun x₃ x₄)) pr₁ pr₂)
... | Ok p₁ | Ok p₂ | Ok leq₁ | Error e₄ = Error (WF-LEQ-right e₄)
... | Ok p₁ | Ok p₂ | Error e₃ | _ = Error (WF-LEQ-left e₃)
... | Ok p₁ | Error e₂ | _ | _ = Error (WF-WF-right e₂)
... | Error e₁ | _ | _ | _ = Error (WF-WF-left e₁)

unfold-forget : ∀ bt {bt₁} {bt₂} at₁ at₂ x₅ x₆ →
  forget-wft (AFun bt  {bt₁} {bt₂} at₁ at₂ x₅ x₆) ≡ ATFun bt (forget-wft at₁) (forget-wft at₂)
unfold-forget bt at₁ at₂ x₅ x₆ = refl

-- well-formedness
data wft : AType → Set where
  wf-int  : ∀ {bt} → wft (Ann bt SInt)
  wf-fun  : ∀ {bt at1 at2} → wft at1 → wft at2
          → isTrue (bt ≼ btof at1) → isTrue (bt ≼ btof at2) → wft (Ann bt (SFun at1 at2))

infer-lemma-fun-left : ∀ σ₁ α₂ → ¬ wft (Ann D (SFun (Ann S σ₁) α₂))
infer-lemma-fun-left σ₁ α₂ (wf-fun v v₁ () x₁)

infer-lemma-fun-right : ∀ α σ → ¬ wft (Ann D (SFun α (Ann S σ)))
infer-lemma-fun-right α σ (wf-fun v v₁ x ())

infer-yes-yes : ∀ bt α₁ α₂ → (wf1 : wft α₁) (wf2 : wft α₂) → Dec (wft (Ann bt (SFun α₁ α₂)))
infer-yes-yes S (Ann bt1 σ₁) (Ann bt2 σ₂) wf1 wf2 = yes (wf-fun wf1 wf2 _ _)
infer-yes-yes D (Ann D σ₁) (Ann D σ₂) wf1 wf2     = yes (wf-fun wf1 wf2 _ _)
infer-yes-yes D (Ann S σ₁) (Ann bt2 σ₂) wf1 wf2   = no (infer-lemma-fun-left σ₁ (Ann bt2 σ₂))
infer-yes-yes D (Ann bt1 σ₁) (Ann S σ₂) wf1 wf2   = no (infer-lemma-fun-right (Ann bt1 σ₁) σ₂)

infer-lemma-arg-left : ∀ bt α₁ α₂ → ¬ wft α₁ → ¬ wft (Ann bt (SFun α₁ α₂))
infer-lemma-arg-left bt α₁ α₂ ¬wft1 (wf-fun v v₁ x x₁) = ¬wft1 v

infer-lemma-arg-right : ∀ bt α₁ α₂ → ¬ wft α₂ → ¬ wft (Ann bt (SFun α₁ α₂))
infer-lemma-arg-right bt α₁ α₂ ¬wft2 (wf-fun v v₁ x x₁) = ¬wft2 v₁

infer-wft : (α : AType) → Dec (wft α)
infer-wft (Ann bt SInt) = yes wf-int
infer-wft (Ann bt (SFun α₁ α₂))
  with infer-wft α₁ | infer-wft α₂
... | yes wf1 | yes wf2 = infer-yes-yes bt α₁ α₂ wf1 wf2
... | yes wf1 | no ¬wf2 = no (infer-lemma-arg-right bt α₁ α₂ ¬wf2)
... | no ¬wf1 | yes wf2 = no (infer-lemma-arg-left bt α₁ α₂ ¬wf1)
... | no ¬wf1 | no ¬wf2 = no (infer-lemma-arg-left bt α₁ α₂ ¬wf1)

----------------------------------------------------------------------
-- step 0
-- Untyped expressions, incorrect results
data Exp : Set where
  EVar : ℕ → Exp
  EInt : ℕ → Exp
  EAdd : Exp → Exp → Exp
  ELam : Exp → Exp
  EApp : Exp → Exp → Exp

-- mapping from annotated type to implementation type
ImpTA : AType → Set
ImpTA (Ann S SInt) = ℕ
ImpTA (Ann S (SFun α β)) = ImpTA α → ImpTA β
ImpTA (Ann D σ) = Exp

-- test for dynamic by wellformedness
data IsDynamic : AType → Set where
  is-dyn : ∀ σ → IsDynamic (Ann D σ)

lem-IsDynamic-by-wf : ∀ α → isTrue (D ≼ btof α) → IsDynamic α
lem-IsDynamic-by-wf (Ann S σ) ()
lem-IsDynamic-by-wf (Ann D σ) _ = is-dyn σ

-- typed annotated expressions
ACtx = List AType

data AExp (Δ : ACtx) : AType → Set where
  AVar : ∀ {α} → α ∈ Δ → AExp Δ α
  AInt : (bt : BT) → ℕ → AExp Δ (ATInt bt)
  AAdd : (bt : BT) → AExp Δ (ATInt bt) → AExp Δ (ATInt bt) → AExp Δ (ATInt bt)
  ALam : ∀ {α₁ α₂} (bt : BT) → wft (ATFun bt α₂ α₁) → AExp (α₂ ∷ Δ) α₁ → AExp Δ (ATFun bt α₂ α₁)
  AApp : ∀ {α₁ α₂} (bt : BT) → wft (ATFun bt α₂ α₁) → AExp Δ (ATFun bt α₂ α₁) → AExp Δ α₂ → AExp Δ α₁

-- TODO: replace wellformedness of types in AApp with lemma
-- the lemma does not require wft in AApp
data wft-context : ACtx → Set where
  wft-[] : wft-context []
  wft-:: : ∀ {α Δ} → wft α → wft-context Δ → wft-context (α ∷ Δ)

lemma-wft-var : ∀ {α Δ} → wft-context Δ → α ∈ Δ → wft α
lemma-wft-var (wft-:: x wc) hd = x
lemma-wft-var (wft-:: x wc) (tl pf) = lemma-wft-var wc pf

lemma-wft : ∀ {α Δ} → wft-context Δ → AExp Δ α → wft α
lemma-wft wc (AVar x) = lemma-wft-var wc x
lemma-wft wc (AInt bt x) = wf-int
lemma-wft wc (AAdd bt ae₁ ae₂) = wf-int
lemma-wft wc (ALam bt x ae) = x
lemma-wft wc (AApp bt _ ae ae₁)
  with lemma-wft wc ae
... | (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) = w₂

data AEnv0 (F : AType → Set) : ACtx -> Set where
  AE[] : AEnv0 F []
  AE∷  : ∀ {Δ} α → F α → AEnv0 F Δ → AEnv0 F (α ∷ Δ)

AEnv = AEnv0 ImpTA

aelength : ∀ {F Δ} → AEnv0 F Δ → ℕ
aelength AE[] = 0
aelength (AE∷ α x ae) = suc( aelength ae)

lookup : ∀ {F Δ α} → AEnv0 F Δ → (o : α ∈ Δ ) → F α
lookup (AE∷ α x env) hd = x
lookup (AE∷ α x env) (tl o) = lookup env o

-- partial evaluation
peval : ∀ {α Δ } → AExp Δ α → AEnv Δ → ImpTA α
peval (AVar x) env = lookup env x
peval (AInt S x) env = x
peval (AInt D x) env = EInt x
peval (AAdd S e₁ e₂) env = peval e₁ env + peval e₂ env
peval (AAdd D e₁ e₂) env = EAdd (peval e₁ env) (peval e₂ env)
peval (ALam {α₂} {α₁} S w e) env = λ y → peval e (AE∷ α₁ y env)
peval (ALam {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
peval (ALam {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun _ _ d≤bt₁ d≤bt₂) e) env
  | is-dyn σ₁ | is-dyn σ₂ = ELam (peval e (AE∷ (Ann D σ₁) (EVar (aelength env)) env))
peval (AApp S w e e₁) env = peval e env (peval e₁ env)
peval (AApp {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
peval (AApp {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun _ _ d≤bt₁ d≤bt₂) e e₁) env
  | is-dyn σ₁ | is-dyn σ₂ = EApp (peval e env) (peval e₁ env)

----------------------------------------------------------------------
-- step 1
-- Untyped expression, but correctly scoped
data Exp' : ℕ → Set where
  EVar : ∀ {n} → Fin n → Exp' n
  EInt : ∀ {n} → ℕ → Exp' n
  EAdd : ∀ {n} → Exp' n → Exp' n → Exp' n
  ELam : ∀ {n} → Exp' (suc n) → Exp' n
  EApp : ∀ {n} → Exp' n → Exp' n → Exp' n

---

m+1+n≡1+m+n : ∀ m n → m + suc n ≡ suc (m + n)
m+1+n≡1+m+n zero    n = refl
m+1+n≡1+m+n (suc m) n = cong suc (m+1+n≡1+m+n m n)

n+0≡n : ∀ n → n + 0 ≡ n
n+0≡n zero    = refl
n+0≡n (suc n) = cong suc $ n+0≡n n

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero    n = sym (n+0≡n n)
+-comm (suc m) n =
  begin
    suc m + n
  ≡⟨ refl ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨ sym (m+1+n≡1+m+n n m) ⟩
    n + suc m
  ∎

≤-refl : ∀ {n} → n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s ≤-refl

≤-trans : ∀ {a b c} → a ≤ b → b ≤ c → a ≤ c
≤-trans z≤n q = z≤n
≤-trans (s≤s p) (s≤s q) = s≤s (≤-trans p q)

≤-suc-right : ∀ {m n} → m ≤ n → m ≤ suc n
≤-suc-right z≤n = z≤n
≤-suc-right (s≤s p) = s≤s (≤-suc-right p)

≤-suc-left : ∀ {m n} → suc m ≤ n → m ≤ n
≤-suc-left (s≤s p) = ≤-suc-right p

xlate : ∀ {m} {n} → Exp' (m + suc n) → Exp' (suc (n + m))
xlate {m} {n} e rewrite m+1+n≡1+m+n m n | +-comm m n = e

shifter1 : ∀ {n} m → Exp' (suc n) → Exp' (suc (n + m))
shifter1 {n} m (EVar x) = xlate {m} (EVar (raise m x))
shifter1 m (EInt x) = EInt x
shifter1 m (EAdd e₁ e₂) = EAdd (shifter1 m e₁) (shifter1 m e₂)
shifter1 m (ELam e) = ELam (shifter1 m e)
shifter1 m (EApp e e₁) = EApp (shifter1 m e) (shifter1 m e₁)

shifter0 : ∀ m → Exp' zero → Exp' m
shifter0 m (EVar ())
shifter0 m (EInt x) = EInt x
shifter0 m (EAdd e₁ e₂) = EAdd (shifter0 m e₁) (shifter0 m e₂)
shifter0 m (ELam e) = ELam (shifter1 m e)
shifter0 m (EApp e e₁) = EApp (shifter0 m e) (shifter0 m e₁)

shifter : ∀ m d → Exp' m → Exp' (m + d)
shifter zero d e = shifter0 d e
shifter (suc m) d e = shifter1 d e

-- m+n∸m≡n : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
-- m+n∸m≡n p

helper : ∀ {m n} → n ≤ m → Exp' (n + (m ∸ n)) → Exp' m
helper p e rewrite m+n∸m≡n p = e

-- index m = nesting level of dynamic definitions
Imp : (m : ℕ) → AType → Set
Imp m (Ann S SInt) = ℕ
Imp m (Ann S (SFun α₁ α₂)) = ∀ n → m ≤ n → (Imp n α₁ → Imp n α₂)
Imp m (Ann D σ) = Exp' m

-- index = nesting level of dynamic definitions
data AEnv1 : ℕ → ACtx → Set where
  [] : AEnv1 0 []
  consS : ∀ {m Δ o} → m ≤ o → (α : AType) → Imp o α → AEnv1 m Δ → AEnv1 o (α ∷ Δ)
  consD : ∀ {m Δ} → (α : AType) → isTrue (D ≼ btof α) → Imp (suc m) α → AEnv1 m Δ → AEnv1 (suc m) (α ∷ Δ)

lift1 : ∀ {m n} α → m ≤ n → Imp m α → Imp n α
lift1 (Ann S SInt) p v = v
lift1 (Ann S (SFun x x₁)) p v = λ k n≤k → v k (≤-trans p n≤k)
lift1 {m} {n} (Ann D σ) p v = helper p (shifter m (n ∸ m) v)

lookup1 : ∀ {α Δ m n} → m  ≤ n → AEnv1 m Δ → α ∈ Δ → Imp n α
lookup1 {α} p (consS _ .α x env) hd = lift1 α p x
lookup1 {α} p (consD .α x x₁ env) hd = lift1 α p x₁
lookup1 p (consS p' .y x env) (tl {_} {y} x₁) = lookup1 (≤-trans p' p) env x₁
lookup1 p (consD .y x x₁ env) (tl {_} {y} x₂) = lookup1 (≤-suc-left p) env x₂

pe1 : ∀ {α Δ} m → AExp Δ α → AEnv1 m Δ → Imp m α
pe1 m (AVar x) env = lookup1 ≤-refl env x
pe1 m (AInt S x) env = x
pe1 m (AInt D x) env = EInt x
pe1 m (AAdd S e₁ e₂) env = pe1 m e₁ env + pe1 m e₂ env
pe1 m (AAdd D e₁ e₂) env = EAdd (pe1 m e₁ env) (pe1 m e₂ env)
pe1 m (ALam S x e) env = λ o p → λ v → pe1 o e (consS p _ v env)
pe1 m (ALam {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe1 m (ALam {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun _ _ d≤bt₁ d≤bt₂) e) env
  | is-dyn σ₁ | is-dyn σ₂ = ELam (pe1 (suc m) e (consD (Ann D σ₁) d≤bt₁ (EVar zero) env))
pe1 m (AApp S x e e₁) env = (pe1 m e env) m ≤-refl (pe1 m e₁ env)
pe1 m (AApp {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe1 m (AApp {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  | is-dyn σ₁ | is-dyn σ₂ = EApp (pe1 m e env) (pe1 m e₁ env)

term1 : AExp [] (ATInt D)
term1 = AInt D 42

term2 : AExp [] (ATFun D (ATInt D) (ATInt D))
term2 = ALam D (wf-fun wf-int wf-int _ _) (AVar hd)
-- Dλ y → let f = λ x → x D+ y in Dλ z → f z
-- Dλ y → let f = λ x → (Dλ w → x D+ y) in Dλ z → f z
-- Dλ y → (λ f → Dλ z → f z) (λ x → (Dλ w → x D+ y))
-- :: DInt D→ (DT  D→ DInt)
-- y : DInt, f : DInt → (DT  D→ DInt)

term3-0 : AExp (Ann D SInt ∷ Ann D SInt ∷ Ann D SInt ∷ []) (Ann D SInt)
term3-0 = AAdd D (AVar (tl (tl hd))) (AVar (tl hd))

term3-1 : AExp (Ann D SInt ∷ Ann D SInt ∷ []) (Ann D (SFun (Ann D SInt) (Ann D SInt)))
term3-1 = ALam D (wf-fun wf-int wf-int _ _) term3-0

term3-2 : AExp (Ann D SInt ∷ []) (Ann S (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))
term3-2 = ALam S (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) term3-1

term3-3 : AExp (Ann D SInt ∷ Ann S (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))) ∷ Ann D SInt ∷ [])
               (Ann D (SFun (Ann D SInt) (Ann D SInt)))
term3-3 = AApp S (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) (AVar (tl hd)) (AVar hd)

term3-4 : AExp (Ann S (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))) ∷ Ann D SInt ∷ [])
               (Ann D (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))
term3-4 = ALam D (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) term3-3

term3-5 : AExp (Ann D SInt ∷ [])
               (Ann S (SFun (Ann S (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))
                            (Ann D (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))))
term3-5 = ALam S (wf-fun (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) _ _) term3-4

term3-6 : AExp (Ann D SInt ∷ [])
               (Ann D (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))
term3-6 = AApp S (wf-fun (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) _ _) term3-5 term3-2

term3 : AExp [] (Ann D (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D (SFun (Ann D SInt) (Ann D SInt)))))))
term3 = ALam D (wf-fun wf-int (wf-fun wf-int (wf-fun wf-int wf-int _ _) _ _) _ _) term3-6

-- conclusion: you want type inference ...

-------------------------------------------------------------------------------
-- step 2
-- now let's do everything typed

data Type : Set where
  Int : Type
  Fun : Type → Type → Type

Ctx = List Type

data _↝_ : Ctx → Ctx → Set where
  ↝-refl   : ∀ {Γ}      → Γ ↝ Γ
  ↝-extend : ∀ {Γ Γ' τ} → Γ ↝ Γ' → Γ ↝ (τ ∷ Γ')

↝-≤ : ∀ Γ Γ' → Γ ↝ Γ' → length Γ ≤ length Γ'
↝-≤ .Γ' Γ' ↝-refl = ≤-refl
↝-≤ Γ .(τ ∷ Γ') (↝-extend {.Γ} {Γ'} {τ} Γ↝Γ') = ≤-suc-right (↝-≤ Γ Γ' Γ↝Γ')

↝-no-left : ∀ Γ τ → ¬ (τ ∷ Γ) ↝ Γ
↝-no-left Γ τ p = 1+n≰n (↝-≤ (τ ∷ Γ) Γ p)

↝-trans : ∀ {Γ Γ' Γ''} → Γ ↝ Γ' → Γ' ↝ Γ'' → Γ ↝ Γ''
↝-trans Γ↝Γ' ↝-refl = Γ↝Γ'
↝-trans Γ↝Γ' (↝-extend Γ'↝Γ'') = ↝-extend (↝-trans Γ↝Γ' Γ'↝Γ'')

lem : ∀ x y xs xs' → (x ∷ xs) ↝ xs' → xs ↝ (y ∷ xs')
lem x y xs .(x ∷ xs) ↝-refl = ↝-extend (↝-extend ↝-refl)
lem x y xs .(x' ∷ xs') (↝-extend {.(x ∷ xs)} {xs'} {x'} p) = ↝-extend (lem x x' xs xs' p)

data _↝_↝_ : Ctx → Ctx → Ctx → Set where
  ↝↝-base   : ∀ {Γ Γ''} → Γ ↝ Γ'' → Γ ↝ [] ↝ Γ''
  ↝↝-extend : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → (τ ∷ Γ) ↝ (τ ∷ Γ') ↝ (τ ∷ Γ'')

-- Typed residula expressions
data Exp'' (Γ : Ctx) : Type → Set where
  EVar : ∀ {τ} → τ ∈ Γ → Exp'' Γ τ
  EInt : ℕ → Exp'' Γ Int
  EAdd : Exp'' Γ Int → Exp'' Γ Int -> Exp'' Γ Int
  ELam : ∀ {τ τ'} → Exp'' (τ ∷ Γ) τ' → Exp'' Γ (Fun τ τ')
  EApp : ∀ {τ τ'} → Exp'' Γ (Fun τ τ')  → Exp'' Γ τ → Exp'' Γ τ'

-- erase annotations
erase : AType → Type
erase (Ann x SInt) = Int
erase (Ann x (SFun x₁ x₂)) = Fun (erase x₁) (erase x₂)

-- index Γ = nesting level of dynamic definitions / dynamic environment
Imp'' : Ctx → AType → Set
Imp'' Γ (Ann S SInt) = ℕ
Imp'' Γ (Ann S (SFun α₁ α₂)) = ∀ Γ' → Γ ↝ Γ' → (Imp'' Γ' α₁ → Imp'' Γ' α₂)
Imp'' Γ (Ann D σ) = Exp'' Γ (erase (Ann D σ))

-- index = nesting level of dynamic definitions
data AEnv2 : Ctx → ACtx → Set where
  [] : AEnv2 [] []
  consS : ∀ {Γ Δ Γ'} → Γ ↝ Γ' → (α : AType) → Imp'' Γ' α → AEnv2 Γ Δ → AEnv2 Γ' (α ∷ Δ)
  consD : ∀ {Γ Δ} → (α : AType) → isTrue (D ≼ btof α) → Imp'' (erase α ∷ Γ) α → AEnv2 Γ Δ → AEnv2 (erase α ∷ Γ) (α ∷ Δ)

elevate-var : ∀ {Γ Γ' τ} → Γ ↝ Γ' → τ ∈ Γ → τ ∈ Γ'
elevate-var ↝-refl x = x
elevate-var (↝-extend Γ↝Γ') x = tl (elevate-var Γ↝Γ' x)

elevate-var2 : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → τ ∈ Γ → τ ∈ Γ''
elevate-var2 (↝↝-base x) x₁ = elevate-var x x₁
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') hd = hd
elevate-var2 (↝↝-extend Γ↝Γ'↝Γ'') (tl x) = tl (elevate-var2 Γ↝Γ'↝Γ'' x)

elevate : ∀ {Γ Γ' Γ'' τ} → Γ ↝ Γ' ↝ Γ'' → Exp'' Γ τ → Exp'' Γ'' τ
elevate Γ↝Γ'↝Γ'' (EVar x) = EVar (elevate-var2 Γ↝Γ'↝Γ'' x)
elevate Γ↝Γ'↝Γ'' (EInt x) = EInt x
elevate Γ↝Γ'↝Γ'' (EAdd e e₁) = EAdd (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)
elevate Γ↝Γ'↝Γ'' (ELam e) = ELam (elevate (↝↝-extend Γ↝Γ'↝Γ'') e)
elevate Γ↝Γ'↝Γ'' (EApp e e₁) = EApp (elevate Γ↝Γ'↝Γ'' e) (elevate Γ↝Γ'↝Γ'' e₁)

lift2 : ∀ {Γ Γ'} α → Γ ↝ Γ' → Imp'' Γ α → Imp'' Γ' α
lift2 (Ann S SInt) p v = v
lift2 (Ann S (SFun x x₁)) Γ↝Γ' v = λ Γ'' Γ'↝Γ'' → v Γ'' (↝-trans Γ↝Γ' Γ'↝Γ'')
lift2 (Ann D x₁) Γ↝Γ' v = elevate (↝↝-base Γ↝Γ') v

lookup2 : ∀ {α Δ Γ Γ'} → Γ ↝ Γ' → AEnv2 Γ Δ → α ∈ Δ → Imp'' Γ' α
lookup2 Γ↝Γ' (consS p α v env) hd = lift2 α Γ↝Γ' v
lookup2 Γ↝Γ' (consS p α₁ v env) (tl x) = lookup2 (↝-trans p Γ↝Γ') env x
lookup2 Γ↝Γ' (consD α D≼α v env) hd = lift2 α Γ↝Γ' v
lookup2 ↝-refl (consD α₁ D≼α v env) (tl x) = lookup2 (↝-extend ↝-refl) env x
lookup2 (↝-extend Γ↝Γ') (consD α₁ D≼α v env) (tl x) = lookup2 (lem (erase α₁) _ _ _ Γ↝Γ') env x

pe2 : ∀ {α Δ} Γ → AExp Δ α → AEnv2 Γ Δ → Imp'' Γ α
pe2 Γ (AVar x) env = lookup2 ↝-refl env x
pe2 Γ (AInt S x) env = x
pe2 Γ (AInt D x) env = EInt x
pe2 Γ (AAdd S e₁ e₂) env = pe2 Γ e₁ env + pe2 Γ e₂ env
pe2 Γ (AAdd D e₁ e₂) env = EAdd (pe2 Γ e₁ env) (pe2 Γ e₂ env)
pe2 {Ann S (SFun α₂ α₁)} Γ (ALam .S w e) env = λ Γ' Γ↝Γ' → λ y → pe2 {α₁} Γ' e (consS Γ↝Γ' α₂ y env)
pe2 Γ (ALam {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe2 Γ (ALam {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun _ _ d≤bt₁ d≤bt₂) e) env
  | is-dyn σ₁ | is-dyn σ₂ = ELam (pe2 (erase (Ann D σ₁) ∷ Γ) e (consD (Ann D σ₁) d≤bt₁ (EVar hd) env))
pe2 Γ (AApp S w e₁ e₂) env = pe2 Γ e₁ env Γ ↝-refl (pe2 Γ e₂ env)
pe2 Γ (AApp {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe2 Γ (AApp {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  | is-dyn σ₁ | is-dyn σ₂ = EApp (pe2 Γ e env) (pe2 Γ e₁ env)

pe2-term1 = pe2 [] term1 []
pe2-term2 = pe2 [] term2 []
pe2-term3 = pe2 [] term3 []


{-# OPTIONS --universe-polymorphism #-}
module Graphs.GraphMorphism where

open import Data.Product
open import Level
open import Relation.Binary
  renaming (_⇒_ to _⊆_)
open import Relation.Binary.PropositionalEquality
  using ()
  renaming
    (_≡_ to _≣_
    ; refl  to ≣-refl
    ; sym   to ≣-sym
    ; trans to ≣-trans
    ; cong  to ≣-cong
    )

open import Graphs.Graph

record GraphMorphism {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
    (A : Graph o₁ ℓ₁ e₁) (B : Graph o₂ ℓ₂ e₂) : Set (o₁ ⊔ o₂ ⊔ ℓ₁ ⊔ ℓ₂ ⊔ e₁ ⊔ e₂) where
  module A = Graph A
  module B = Graph B
  field
    F₀        : A.Obj → B.Obj
    F₁        : ∀ {X Y} → A [ X ↝ Y ] → B [ F₀ X ↝ F₀ Y ]
    .F-resp-≈ : ∀ {X Y}{f g : A [ X ↝ Y ]} → A [ f ≈ g ] → B [ F₁ f ≈ F₁ g ]

infixr 9 _∘_
infix  4 _≈_

id : ∀{o ℓ e}{A : Graph o ℓ e} → GraphMorphism A A
id = record
  { F₀        = λ A → A
  ; F₁        = λ f → f
  ; F-resp-≈  = λ f≈g → f≈g
  }

_∘_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
        {A : Graph o₀ ℓ₀ e₀} {B : Graph o₁ ℓ₁ e₁} {C : Graph o₂ ℓ₂ e₂}
    → GraphMorphism B C → GraphMorphism A B → GraphMorphism A C
G ∘ F = record
  { F₀ = λ A → G₀ (F₀ A)
  ; F₁ = λ f → G₁ (F₁ f)
  ; F-resp-≈ = λ f≈g → G-resp-≈ (F-resp-≈ f≈g)
  } where
    open GraphMorphism F
    open GraphMorphism G renaming (F₀ to G₀; F₁ to G₁; F-resp-≈ to G-resp-≈)

_≈₀_ : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → (F G : GraphMorphism A B)
  → Set (o₁ ⊔ o₂)
_≈₀_ {A = A}{B} F G
  = ∀ X → F₀ X ≣ G₀ X
  where
    open GraphMorphism F using (F₀)
    open GraphMorphism G renaming (F₀ to G₀)

isEquivalence₀ : ∀{o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → IsEquivalence (_≈₀_ {A = A}{B})
isEquivalence₀ {A = A}{B} = record
  { refl  = λ     x → ≣-refl
  ; sym   = λ p   x → ≣-sym   (p x)
  ; trans = λ p q x → ≣-trans (p x) (q x)
  }

_≈₁_ : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → (F G : GraphMorphism A B)
  → Set (o₁ ⊔ ℓ₁ ⊔ ℓ₂ ⊔ e₂)
_≈₁_ {A = A}{B} F G
  = ∀ {X Y} (f : A [ X ↝ Y ]) → B [ F₁ f ~ G₁ f ]
  where
    open GraphMorphism F using (F₁)
    open GraphMorphism G renaming (F₁ to G₁)

isEquivalence₁ : ∀{o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → IsEquivalence (_≈₁_ {A = A}{B})
isEquivalence₁ {A = A}{B} = record
  { refl  = λ     f → refl
  ; sym   = λ p   f → sym   (p f)
  ; trans = λ p q f → trans (p f) (q f)
  } where open Heterogeneous B

_≈_ : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → (F G : GraphMorphism A B)
  → Set (o₁ ⊔ o₂ ⊔ ℓ₁ ⊔ ℓ₂ ⊔ e₂)
_≈_ = _≈₀_ -×- _≈₁_

isEquivalence : ∀{o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {A : Graph o₁ ℓ₁ e₁} {B : Graph o₂ ℓ₂ e₂}
  → IsEquivalence (_≈_ {A = A}{B})
isEquivalence {A = A}{B} = record
  { refl  = λ {x}       → refl₀  {x} , λ f → refl₁  {x} f
  ; sym   = λ {x}{y}    → map (sym₀   {x}{y})    (sym₁   {x}{y})
  ; trans = λ {x}{y}{z} → zip (trans₀ {x}{y}{z}) (trans₁ {x}{y}{z})
  }
  where
    open IsEquivalence isEquivalence₀
      renaming (refl to refl₀; sym to sym₀; trans to trans₀)
    open IsEquivalence isEquivalence₁
      renaming (refl to refl₁; sym to sym₁; trans to trans₁)

.∘-resp-≈  : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
               {A : Graph o₀ ℓ₀ e₀} {B : Graph o₁ ℓ₁ e₁} {C : Graph o₂ ℓ₂ e₂}
               {F H : GraphMorphism B C} {G I : GraphMorphism A B}
           → F ≈ H → G ≈ I → F ∘ G ≈ H ∘ I
∘-resp-≈ {B = B} {C} {F}{H}{G}{I} F≈H G≈I
  = (λ x → helper₁ (proj₁ G≈I x) (proj₁ F≈H (GraphMorphism.F₀ I x)))
  , (λ q → helper₂ (proj₂ G≈I q) (proj₂ F≈H (GraphMorphism.F₁ I q)))
  where
  open Heterogeneous C
  module C = Graph C
  helper₁ : ∀ {x}
    → GraphMorphism.F₀ G x ≣ GraphMorphism.F₀ I x
    → GraphMorphism.F₀ F (GraphMorphism.F₀ I x) ≣ GraphMorphism.F₀ H (GraphMorphism.F₀ I x)
    → GraphMorphism.F₀ F (GraphMorphism.F₀ G x) ≣ GraphMorphism.F₀ H (GraphMorphism.F₀ I x)
  helper₁ g≣i f≣h = ≣-trans (≣-cong (GraphMorphism.F₀ F) g≣i) f≣h

  helper₂ : ∀ {a b c d} {z w} {f : B [ a ↝ b ]} {h : B [ c ↝ d ]} {i : C [ z ↝ w ]}
         → B [ f ~ h ] → C [ GraphMorphism.F₁ F h ~ i ] → C [ GraphMorphism.F₁ F f ~ i ]
  helper₂ (≈⇒~ f≈h) (≈⇒~ g≈i) = ≈⇒~ (C.Equiv.trans (GraphMorphism.F-resp-≈ F f≈h) g≈i)


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

module Agda.Builtin.Float where

open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Builtin.Int
open import Agda.Builtin.String

postulate Float : Set
{-# BUILTIN FLOAT Float #-}

primitive
  primFloatEquality : Float → Float → Bool
  primFloatLess     : Float → Float → Bool
  primFloatNumericalEquality : Float → Float → Bool
  primFloatNumericalLess     : Float → Float → Bool
  primNatToFloat    : Nat → Float
  primFloatPlus     : Float → Float → Float
  primFloatMinus    : Float → Float → Float
  primFloatTimes    : Float → Float → Float
  primFloatNegate   : Float → Float
  primFloatDiv      : Float → Float → Float
  primFloatSqrt     : Float → Float
  primRound         : Float → Int
  primFloor         : Float → Int
  primCeiling       : Float → Int
  primExp           : Float → Float
  primLog           : Float → Float
  primSin           : Float → Float
  primCos           : Float → Float
  primTan           : Float → Float
  primASin          : Float → Float
  primACos          : Float → Float
  primATan          : Float → Float
  primATan2         : Float → Float → Float
  primShowFloat     : Float → String


------------------------------------------------------------------------
-- Untyped hereditary substitution in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Syntax.SingleVariableSubstitution where

open import Data.Fin using (Fin; zero; suc; raise; lift)
open import Data.Fin.Substitution using (Sub; Subs; Lift; Application)
open import Data.Fin.Substitution.Lemmas using (AppLemmas)
  renaming (module VarLemmas to V)
open import Data.Fin.Substitution.ExtraLemmas
  using (TermLikeLemmas; LiftAppLemmas)
open import Data.Nat using (ℕ; zero; suc; _+_)
import Data.Vec as Vec
open import Data.Vec.Properties using (lookup-map)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_)
open import Relation.Binary.PropositionalEquality as P hiding ([_])

open import FOmegaInt.Syntax renaming (module Substitution to Sub)

----------------------------------------------------------------------
-- Untyped single-variable substitution.

open Syntax
open Sub using (weaken; weakenElim; weakenElim⋆; _Elim/Var_)

-- Suspended single-variable substitions.
--
-- Traditionally, a single-variable substitution [t/x] consists of two
-- data: the name x of the variable to be substituted and the
-- substitute t for the variable.
--
-- The following inductive definition is an alternative representation
-- of this data.  Instead of specifying the variable name (i.e. the de
-- Bruijn index) to be substituted, we use two constructors: one for
-- substituting the zero-th variable (sub) and one for lifting the
-- substitution over an a new free variable (_↑).  The advantage of
-- this representation is that it corresponds more closely to the
-- explicit substitution calculus and the inductive structure of both
-- de Bruijn indices and dependent contexts.  Among other things, this
-- avoids green slime in the definition.
--
-- Since we are working with intrinsically well-scoped syntax, the
-- datatype is parametrized by the number of free variables in the
-- source and target context: a substitution |σ : SVSub m n|, when
-- applied to a term with at most m variables, yields a term with at
-- most n variables.

data SVSub : ℕ → ℕ → Set where
  sub : ∀ {n}   (a : Elim n)    → SVSub (suc n) n
  _↑  : ∀ {m n} (σ : SVSub m n) → SVSub (suc m) (suc n)

-- Repeated lifting.

_↑⋆_ : ∀ {m n} (σ : SVSub m n) k → SVSub (k + m) (k + n)
σ ↑⋆ zero  = σ
σ ↑⋆ suc k = (σ ↑⋆ k) ↑

-- Turn a single-variable substitution into a multi-variable
-- substitution.

toSub : ∀ {m n} → SVSub m n → Sub Term m n
toSub (sub a) = Sub.sub ⌞ a ⌟
toSub (σ ↑)   = (toSub σ) Sub.↑

-- The result of looking up a single-variable substitution.

data SVRes : ℕ → Set where
  hit  : ∀ {n} (a : Elim n) → SVRes n  -- hit: looked up t at x in [t/x]
  miss : ∀ {n} (y : Fin n)  → SVRes n  -- miss: looked up y ≠ x in [t/x]

toElim : ∀ {n} → SVRes n → Elim n
toElim (hit a)  = a
toElim (miss y) = var∙ y

-- Renamings in single-variable substitutions and results.

infixl 8 _?/Var_

_?/Var_ : ∀ {m n} → SVRes m → Sub Fin m n → SVRes n
hit a  ?/Var ρ = hit (a Elim/Var ρ)
miss y ?/Var ρ = miss (Vec.lookup ρ y)

-- Weakening of SV results.

weakenSVRes : ∀ {n} → SVRes n → SVRes (suc n)
weakenSVRes r = r ?/Var V.wk

-- Look up a variable in a single-variable substitution.

lookupSV : ∀ {m n} → SVSub m n → Fin m → SVRes n
lookupSV (sub a) zero    = hit a
lookupSV (sub a) (suc x) = miss x
lookupSV (σ ↑)   zero    = miss zero
lookupSV (σ ↑)   (suc x) = weakenSVRes (lookupSV σ x)

----------------------------------------------------------------------
-- Properties of single-variable substitution and results.

open P.≡-Reasoning

-- Lifting commutes with conversion of substitutions.

↑⋆-toSub : ∀ {m n} {σ : SVSub m n} k → toSub (σ ↑⋆ k) ≡ (toSub σ) Sub.↑⋆ k
↑⋆-toSub zero    = refl
↑⋆-toSub (suc k) = cong Sub._↑ (↑⋆-toSub k)

-- Application of renamings commutes with conversion to terms.

toElim-/Var : ∀ {m n} r {ρ : Sub Fin m n} →
              toElim (r ?/Var ρ) ≡ toElim r Elim/Var ρ
toElim-/Var (hit a)  = refl
toElim-/Var (miss y) = refl

-- Lookup commutes with conversion of substitutions.

lookup-toSub : ∀ {m n} (σ : SVSub m n) (x : Fin m) →
               Vec.lookup (toSub σ) x ≡ ⌞ toElim (lookupSV σ x) ⌟
lookup-toSub (sub a) zero    = refl
lookup-toSub (sub a) (suc x) = Sub.lookup-id x
lookup-toSub (σ ↑)   zero    = refl
lookup-toSub (σ ↑)   (suc x) = begin
  Vec.lookup ((toSub σ) Sub.↑) (suc x)      ≡⟨⟩
  Vec.lookup (Vec.map weaken (toSub σ)) x   ≡⟨ lookup-map x weaken (toSub σ) ⟩
  weaken (Vec.lookup (toSub σ) x)           ≡⟨ cong weaken (lookup-toSub σ x) ⟩
  weaken ⌞ toElim σ[x] ⌟                    ≡˘⟨ Sub.⌞⌟-/Var (toElim σ[x]) ⟩
  ⌞ weakenElim (toElim σ[x]) ⌟              ≡˘⟨ cong ⌞_⌟ (toElim-/Var σ[x]) ⟩
  ⌞ toElim (weakenSVRes σ[x]) ⌟             ≡⟨⟩
  ⌞ toElim (lookupSV (σ ↑) (suc x)) ⌟       ∎
  where
    open P.≡-Reasoning
    σ[x] = lookupSV σ x

-- Lemmas about applications of renamings to SV results

open TermLikeLemmas Sub.termLikeLemmasElim using (varLiftAppLemmas)
open LiftAppLemmas varLiftAppLemmas using (id-vanishes; /-⊙; wk-commutes)

?/Var-id : ∀ {n} (r : SVRes n) → r ?/Var V.id ≡ r
?/Var-id (hit a)  = cong hit (id-vanishes a)
?/Var-id (miss y) = cong miss (V.id-vanishes y)

?/Var-⊙ : ∀ {m n k} {ρ₁ : Sub Fin m n} {ρ₂ : Sub Fin n k} r →
          r ?/Var ρ₁ V.⊙ ρ₂ ≡ r ?/Var ρ₁ ?/Var ρ₂
?/Var-⊙                (hit a)  = cong hit (/-⊙ a)
?/Var-⊙ {ρ₁ = ρ₁} {ρ₂} (miss y) = cong miss (V./-⊙ {ρ₁ = ρ₁} {ρ₂} y)

resAppLemmas : AppLemmas SVRes Fin
resAppLemmas = record
  { application = record { _/_ = _?/Var_ }
  ; lemmas₄     = V.lemmas₄
  ; id-vanishes = ?/Var-id
  ; /-⊙         = ?/Var-⊙
  }

module SVResAppLemmas = AppLemmas resAppLemmas

-- Lookup in a single-variable substitution commutes with renaming

lookup-sub-/Var-↑⋆ : ∀ {m n} a i x {ρ : Sub Fin m n} →
                     lookupSV (sub a ↑⋆ i) x ?/Var ρ V.↑⋆ i  ≡
                     lookupSV (sub (a Elim/Var ρ) ↑⋆ i) (x V./ (ρ V.↑) V.↑⋆ i)
lookup-sub-/Var-↑⋆ a zero zero        = refl
lookup-sub-/Var-↑⋆ a zero (suc x) {ρ} = begin
    miss (Vec.lookup ρ x)
  ≡⟨⟩
    lookupSV (sub (a Elim/Var ρ)) (suc (Vec.lookup ρ x))
  ≡˘⟨ cong (lookupSV (sub (a Elim/Var ρ))) (lookup-map x suc ρ) ⟩
    lookupSV (sub (a Elim/Var ρ)) (Vec.lookup (Vec.map suc ρ) x)
  ≡⟨⟩
    lookupSV (sub (a Elim/Var ρ)) (suc x V./ ρ V.↑)
  ∎
lookup-sub-/Var-↑⋆ a (suc i) zero        = refl
lookup-sub-/Var-↑⋆ a (suc i) (suc x) {ρ} = begin
    weakenSVRes (lookupSV (sub a ↑⋆ i) x) ?/Var (ρ V.↑⋆ i) V.↑
  ≡⟨⟩
    lookupSV (sub a ↑⋆ i) x ?/Var V.wk ?/Var (ρ V.↑⋆ i) V.↑
  ≡˘⟨ SVResAppLemmas.wk-commutes (lookupSV (sub a ↑⋆ i) x) ⟩
    lookupSV (sub a ↑⋆ i) x ?/Var (ρ V.↑⋆ i) ?/Var V.wk
  ≡⟨ cong (_?/Var V.wk) (lookup-sub-/Var-↑⋆ a i x) ⟩
    lookupSV (sub (a Elim/Var ρ) ↑⋆ i) (x V./ ((ρ V.↑) V.↑⋆ i)) ?/Var V.wk
  ≡⟨⟩
    lookupSV ((sub (a Elim/Var ρ) ↑⋆ i) ↑) (suc (x V./ (ρ V.↑) V.↑⋆ i))
  ≡˘⟨ cong (lookupSV ((sub (a Elim/Var ρ) ↑⋆ i) ↑))
           (lookup-map x suc ((ρ V.↑) V.↑⋆ i)) ⟩
    lookupSV ((sub (a Elim/Var ρ) ↑⋆ i) ↑)
             (Vec.lookup (Vec.map suc ((ρ V.↑) V.↑⋆ i)) x)
  ≡⟨⟩
    lookupSV ((sub (a Elim/Var ρ) ↑⋆ i) ↑) (suc x V./ ((ρ V.↑) V.↑⋆ i) V.↑)
  ∎

-- Lookup commutes with weakening

lookup-/Var-wk-↑⋆ : ∀ {m n} i x {σ : SVSub m n} →
                    lookupSV (σ ↑⋆ i) x ?/Var V.wk V.↑⋆ i ≡
                    lookupSV ((σ ↑) ↑⋆ i) (x V./ V.wk V.↑⋆ i)
lookup-/Var-wk-↑⋆ zero x {σ} = begin
    lookupSV σ x ?/Var V.wk
  ≡⟨⟩
    lookupSV (σ ↑) (suc x)
  ≡˘⟨ cong (lookupSV (σ ↑)) V./-wk ⟩
    lookupSV (σ ↑) (x V./ V.wk)
  ∎
lookup-/Var-wk-↑⋆ (suc i) zero        = refl
lookup-/Var-wk-↑⋆ (suc i) (suc x) {σ} = begin
    lookupSV (σ ↑⋆ i) x ?/Var V.wk ?/Var (V.wk V.↑⋆ i) V.↑
  ≡˘⟨ SVResAppLemmas.wk-commutes (lookupSV (σ ↑⋆ i) x) ⟩
    lookupSV (σ ↑⋆ i) x ?/Var V.wk V.↑⋆ i ?/Var V.wk
  ≡⟨ cong weakenSVRes (lookup-/Var-wk-↑⋆ i x) ⟩
    lookupSV (((σ ↑) ↑⋆ i) ↑) (suc (Vec.lookup (V.wk V.↑⋆ i) x))
  ≡˘⟨ cong (lookupSV (((σ ↑) ↑⋆ i) ↑)) (lookup-map x suc (V.wk V.↑⋆ i)) ⟩
    lookupSV (((σ ↑) ↑⋆ i) ↑) (Vec.lookup (Vec.map suc (V.wk V.↑⋆ i)) x)
  ≡⟨⟩
    lookupSV (((σ ↑) ↑⋆ i) ↑) (suc x V./ V.wk V.↑⋆ suc i)
  ∎

----------------------------------------------------------------------
-- Predicates relating SV substitutions to variables.

data Hit : ∀ {m n} → SVSub m n → Fin m → Elim n → Set where
  here : ∀ {n} {a : Elim n} → Hit (sub a) zero a
  _↑   : ∀ {m n} {σ : SVSub m n} {x a} →
         Hit σ x a → Hit (σ ↑) (suc x) (weakenElim a)

data Miss : ∀ {m n} → SVSub m n → Fin m → Fin n → Set where
  over  : ∀ {n} {a : Elim n} {y : Fin n} → Miss (sub a) (suc y) y
  under : ∀ {m n} {σ : SVSub m n} → Miss (σ ↑) zero zero
  _↑    : ∀ {m n} {σ : SVSub m n} {x y} →
          Miss σ x y → Miss (σ ↑) (suc x) (suc y)

data Hit? {m n} (σ : SVSub m n) (x : Fin m) : Set where
  hit  : ∀ a → Hit  σ x a → Hit? σ x
  miss : ∀ y → Miss σ x y → Hit? σ x

toRes : ∀ {m n} {σ : SVSub m n} {x : Fin m} → Hit? σ x → SVRes n
toRes (hit a _)  = hit a
toRes (miss y _) = miss y

-- A version of `lookupSV' that produces a more a more informative
-- result.

hit? : ∀ {m n} (σ : SVSub m n) (x : Fin m) → Hit? σ x
hit? (sub a) zero    = hit a here
hit? (sub a) (suc x) = miss x over
hit? (σ ↑)   zero    = miss zero under
hit? (σ ↑)   (suc x) with hit? σ x
... | hit a hitP   = hit (weakenElim a) (hitP ↑)
... | miss y missP = miss (suc y) (missP ↑)

-- The two versions of lookup agree.

lookup-Hit : ∀ {m n} {σ : SVSub m n} {x : Fin m} {a : Elim n} →
             Hit σ x a → lookupSV σ x ≡ hit a
lookup-Hit here  = refl
lookup-Hit (hitP ↑) = cong weakenSVRes (lookup-Hit hitP)

lookup-Miss : ∀ {m n} {σ : SVSub m n} {x : Fin m} {y : Fin n} →
              Miss σ x y → lookupSV σ x ≡ miss y
lookup-Miss                           over      = refl
lookup-Miss                           under     = refl
lookup-Miss {σ = σ ↑} {suc x} {suc y} (missP ↑) = begin
  weakenSVRes (lookupSV σ x)  ≡⟨ cong weakenSVRes (lookup-Miss missP) ⟩
  miss (y V./ V.wk)           ≡⟨ cong miss V./-wk ⟩
  miss (suc y)                ∎

hit?-lookup : ∀ {m n} (σ : SVSub m n) (x : Fin m) →
              lookupSV σ x ≡ toRes (hit? σ x)
hit?-lookup σ x with hit? σ x
... | (hit a hitP)   = lookup-Hit hitP
... | (miss y missP) = lookup-Miss missP

-- The Hit predicate is functional.

Hit-functional₁ : ∀ {m n} {σ : SVSub m n} {x y : Fin m} {a b : Elim n} →
                  Hit σ x a → Hit σ y b → x ≡ y
Hit-functional₁ here      here      = refl
Hit-functional₁ (hitP₁ ↑) (hitP₂ ↑) = cong suc (Hit-functional₁ hitP₁ hitP₂)

Hit-functional₂ : ∀ {m n} {σ : SVSub m n} {x y : Fin m} {a b : Elim n} →
                  Hit σ x a → Hit σ y b → a ≡ b
Hit-functional₂ here      here      = refl
Hit-functional₂ (hitP₁ ↑) (hitP₂ ↑) =
  cong weakenElim (Hit-functional₂ hitP₁ hitP₂)

-- For a fixed σ, the Miss predicate is injective.

Miss-injective : ∀ {m n} {σ : SVSub m n} {x y : Fin m} {z : Fin n} →
                 Miss σ x z → Miss σ y z → x ≡ y
Miss-injective over      over      = refl
Miss-injective under     under     = refl
Miss-injective (hitP₁ ↑) (hitP₂ ↑) = cong suc (Miss-injective hitP₁ hitP₂)

-- Lifting preserves the predicates

Hit-↑⋆ : ∀ {m n} {σ : SVSub m n} {x : Fin m} {a : Elim n} i →
         Hit σ x a → Hit (σ ↑⋆ i) (raise i x) (weakenElim⋆ i a)
Hit-↑⋆ zero    hyp = hyp
Hit-↑⋆ (suc i) hyp = (Hit-↑⋆ i hyp) ↑

Miss-↑⋆ : ∀ {m n} {σ : SVSub m n} {x : Fin m} {y : Fin n} i →
          Miss σ x y → Miss (σ ↑⋆ i) (raise i x) (raise i y)
Miss-↑⋆ zero    hyp = hyp
Miss-↑⋆ (suc i) hyp = (Miss-↑⋆ i hyp) ↑

Hit-↑-↑⋆ : ∀ {m n} {σ : SVSub m n} i {x a} → Hit (σ ↑⋆ i) x a →
           Hit ((σ ↑) ↑⋆ i) (lift i suc x) (a Elim/Var V.wk V.↑⋆ i)
Hit-↑-↑⋆ zero    hyp               = hyp ↑
Hit-↑-↑⋆ (suc i) (_↑ {a = a} hyp ) =
  subst (Hit _ _) (wk-commutes a) (Hit-↑-↑⋆ i hyp ↑)

Miss-↑-↑⋆ : ∀ {m n} {σ : SVSub m n} i {x y} → Miss (σ ↑⋆ i) x y →
            Miss ((σ ↑) ↑⋆ i) (lift i suc x) (lift i suc y)
Miss-↑-↑⋆ zero    hyp     = hyp ↑
Miss-↑-↑⋆ (suc i) under   = under
Miss-↑-↑⋆ (suc i) (hyp ↑) = (Miss-↑-↑⋆ i hyp) ↑

-- Yet another way to characterize hits/misses of single-variable
-- substitutions.

Hit-sub-↑⋆ : ∀ {n} {a : Elim n} i →
             Hit (sub a ↑⋆ i) (raise i zero) (weakenElim⋆ i a)
Hit-sub-↑⋆ i = Hit-↑⋆ i here

Hit-sub-↑⋆₁ : ∀ {n} {a : Elim n} i {x b} →
              Hit (sub a ↑⋆ i) x b → x ≡ raise i zero
Hit-sub-↑⋆₁ i hyp = Hit-functional₁ hyp (Hit-sub-↑⋆ i)

Hit-sub-↑⋆₂ : ∀ {n} {a : Elim n} i {x b} →
              Hit (sub a ↑⋆ i) x b → b ≡ weakenElim⋆ i a
Hit-sub-↑⋆₂ i hyp = Hit-functional₂ hyp (Hit-sub-↑⋆ i)

Miss-sub-↑⋆ : ∀ {n} {a : Elim n} i x → Miss (sub a ↑⋆ i) (lift i suc x) x
Miss-sub-↑⋆ zero    x       = over
Miss-sub-↑⋆ (suc i) zero    = under
Miss-sub-↑⋆ (suc i) (suc x) = Miss-sub-↑⋆ i x ↑

Miss-sub-↑⋆′ : ∀ {n} {a : Elim n} i {x} y →
               Miss (sub a ↑⋆ i) x y → x ≡ lift i suc y
Miss-sub-↑⋆′ i y hyp = Miss-injective hyp (Miss-sub-↑⋆ i y)

-- Looking up a sufficiently weakened variable will always miss.

lookup-sub-wk-↑⋆ : ∀ {n} i x {a : Elim n} →
                   lookupSV (sub a ↑⋆ i) (x V./ V.wk V.↑⋆ i) ≡ miss x
lookup-sub-wk-↑⋆ i x {a} = begin
    lookupSV (sub a ↑⋆ i) (x V./ V.wk V.↑⋆ i)
  ≡⟨ cong (lookupSV (sub a ↑⋆ i)) (V.lookup-wk-↑⋆ i x) ⟩
    lookupSV (sub a ↑⋆ i) (lift i suc x)
  ≡⟨ lookup-Miss (Miss-sub-↑⋆ i x) ⟩
    miss x
  ∎

-- A predicate for comparing variable names to naturals.
--
-- Instances of |Eq? n x| are proofs that a natural number |n| is or
-- is not "equal" to a variable name |x|.  Given two natural numbers
-- m, n and a "name" x in the interval { 0, ..., (n + 1 + m) }, "yes"
-- instances of the |Eq? n x| prove that "n = x", while "no" instances
-- prove that x is any one of the other names in the interval.
--
-- The predicate is useful for deciding whether a lookup of |x| in
-- some single-variable substitutions will lead to a hit or miss,
-- independently of the actual substitution.
--
-- NOTE. This predicate is only used in the proof of one lemma, namely
-- FOmegaInt.Kinding.Simple.EtaExpansion.Nf∈-[]-η-var.  Maybe the
-- proof of the lemma could be rewritten so as to avoid the
-- introduction of this extra predicate, but this might reduce
-- clarity.

data Eq? {m : ℕ} (n : ℕ) (x : Fin (n + suc m)) : Set where
  yes : raise n zero ≡ x       → Eq? n x
  no  : ∀ y → lift n suc y ≡ x → Eq? n x

-- Eq? is stable w.r.t. increments.

suc-Eq? : ∀ {m n} {x : Fin (n + suc m)} → Eq? n x → Eq? (suc n) (suc x)
suc-Eq? (yes refl)  = yes refl
suc-Eq? (no y refl) = no (suc y) refl

-- A decision procedure for Eq?.

compare : ∀ {m} n (x : Fin (n + suc m)) → Eq? n x
compare zero    zero    = yes refl
compare zero    (suc x) = no x refl
compare (suc n) zero    = no zero refl
compare (suc n) (suc x) = suc-Eq? (compare n x)

-- Turn Eq? instances into Hit? instances for a given substitution.

toHit? : ∀ {m n} {a : Elim m} {x} → Eq? n x → Hit? (sub a ↑⋆ n) x
toHit? {_} {n} (yes refl)  = hit _ (Hit-sub-↑⋆ n)
toHit? {_} {n} (no y refl) = miss y (Miss-sub-↑⋆ n y)


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

open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; subst; setoid)
open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂; zip; map; <_,_>; swap)
import Function.Equality
open import Relation.Binary using (Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidR

import Categories.Category
import Categories.Functor
import Categories.Category.Instance.Setoids
import Categories.Monad.Relative
import Categories.Category.Equivalence
import Categories.Category.Cocartesian
import Categories.Category.Construction.Functors
import Categories.Category.Product
import Categories.NaturalTransformation
import Categories.NaturalTransformation.NaturalIsomorphism

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.VRenaming
import SecondOrder.MRenaming
import SecondOrder.Term
import SecondOrder.Substitution
import SecondOrder.RelativeMonadMorphism
import SecondOrder.Instantiation
import SecondOrder.IndexedCategory
import SecondOrder.RelativeKleisli

module SecondOrder.Mslot
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ
  open SecondOrder.Term Σ
  open SecondOrder.VRenaming Σ
  open SecondOrder.MRenaming Σ
  -- open SecondOrder.Substitution Σ
  -- open import SecondOrder.RelativeMonadMorphism
  -- open SecondOrder.Instantiation
  open Categories.Category
  open Categories.Functor using (Functor)
  open Categories.NaturalTransformation renaming (id to idNt)
  open Categories.NaturalTransformation.NaturalIsomorphism renaming (refl to reflNt; sym to symNt; trans to transNt)
  open Categories.Category.Construction.Functors
  open Categories.Category.Instance.Setoids
  open Categories.Category.Product
  open Function.Equality using () renaming (setoid to Π-setoid)
  open SecondOrder.IndexedCategory
  -- open import SecondOrder.RelativeKleisli

  MTele = MContexts
  VTele = VContexts

  -- the codomain category of the MSlots functor. It should be equivalent to the
  -- functor category [ MTele x VTele , < Setoid >ₛₒᵣₜ ]
  -- objects are functors, which are really pairs of functions, one on objects
  -- one on morphisms
  -- morphisms in this category are natural transformations

  module _ where
    open Category
    open NaturalTransformation
    open Function.Equality renaming (_∘_ to _∙_)

    ∘ᵥ-resp-≈ : ∀ {o l e o' l' e'} {𝒞 : Category o l e} {𝒟 : Category o' l' e'}
                {F G H : Functor 𝒞 𝒟} {α β : NaturalTransformation F G} {γ δ : NaturalTransformation G H}
              → (∀ {X : Obj 𝒞} → (𝒟 Category.≈ (η α X)) (η β X))
              → (∀ {X : Obj 𝒞} → (𝒟 Category.≈ (η γ X)) (η δ X))
              -------------------------------------------------------------------
              → (∀ {X : Obj 𝒞} → (𝒟 Category.≈ (η (γ ∘ᵥ α) X)) (η (δ ∘ᵥ β) X))
    ∘ᵥ-resp-≈ {𝒟 = 𝒟} α≈β γ≈δ {X = X} = ∘-resp-≈ 𝒟 γ≈δ α≈β

  MCodom : Category (lsuc ℓ) ℓ ℓ
  MCodom =
    let open Category in
    let open Functor in
    let open NaturalTransformation in
    let open Function.Equality using (_⟨$⟩_) renaming (cong to func-cong) in
    let open Category.HomReasoning in
    record
    { Obj = Functor MTele (Functors VTele (Setoids ℓ ℓ))
    ; _⇒_ = NaturalTransformation
    ; _≈_ = λ {F} {G} α β → ∀ (ψ : Obj MTele) (Γ : Obj VTele)
          → (Setoids ℓ ℓ Category.≈ (η ((η α) ψ) Γ)) (η ((η β) ψ) Γ)
    ; id = idNt
    ; _∘_ = _∘ᵥ_
    ; assoc = λ ψ Γ x≈y → Setoid.refl {!!}
    ; sym-assoc = λ ψ Γ x≈y → Setoid.refl {!!}
    ; identityˡ = λ {F} {G} {α} ψ Γ x≈y → Setoid.refl {!!}
    ; identityʳ = λ ψ Γ x → Setoid.refl {!!}
    ; identity² = Setoid.refl {!!}
    ; equiv = record
              { refl = Setoid.refl {!!}
              ; sym = Setoid.sym {!!}
              ; trans = Setoid.trans {!!}
              }
    ; ∘-resp-≈ = λ {F} {G} {H} {α} {β} {γ} {δ} α≈β γ≈δ ψ Γ
      → ∘ᵥ-resp-≈ {α = γ} {δ} {γ = α} {β} (γ≈δ _ _) (α≈β _ _)
    }

  Mslots : Functor MContexts (IndexedCategory sort (MCodom))
  Mslots =
    let open Categories.NaturalTransformation in
    let open NaturalTransformation in
          record
            { F₀ = λ Θ A →
                 record
                 { F₀ = λ ψ → Term-Functor {Θ ,, ψ} {A}
                 ; F₁ = λ ι → MRenaming-NT (ᵐ⇑ᵐ ι)
                 ; identity = λ t≈s → ≈-trans (≈-trans ([]ᵐ-resp-≡ᵐ ᵐ⇑ᵐ-resp-idᵐ) [idᵐ]) t≈s
                 ; homomorphism = λ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) (≈-trans ([]ᵐ-resp-≡ᵐ ᵐ⇑ᵐ-resp-∘ᵐ) [∘ᵐ])
                 ; F-resp-≈ = λ ι≡μ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) ([]ᵐ-resp-≡ᵐ (ᵐ⇑ᵐ-resp-≡ᵐ ι≡μ))
                 }
            ; F₁ = λ {Θ} {Θ'} ι A →
                 record
                 { η = λ Ψ →
                     record { η = λ Γ → η (MRenaming-NT (⇑ᵐ ι)) Γ
                            ; commute = commute (MRenaming-NT (⇑ᵐ ι))
                            ; sym-commute = sym-commute (MRenaming-NT (⇑ᵐ ι))
                            }
                 ; commute = λ ι t≈s
                           → ≈-trans ([]ᵐ-resp-≈ ([]ᵐ-resp-≈ t≈s)) ⇑-resp-+
                 ; sym-commute = λ ι t≈s → ≈-trans (≈-sym ⇑-resp-+) (([]ᵐ-resp-≈ ([]ᵐ-resp-≈ t≈s)))
                 }
            ; identity = λ Θ ψ Γ t≈s
              → ≈-trans ([]ᵐ-resp-≈ t≈s) (≈-trans ([]ᵐ-resp-≡ᵐ ⇑ᵐ-resp-idᵐ) [idᵐ])
            ; homomorphism = λ A ψ Γ t≈s
              → ≈-trans ([]ᵐ-resp-≈ t≈s) ∘ᵐ-resp-⇑-term
            ; F-resp-≈ = λ ι≡μ A ψ Γ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) ([]ᵐ-resp-≡ᵐ (⇑ᵐ-resp-≡ᵐ ι≡μ))
            }


open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst; cong)

open import Syntax
import Renaming

-- Substitutions
module Substitution where

  module _ {𝕊 : Signature} where

    open Expression 𝕊
    open Renaming
    open Equality

    infix 5 _∥_→ˢ_

    -- the set of substitutions
    _∥_→ˢ_ : MShape → VShape → VShape → Set
    𝕄 ∥ γ →ˢ δ = var γ → ExprTm 𝕄 δ

    -- equality of substitutions

    infix 4 _≈ˢ_

    _≈ˢ_ : ∀ {𝕄} {γ δ} (σ : 𝕄 ∥ γ →ˢ δ) (σ : 𝕄 ∥ γ →ˢ δ) → Set
    σ ≈ˢ τ = ∀ x → σ x ≈ τ x

    -- equality is an equivalence relation

    ≈ˢ-refl : ∀ {𝕄} {γ δ} {σ : 𝕄 ∥ γ →ˢ δ} → σ ≈ˢ σ
    ≈ˢ-refl x = ≈-refl

    ≈ˢ-sym : ∀ {𝕄} {γ δ} {σ τ : 𝕄 ∥ γ →ˢ δ} → σ ≈ˢ τ → τ ≈ˢ σ
    ≈ˢ-sym ξ x = ≈-sym (ξ x)

    ≈ˢ-trans : ∀ {𝕄} {γ δ} {σ τ χ : 𝕄 ∥ γ →ˢ δ} → σ ≈ˢ τ → τ ≈ˢ χ → σ ≈ˢ χ
    ≈ˢ-trans ζ ξ x = ≈-trans (ζ x) (ξ x)

    -- identity substitution
    𝟙ˢ : ∀ {𝕄} {γ} → 𝕄 ∥ γ →ˢ γ
    𝟙ˢ = expr-var

    -- inclusions

    inlˢ : ∀ {𝕄} {γ δ} → 𝕄 ∥ γ →ˢ γ ⊕ δ
    inlˢ x = expr-var (var-left x)

    inrˢ : ∀ {𝕄} {γ δ} → 𝕄 ∥ δ →ˢ γ ⊕ δ
    inrˢ x = expr-var (var-right x)

    -- join of substitutions

    [_,_]ˢ : ∀ {𝕄} {γ δ η} → (𝕄 ∥ γ →ˢ η) → (𝕄 ∥ δ →ˢ η) → (𝕄 ∥ γ ⊕ δ →ˢ η)
    [ ξ , σ ]ˢ (var-left x) = ξ x
    [ ξ , σ ]ˢ (var-right y) = σ y

    -- join respect equality

    [,]ˢ-resp-≈ˢ : ∀ {𝕄} {γ δ η} {ρ₁ ρ₂ : 𝕄 ∥ γ →ˢ η} {τ₁ τ₂ : 𝕄 ∥ δ →ˢ η} →
                 ρ₁ ≈ˢ ρ₂ → τ₁ ≈ˢ τ₂ → [ ρ₁ , τ₁ ]ˢ ≈ˢ [ ρ₂ , τ₂ ]ˢ
    [,]ˢ-resp-≈ˢ ζ ξ (var-left x) = ζ x
    [,]ˢ-resp-≈ˢ ζ ξ (var-right y) = ξ y

    -- substutution extension

    ⇑ˢ : ∀ {𝕄} {γ δ η} → (𝕄 ∥ γ →ˢ δ) → (𝕄 ∥ γ ⊕ η →ˢ δ ⊕ η)
    ⇑ˢ σ (var-left x) = [ var-left ]ʳ σ x
    ⇑ˢ σ (var-right y) = expr-var (var-right y)

    -- extension preserves equality

    ⇑ˢ-resp-≈ˢ : ∀ {𝕄} {γ δ η} {σ τ : 𝕄 ∥ γ →ˢ δ} → σ ≈ˢ τ → ⇑ˢ {η = η} σ ≈ˢ ⇑ˢ τ
    ⇑ˢ-resp-≈ˢ ξ (var-left x) = []ʳ-resp-≈ var-left (ξ x)
    ⇑ˢ-resp-≈ˢ ξ (var-right y) = ≈-refl

    -- extension preserves identity

    ⇑ˢ-𝟙ˢ : ∀ {𝕄} {γ δ} → ⇑ˢ 𝟙ˢ ≈ˢ 𝟙ˢ {𝕄 = 𝕄} {γ = γ ⊕ δ}
    ⇑ˢ-𝟙ˢ (var-left x) = ≈-refl
    ⇑ˢ-𝟙ˢ (var-right x) = ≈-refl

    -- action of a substitution

    infix 5 [_]ˢ_

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

    -- the action respects equality

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

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

    []ˢ-resp-≈ˢ-≈ : ∀ {cl 𝕄} {γ δ} {σ τ : 𝕄 ∥ γ →ˢ δ} {t u : Expr cl 𝕄 γ} → σ ≈ˢ τ → t ≈ u → [ σ ]ˢ t ≈ [ τ ]ˢ u
    []ˢ-resp-≈ˢ-≈ {τ = τ} {t = t} ζ ξ = ≈-trans ([]ˢ-resp-≈ˢ ζ t) ([]ˢ-resp-≈ τ ξ)

    -- composition of substitutions

    infixl 7 _∘ˢ_

    _∘ˢ_ : ∀ {𝕄} {γ δ η} → (𝕄 ∥ δ →ˢ η) → (𝕄 ∥ γ →ˢ δ) → (𝕄 ∥ γ →ˢ η)
    (ξ ∘ˢ σ) x = [ ξ ]ˢ (σ x)

    -- sum of substitutions

    infixl 8 _⊕ˢ_

    _⊕ˢ_ : ∀ {𝕄} {γ δ η χ} → (𝕄 ∥ γ →ˢ δ) → (𝕄 ∥ η →ˢ χ) → (𝕄 ∥ γ ⊕ η →ˢ δ ⊕ χ)
    σ ⊕ˢ τ = [ inlˢ ∘ˢ σ , inrˢ ∘ˢ τ  ]ˢ

    -- composition of renaming and substitition

    infixr 7 _ʳ∘ˢ_

    _ʳ∘ˢ_ : ∀ {𝕄} {γ δ η} → (δ →ʳ η) → (𝕄 ∥ γ →ˢ δ) → (𝕄 ∥ γ →ˢ η)
    (ρ ʳ∘ˢ σ) x = [ ρ ]ʳ σ x

    infixl 7 _ˢ∘ʳ_

    _ˢ∘ʳ_ : ∀ {𝕄} {γ δ η} → (𝕄 ∥ δ →ˢ η) → (γ →ʳ δ) → (𝕄 ∥ γ →ˢ η)
    (σ ˢ∘ʳ ρ) x =  σ (ρ x)

    -- extension commutes with the composition of renaming and substitution

    ⇑ˢ-resp-ʳ∘ˢ : ∀ {𝕄} {γ δ η θ} {ρ : δ →ʳ η} → {σ : 𝕄 ∥ γ →ˢ δ} →
                  ⇑ˢ {η = θ} (ρ ʳ∘ˢ σ) ≈ˢ ⇑ʳ ρ ʳ∘ˢ ⇑ˢ σ
    ⇑ˢ-resp-ʳ∘ˢ {σ = σ} (var-left x) =
      ≈-trans
        (≈-sym ([∘ʳ] (σ x)))
        (≈-trans
           ([]ʳ-resp-≡ʳ (σ x) ≡ʳ-refl)
           ([∘ʳ] (σ x)))
    ⇑ˢ-resp-ʳ∘ˢ (var-right y) = ≈-refl

    ⇑ˢ-resp-ˢ∘ʳ : ∀ {𝕄} {β γ δ η} {ρ : β →ʳ γ} {σ : 𝕄 ∥ γ →ˢ δ} → ⇑ˢ {η = η} (σ ˢ∘ʳ ρ) ≈ˢ ⇑ˢ σ ˢ∘ʳ ⇑ʳ ρ
    ⇑ˢ-resp-ˢ∘ʳ (var-left x) = ≈-refl
    ⇑ˢ-resp-ˢ∘ʳ (var-right y) = ≈-refl

    ⇑ˢ-ʳ∘ˢ : ∀ {𝕄} {β γ δ η} {σ : 𝕄 ∥ β →ˢ γ} {ρ : γ →ʳ δ} → ⇑ˢ {η = η} (ρ ʳ∘ˢ σ) ≈ˢ ⇑ʳ ρ ʳ∘ˢ ⇑ˢ σ
    ⇑ˢ-ʳ∘ˢ (var-left x) = ≈-trans (≈-trans (≈-sym ([∘ʳ] _)) ([]ʳ-resp-≡ʳ _ λ x → refl)) ([∘ʳ] _)
    ⇑ˢ-ʳ∘ˢ (var-right x) = ≈-refl

    -- action of a composition of a renaming and a substitition

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

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

    -- composition commutes with extensions

    ⇑ˢ-resp-∘ˢ : ∀ {𝕄} {β γ δ η} {σ : 𝕄 ∥ β →ˢ γ} {τ : 𝕄 ∥ γ →ˢ δ} → ⇑ˢ {η = η} (τ ∘ˢ σ) ≈ˢ ⇑ˢ τ ∘ˢ ⇑ˢ σ
    ⇑ˢ-resp-∘ˢ {σ = σ} (var-left x) = ≈-trans (≈-trans (≈-sym ([ʳ∘ˢ] (σ x))) ([]ˢ-resp-≈ˢ (λ x₁ → ≈-refl) (σ x))) ([ˢ∘ʳ] (σ x))
    ⇑ˢ-resp-∘ˢ (var-right y) = ≈-refl

    -- action of substitutions is functorial

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

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

    []ˢ-id : ∀ {cl 𝕄 γ} {σ : 𝕄 ∥ γ →ˢ γ} {t : Expr cl 𝕄 γ} → σ ≈ˢ 𝟙ˢ → [ σ ]ˢ t ≈ t
    []ˢ-id {t = t} ξ = ≈-trans ([]ˢ-resp-≈ˢ ξ t) ([𝟙ˢ] t)

    []ˢ-𝟘-initial : ∀ {cl 𝕄 γ} {σ : 𝕄 ∥ γ →ˢ 𝟘} (t : Expr cl 𝕄 𝟘) → [ σ ]ˢ [ 𝟘-initial ]ʳ t ≈ t
    []ˢ-𝟘-initial (expr-symb S es) =
      ≈-symb (λ i → ≈-trans (≈-sym ([ˢ∘ʳ] (es i))) ([]ˢ-id (λ {(var-right x) → ≈-refl})))
    []ˢ-𝟘-initial (expr-meta M ts) = ≈-meta (λ i → []ˢ-𝟘-initial (ts i))
    []ˢ-𝟘-initial expr-eqty = ≈-eqty
    []ˢ-𝟘-initial expr-eqtm = ≈-eqtm

  infix 5 _%_∥_→ˢ_
  _%_∥_→ˢ_ : ∀ (𝕊 : Signature) → MShape → VShape → VShape → Set
  _%_∥_→ˢ_ 𝕊 = _∥_→ˢ_ {𝕊 = 𝕊}


data Cx (U : Set) : Set where
  ∅   : Cx U
  _,_ : Cx U → U → Cx U

data _∈_ {U : Set} (A : U) : Cx U → Set where
  top : ∀ {Γ} → A ∈ (Γ , A)
  pop : ∀ {B Γ} → A ∈ Γ → A ∈ (Γ , B)

infixr 3 _⇒_
data Ty : Set where
  ι   : Ty
  _⇒_ : Ty → Ty → Ty
  □_  : Ty → Ty

infix 1 _⊢_
data _⊢_ : Cx Ty → Ty → Set where
  var  : ∀ {Γ A}     → A ∈ Γ → Γ ⊢ A
  app  : ∀ {Γ A B}   → Γ ⊢ A ⇒ B → Γ ⊢ A → Γ ⊢ B
  nec  : ∀ {A}       → ∅ ⊢ A → ∅ ⊢ □ A
  kcom : ∀ {Γ A B}   → Γ ⊢ A ⇒ B ⇒ A
  scom : ∀ {Γ A B C} → Γ ⊢ (A ⇒ B ⇒ C) ⇒ (A ⇒ B) ⇒ A ⇒ C
  dist : ∀ {Γ A B}   → Γ ⊢ □ (A ⇒ B) ⇒ □ A ⇒ □ B
  down : ∀ {Γ A}     → Γ ⊢ □ A ⇒ A
  up   : ∀ {Γ A}     → Γ ⊢ □ A ⇒ □ □ A

icom : ∀ {A Γ} → Γ ⊢ A ⇒ A
icom {A} = app (app (scom {A = A} {B = A ⇒ A} {C = A}) kcom) kcom

ded : ∀ {A B Γ} → Γ , A ⊢ B → Γ ⊢ A ⇒ B
ded (var top)     = icom
ded (var (pop i)) = app kcom (var i)
ded (app t u)     = app (app scom (ded t)) (ded u)
ded (nec t)       = ?
ded kcom          = app kcom kcom
ded scom          = app kcom scom
ded dist          = app kcom dist
ded down          = app kcom down
ded up            = app kcom up


{-# OPTIONS --rewriting        #-}
{-# OPTIONS --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

module _ (A : Set) where
  postulate
    D : Set
    f : D → D → D
    r : (x y z : D) → f x (f y z) ≡ f x z

  {-# REWRITE r #-}
  -- WAS:
  -- Confluence check failed: f x (f y (f y₁ z)) reduces to both
  -- f x (f y₁ z) and f x (f y z) which are not equal because
  -- y != y₁ of type D
  -- when checking confluence of the rewrite rule r with itself

  module _ (x y y₁ z : D) where
    -- SUCCEEDS:
    _ : f x (f y₁ z) ≡ f x (f y z)
    _ = refl


{-# OPTIONS --allow-unsolved-metas #-}
module LiteralSequent where

open import Sequent
open import IsLiteralSequent

record LiteralSequent : Set
 where
  constructor ⟨_⟩
  field
    {sequent} : Sequent
    isLiteralSequent : IsLiteralSequent sequent

open LiteralSequent public

open import OscarPrelude

private
  module _ where

    pattern ⟪_,_⟫ h s = ⟨_⟩ {h} s
    pattern ⟪_⟫ h = (⟨_⟩ {h} _)

instance EqLiteralSequent : Eq LiteralSequent
Eq._==_ EqLiteralSequent ⟪ Φ₁ ⟫ ⟪ Φ₂ ⟫   with Φ₁ ≟ Φ₂
Eq._==_ EqLiteralSequent ⟨ !Φ₁ ⟩ ⟨ !Φ₂ ⟩ | yes refl with !Φ₁ ≟ !Φ₂
Eq._==_ EqLiteralSequent _ _             | yes refl | yes refl = yes refl
Eq._==_ EqLiteralSequent ⟨ Φ₁ ⟩ ⟨ Φ₂ ⟩   | yes refl | no !Φ₁≢!Φ₂ = no λ {refl → !Φ₁≢!Φ₂ refl}
Eq._==_ EqLiteralSequent ⟨ Φ₁ ⟩ ⟨ Φ₂ ⟩   | no Φ₁≢Φ₂ = no λ {refl → Φ₁≢Φ₂ refl}

module _ where

  open import HasNegation
  open import IsLiteralFormula

  instance HasNegationLiteralSequent : HasNegation LiteralSequent
  HasNegation.~ HasNegationLiteralSequent ⟨ atomic 𝑃 τs ╱ φˢs ⟩ = ⟨ logical 𝑃 τs ╱ φˢs ⟩
  HasNegation.~ HasNegationLiteralSequent ⟨ logical 𝑃 τs ╱ φˢs ⟩ = ⟨ atomic 𝑃 τs ╱ φˢs ⟩

open import 𝓐ssertion

instance 𝓐ssertionLiteralSequent : 𝓐ssertion LiteralSequent
𝓐ssertionLiteralSequent = record {}

open import HasSatisfaction

instance HasSatisfactionLiteralSequent : HasSatisfaction LiteralSequent
HasSatisfaction._⊨_ HasSatisfactionLiteralSequent I Φ = I ⊨ sequent Φ

open import HasDecidableValidation

instance HasDecidableValidationLiteralSequent : HasDecidableValidation LiteralSequent
HasDecidableValidationLiteralSequent = {!!}


------------------------------------------------------------------------------
-- Testing the existential quantifier
------------------------------------------------------------------------------

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

module Existential where

postulate
  D : Set
  A : D → Set
  ∃ : (A : D → Set) → Set

postulate foo : (∃ λ x → A x) → (∃ λ x → A x)
{-# ATP prove foo #-}


-- Also works for parts of operators.
module NotInScope where

postulate
  X : Set
  if_then_else_ : X -> X -> X -> X
  x : X

bad = if x thenn x else x


-- A cut-down example:

module Issue295 where

data ⊥ : Set where

data Arr : Set where
  _⟶_ : ⊥ → ⊥ → Arr

_﹔_ : Arr → Arr → Arr
(a ⟶ b)﹔(c ⟶ d) with b
... | ()

data Fun : Arr → Set where
  ∙ : ∀ a b c d → Fun (a ⟶ b) → Fun (c ⟶ d) → Fun ((a ⟶ b)﹔(c ⟶ d))

f : ∀ a b c d e f → Fun (a ⟶ b) → Fun (c ⟶ d) → Fun (e ⟶ f)
f a b c d e f F G = ∙ a b c d F G

-- The problem does not appear to be restricted to the pretty-printer.
-- With -v10 I get the following output:
--
-- compareTerm (a ⟶ b) ﹔ (b ⟶ c) == a ⟶ c : Arr
-- { compareAtom
-- compareAtom (b ⟶ a) ﹔ (c ⟶ b) | b == a ⟶ c : Arr
-- /tmp/Bug.agda:16,15-28
-- (b ⟶ a) ﹔ (c ⟶ b) | b != a ⟶ c of type Arr
-- when checking that the expression ∙ a b b c F G has type
-- Fun (a ⟶ c)


module Structure.Category.Functor.Functors.Proofs where

import      Functional as Fn
import      Function.Equals
open        Function.Equals.Dependent
open import Function.Equals.Proofs
open import Logic.Predicate
open import Logic.Propositional
import      Lvl
open import Relator.Equals.Proofs.Equivalence
open import Structure.Category
open import Structure.Category.Functor
open import Structure.Category.Functor.Equiv
open import Structure.Category.Functor.Functors
open import Structure.Category.Morphism.IdTransport
open import Structure.Category.NaturalTransformation
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓₒ ℓₘ ℓₑ : Lvl.Level
private variable A B C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}

open CategoryObject
open Category ⦃ … ⦄
open Functor ⦃ … ⦄

module _ where
  open Wrapped

  -- TODO: Prove transport-of-congruenced-bifunctor
  [∘ᶠᵘⁿᶜᵗᵒʳ]-binaryOperator : BinaryOperator(_∘ᶠᵘⁿᶜᵗᵒʳ_ {A = A}{B = B}{C = C})
  _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (BinaryOperator.congruence ([∘ᶠᵘⁿᶜᵗᵒʳ]-binaryOperator {A = A} {B = B} {C = C}) {[∃]-intro F₁} {[∃]-intro F₂} {[∃]-intro G₁} {[∃]-intro G₂} (intro fp₁ mp₁) (intro fp₂ mp₂)) = congruence₂(Fn._∘_) ⦃ [⊜][∘]-binaryOperator ⦃ function = [≡]-function ⦄ ⦄ fp₁ fp₂ where
    instance _ = [≡]-equiv {T = Object(B)}
    instance _ = [≡]-equiv {T = Object(C)}
  NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (BinaryOperator.congruence ([∘ᶠᵘⁿᶜᵗᵒʳ]-binaryOperator {A = A} {B = B} {C = C}) {[∃]-intro F₁}{[∃]-intro F₂} {[∃]-intro G₁}{[∃]-intro G₂} (intro fp₁ mp₁) (intro fp₂ mp₂))) {x}{y} {f} = anything {-
    transport C (_⊜_.proof (congruence₂(Fn._∘_) ⦃ [⊜][∘]-binaryOperator ⦃ function = [≡]-function _ ⦄ ⦄ fp₁ fp₂)) ∘ map(map f)      🝖-[ {!x₂ y₂!} ]
    map(map f) ∘ transport C ([≡]-with-op (Object C) (λ v v₁ → {!v!}) (_⊜_.proof fp₁) (_⊜_.proof fp₂)) 🝖-[ {!!} ]
    map(map f) ∘ transport C (_⊜_.proof (congruence₂(Fn._∘_) ⦃ [⊜][∘]-binaryOperator ⦃ function = [≡]-function _ ⦄ ⦄ fp₁ fp₂)) 🝖-end-}
    where
      postulate anything : ∀{ℓ}{a : Type{ℓ}} → a
      open module MorphismEquivB {x}{y} = Equiv(morphism-equiv B {x}{y}) using () renaming (_≡_ to _≡B_)
      open module MorphismEquivC {x}{y} = Equiv(morphism-equiv C {x}{y}) using () renaming (_≡_ to _≡C_)
      instance _ = category A
      instance _ = category B
      instance _ = category C
      instance _ = [≡]-equiv {T = Object B}
      instance _ = [≡]-equiv {T = Object C}
      -- [≡]-with-op

  instance
    [∘ᶠᵘⁿᶜᵗᵒʳ]-identityₗ : Morphism.Identityₗ {Obj = CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} (\{A} → _∘ᶠᵘⁿᶜᵗᵒʳ_ {A = A})(idᶠᵘⁿᶜᵗᵒʳ)
    _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Morphism.Identityₗ.proof ([∘ᶠᵘⁿᶜᵗᵒʳ]-identityₗ) {y = B}) = reflexivity(_⊜_) where
      instance _ = [≡]-equiv {T = Object(B)}
    NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Morphism.Identityₗ.proof [∘ᶠᵘⁿᶜᵗᵒʳ]-identityₗ {A} {B} {[∃]-intro F})) {x} {y} {f} =
      id ∘ map f 🝖-[ Morphism.identityₗ(_∘_)(id) ]
      map f      🝖-[ Morphism.identityᵣ(_∘_)(id) ]-sym
      map f ∘ id 🝖-end
      where
        open module MorphismEquivB {x}{y} = Equiv(morphism-equiv B {x}{y}) using () renaming (_≡_ to _≡B_)
        instance _ = category A
        instance _ = category B

  instance
    [∘ᶠᵘⁿᶜᵗᵒʳ]-identityᵣ : Morphism.Identityᵣ {Obj = CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} (\{A} → _∘ᶠᵘⁿᶜᵗᵒʳ_ {A = A})(idᶠᵘⁿᶜᵗᵒʳ)
    _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Morphism.Identityᵣ.proof ([∘ᶠᵘⁿᶜᵗᵒʳ]-identityᵣ) {y = B}) = reflexivity(_⊜_) where
      instance _ = [≡]-equiv {T = Object(B)}
    NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Morphism.Identityᵣ.proof [∘ᶠᵘⁿᶜᵗᵒʳ]-identityᵣ {A} {B} {[∃]-intro F})) {x} {y} {f} =
      id ∘ map f 🝖-[ Morphism.identityₗ(_∘_)(id) ]
      map f      🝖-[ Morphism.identityᵣ(_∘_)(id) ]-sym
      map f ∘ id 🝖-end
      where
        open module MorphismEquivB {x}{y} = Equiv(morphism-equiv B {x}{y}) using () renaming (_≡_ to _≡B_)
        instance _ = category A
        instance _ = category B

  instance
    [∘ᶠᵘⁿᶜᵗᵒʳ]-identity : Morphism.Identity {Obj = CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} (\{A} → _∘ᶠᵘⁿᶜᵗᵒʳ_ {A = A})(idᶠᵘⁿᶜᵗᵒʳ)
    [∘ᶠᵘⁿᶜᵗᵒʳ]-identity = [∧]-intro [∘ᶠᵘⁿᶜᵗᵒʳ]-identityₗ [∘ᶠᵘⁿᶜᵗᵒʳ]-identityᵣ

  instance
    [∘ᶠᵘⁿᶜᵗᵒʳ]-associativity : Morphism.Associativity {Obj = CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}} (\{A B C} → _∘ᶠᵘⁿᶜᵗᵒʳ_ {A = A}{B = B}{C = C})
    _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Morphism.Associativity.proof [∘ᶠᵘⁿᶜᵗᵒʳ]-associativity {w = D}) = reflexivity(_⊜_) where
      instance _ = [≡]-equiv {T = Object(D)}
    NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Morphism.Associativity.proof [∘ᶠᵘⁿᶜᵗᵒʳ]-associativity {A}{B}{C}{D} {[∃]-intro F}{[∃]-intro G}{[∃]-intro H})) {x}{y}{f} =
      id ∘ map(map(map f)) 🝖-[ Morphism.identityₗ(_∘_)(id) ]
      map(map(map f))      🝖-[ Morphism.identityᵣ(_∘_)(id) ]-sym
      map(map(map f)) ∘ id 🝖-end
      where
        open module MorphismEquivₗ {x}{y} = Equiv(morphism-equiv D {x}{y}) using () renaming (_≡_ to _≡D_)
        instance _ = category A
        instance _ = category B
        instance _ = category C
        instance _ = category D


open import SOAS.Common
import SOAS.Families.Core

-- Families with syntactic structure
module SOAS.Metatheory.MetaAlgebra {T : Set}
  (open SOAS.Families.Core {T})
  (⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ)
  (𝔛 : Familyₛ) where

open import SOAS.Context {T}
open import SOAS.Variable {T}
open import SOAS.Construction.Structure as Structure
open import SOAS.Abstract.Hom {T}
import SOAS.Abstract.Coalgebra {T} as →□ ; open →□.Sorted

open import SOAS.Metatheory.Algebra ⅀F

private
  variable
    Γ Δ Π : Ctx
    α : T

-- A family with support for variables, metavariables, and ⅀-algebra structure
record MetaAlg (𝒜 : Familyₛ) : Set where

  field
    𝑎𝑙𝑔  : ⅀ 𝒜 ⇾̣ 𝒜
    𝑣𝑎𝑟  :   ℐ ⇾̣ 𝒜
    𝑚𝑣𝑎𝑟 :   𝔛 ⇾̣ 〖 𝒜 , 𝒜 〗

  -- Congruence in metavariable arguments
  𝑚≈₁ : {𝔪₁ 𝔪₂ : 𝔛 α Π}{σ : Π ~[ 𝒜 ]↝ Γ}
      → 𝔪₁ ≡ 𝔪₂
      → 𝑚𝑣𝑎𝑟 𝔪₁ σ ≡ 𝑚𝑣𝑎𝑟 𝔪₂ σ
  𝑚≈₁ refl = refl

  𝑚≈₂ : {𝔪 : 𝔛 α Π}{σ ς : Π ~[ 𝒜 ]↝ Γ}
      → ({τ : T}(v : ℐ τ Π) → σ v ≡ ς v)
      → 𝑚𝑣𝑎𝑟 𝔪 σ ≡ 𝑚𝑣𝑎𝑟 𝔪 ς
  𝑚≈₂ {𝔪 = 𝔪} p = cong (𝑚𝑣𝑎𝑟 𝔪) (dext p)

-- Meta-algebra homomorphism
record MetaAlg⇒ {𝒜 ℬ : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜)(ℬᵃ : MetaAlg ℬ)
                (f : 𝒜 ⇾̣ ℬ) : Set where
  private module 𝒜 = MetaAlg 𝒜ᵃ
  private module ℬ = MetaAlg ℬᵃ

  field
    ⟨𝑎𝑙𝑔⟩  : {t : ⅀ 𝒜 α Γ} → f (𝒜.𝑎𝑙𝑔 t) ≡ ℬ.𝑎𝑙𝑔 (⅀₁ f t)
    ⟨𝑣𝑎𝑟⟩  : {v : ℐ α Γ} → f (𝒜.𝑣𝑎𝑟 v) ≡ ℬ.𝑣𝑎𝑟 v
    ⟨𝑚𝑣𝑎𝑟⟩ : {𝔪 : 𝔛 α Π}{ε : Π ~[ 𝒜 ]↝ Γ} → f (𝒜.𝑚𝑣𝑎𝑟 𝔪 ε) ≡ ℬ.𝑚𝑣𝑎𝑟 𝔪 (f ∘ ε)

-- Category of meta-algebras
module MetaAlgebraStructure = Structure 𝔽amiliesₛ MetaAlg

MetaAlgebraCatProps : MetaAlgebraStructure.CategoryProps
MetaAlgebraCatProps = record
  { IsHomomorphism = MetaAlg⇒
  ; id-hom = λ {𝒜}{𝒜ᵃ} → record
    { ⟨𝑎𝑙𝑔⟩ = cong (𝑎𝑙𝑔 𝒜ᵃ) (sym ⅀.identity)
    ; ⟨𝑣𝑎𝑟⟩ = refl
    ; ⟨𝑚𝑣𝑎𝑟⟩ = refl }
  ; comp-hom = λ{ {𝐶ˢ = 𝒜ᵃ}{ℬᵃ}{𝒞ᵃ} g f gᵃ⇒ fᵃ⇒ → record
    { ⟨𝑎𝑙𝑔⟩ = trans (cong g (⟨𝑎𝑙𝑔⟩ fᵃ⇒))
            (trans (⟨𝑎𝑙𝑔⟩  gᵃ⇒)
                    (cong (𝑎𝑙𝑔 𝒞ᵃ) (sym ⅀.homomorphism)))
    ; ⟨𝑣𝑎𝑟⟩ = trans (cong g (⟨𝑣𝑎𝑟⟩ fᵃ⇒)) (⟨𝑣𝑎𝑟⟩ gᵃ⇒)
    ; ⟨𝑚𝑣𝑎𝑟⟩ = trans (cong g (⟨𝑚𝑣𝑎𝑟⟩ fᵃ⇒)) (⟨𝑚𝑣𝑎𝑟⟩ gᵃ⇒) }
  }} where open MetaAlg ; open MetaAlg⇒

module MetaAlgProps = MetaAlgebraStructure.CategoryProps MetaAlgebraCatProps

𝕄etaAlgebras : Category 1ℓ 0ℓ 0ℓ
𝕄etaAlgebras = MetaAlgebraStructure.StructCat MetaAlgebraCatProps

module 𝕄etaAlg = Category 𝕄etaAlgebras

MetaAlgebra : Set₁
MetaAlgebra = 𝕄etaAlg.Obj

MetaAlgebra⇒ : MetaAlgebra → MetaAlgebra → Set
MetaAlgebra⇒ = 𝕄etaAlg._⇒_

-- Identity is a meta-algebra homomorphism
idᵃ : {𝒜 : Familyₛ} → (𝒜ᵃ : MetaAlg 𝒜) → MetaAlg⇒ 𝒜ᵃ 𝒜ᵃ id
idᵃ 𝒜ᵃ = record { ⟨𝑎𝑙𝑔⟩ = cong (MetaAlg.𝑎𝑙𝑔 𝒜ᵃ) (sym ⅀.identity)
                ; ⟨𝑣𝑎𝑟⟩ = refl ; ⟨𝑚𝑣𝑎𝑟⟩ = refl }


module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Reflection
open import Common.Equality

module _ (A : Set) where
  record R : Set where

  `R₀ : Type
  `R₀ = def (quote R) []

  `R₁ : Term → Type
  `R₁ a = def (quote R) (vArg a ∷ [])

  `Nat : Type
  `Nat = def (quote Nat) []

  _`→_ : Type → Type → Type
  a `→ b = pi (vArg a) (abs "x" b)

  helper-type₀ : Type
  helper-type₀ = `R₀ `→ `R₀

  helper-type₁ : Type
  helper-type₁ = `R₁ `Nat `→ `R₁ `Nat

  helper-term : Term
  helper-term = var 0 []

  helper-patterns : List (Arg Pattern)
  helper-patterns = vArg (var "_") ∷
                    []

  defineHelper : Type → TC ⊤
  defineHelper t =
    freshName "n" >>= λ n →
    declareDef (vArg n) t >>= λ _ →
    defineFun n (clause helper-patterns helper-term ∷ [])

  noFail : TC ⊤ → TC Bool
  noFail m = catchTC (bindTC m λ _ → returnTC true) (returnTC false)

  mac : Type → Tactic
  mac t hole =
    noFail (defineHelper t) >>= λ b →
    quoteTC b >>= unify hole

  macro
    mac₀ : Tactic
    mac₀ = mac helper-type₀

    mac₁ : Tactic
    mac₁ = mac helper-type₁

  within-module-succeeds₀ : mac₀ ≡ true
  within-module-succeeds₀ = refl

  within-module-fails₁ : mac₁ ≡ false
  within-module-fails₁ = refl

outside-module-fails₀ : mac₀ Nat ≡ false
outside-module-fails₀ = refl

outside-module-succeeds₁ : mac₁ Nat ≡ true
outside-module-succeeds₁ = refl


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

module IrrelevantData where

data T (A : Set) : Set where
  c : .A → T A

d : ∀ {A} → T A → A
d (c x) = x
-- needs to fail since x is irrelevant under c


{-# OPTIONS --safe --warning=error --without-K #-}

open import Groups.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Subgroups.Definition
open import Groups.Lemmas
open import Groups.Abelian.Definition
open import Groups.Subgroups.Normal.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Groups.Subgroups.Normal.Lemmas where

data GroupKernelElement {a} {b} {c} {d} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) : Set (a ⊔ b ⊔ c ⊔ d) where
  kerOfElt : (x : A) → (Setoid._∼_ T (f x) (Group.0G H)) → GroupKernelElement G hom

groupKernel : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → Setoid (GroupKernelElement G hom)
Setoid._∼_ (groupKernel {S = S} G {H} {f} fHom) (kerOfElt x fx=0) (kerOfElt y fy=0) = Setoid._∼_ S x y
Equivalence.reflexive (Setoid.eq (groupKernel {S = S} G {H} {f} fHom)) {kerOfElt x x₁} = Equivalence.reflexive (Setoid.eq S)
Equivalence.symmetric (Setoid.eq (groupKernel {S = S} G {H} {f} fHom)) {kerOfElt x prX} {kerOfElt y prY} = Equivalence.symmetric (Setoid.eq S)
Equivalence.transitive (Setoid.eq (groupKernel {S = S} G {H} {f} fHom)) {kerOfElt x prX} {kerOfElt y prY} {kerOfElt z prZ} = Equivalence.transitive (Setoid.eq S)

groupKernelGroupOp : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → (GroupKernelElement G hom) → (GroupKernelElement G hom) → (GroupKernelElement G hom)
groupKernelGroupOp {T = T} {_·A_ = _+A_} G {H = H} hom (kerOfElt x prX) (kerOfElt y prY) = kerOfElt (x +A y) (transitive (GroupHom.groupHom hom) (transitive (Group.+WellDefined H prX prY) (Group.identLeft H)))
  where
    open Setoid T
    open Equivalence eq

groupKernelGroup : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → Group (groupKernel G hom) (groupKernelGroupOp G hom)
Group.+WellDefined (groupKernelGroup G fHom) {kerOfElt x prX} {kerOfElt y prY} {kerOfElt a prA} {kerOfElt b prB} = Group.+WellDefined G
Group.0G (groupKernelGroup G fHom) = kerOfElt (Group.0G G) (imageOfIdentityIsIdentity fHom)
Group.inverse (groupKernelGroup {T = T} G {H = H} fHom) (kerOfElt x prX) = kerOfElt (Group.inverse G x) (transitive (homRespectsInverse fHom) (transitive (inverseWellDefined H prX) (invIdent H)))
  where
    open Setoid T
    open Equivalence eq
Group.+Associative (groupKernelGroup {S = S} {_·A_ = _·A_} G fHom) {kerOfElt x prX} {kerOfElt y prY} {kerOfElt z prZ} = Group.+Associative G
Group.identRight (groupKernelGroup G fHom) {kerOfElt x prX} = Group.identRight G
Group.identLeft (groupKernelGroup G fHom) {kerOfElt x prX} = Group.identLeft G
Group.invLeft (groupKernelGroup G fHom) {kerOfElt x prX} = Group.invLeft G
Group.invRight (groupKernelGroup G fHom) {kerOfElt x prX} = Group.invRight G

injectionFromKernelToG : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → GroupKernelElement G hom → A
injectionFromKernelToG G hom (kerOfElt x _) = x

injectionFromKernelToGIsHom : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → GroupHom (groupKernelGroup G hom) G (injectionFromKernelToG G hom)
GroupHom.groupHom (injectionFromKernelToGIsHom {S = S} G hom) {kerOfElt x prX} {kerOfElt y prY} = Equivalence.reflexive (Setoid.eq S)
GroupHom.wellDefined (injectionFromKernelToGIsHom G hom) {kerOfElt x prX} {kerOfElt y prY} i = i

groupKernelGroupPred : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → A → Set d
groupKernelGroupPred {T = T} G {H = H} {f = f} hom a = Setoid._∼_ T (f a) (Group.0G H)

groupKernelGroupPredWd : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → {x y : A} → (Setoid._∼_ S x y) → (groupKernelGroupPred G hom x → groupKernelGroupPred G hom y)
groupKernelGroupPredWd {S = S} {T = T} G hom {x} {y} x=y fx=0 = Equivalence.transitive (Setoid.eq T) (GroupHom.wellDefined hom (Equivalence.symmetric (Setoid.eq S) x=y)) fx=0

groupKernelGroupIsSubgroup : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → Subgroup G (groupKernelGroupPred G hom)
Subgroup.closedUnderPlus (groupKernelGroupIsSubgroup {S = S} {T = T} G {H = H} hom) g=0 h=0 = Equivalence.transitive (Setoid.eq T) (GroupHom.groupHom hom) (Equivalence.transitive (Setoid.eq T) (Group.+WellDefined H g=0 h=0) (Group.identLeft H))
Subgroup.containsIdentity (groupKernelGroupIsSubgroup G hom) = imageOfIdentityIsIdentity hom
Subgroup.closedUnderInverse (groupKernelGroupIsSubgroup {S = S} {T = T} G {H = H} hom) g=0 = Equivalence.transitive (Setoid.eq T) (homRespectsInverse hom) (Equivalence.transitive (Setoid.eq T) (inverseWellDefined H g=0) (invIdent H))
Subgroup.isSubset (groupKernelGroupIsSubgroup G hom) = groupKernelGroupPredWd G hom

groupKernelGroupIsNormalSubgroup : {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} {f : A → B} (hom : GroupHom G H f) → normalSubgroup G (groupKernelGroupIsSubgroup G hom)
groupKernelGroupIsNormalSubgroup {T = T} G {H = H} hom k=0 = transitive groupHom (transitive (+WellDefined reflexive groupHom) (transitive (+WellDefined reflexive (transitive (+WellDefined k=0 reflexive) identLeft)) (transitive (symmetric groupHom) (transitive (wellDefined (Group.invRight G)) (imageOfIdentityIsIdentity hom)))))
  where
    open Setoid T
    open Group H
    open Equivalence eq
    open GroupHom hom

abelianGroupSubgroupIsNormal : {a b c : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {G : Group S _+_} {pred : A → Set c} → (s : Subgroup G pred) → AbelianGroup G → normalSubgroup G s
abelianGroupSubgroupIsNormal {S = S} {_+_ = _+_} {G = G} record { isSubset = predWd ; closedUnderPlus = respectsPlus ; containsIdentity = respectsId ; closedUnderInverse = respectsInv } abelian {k} {l} prK = predWd (transitive (transitive (transitive (symmetric identLeft) (+WellDefined (symmetric invRight) reflexive)) (symmetric +Associative)) (+WellDefined reflexive commutative)) prK
  where
    open Group G
    open AbelianGroup abelian
    open Setoid S
    open Equivalence eq


------------------------------------------------------------------------
-- The Agda standard library
--
-- Substitution lemmas
------------------------------------------------------------------------

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

module Data.Fin.Substitution.Lemmas where

import Category.Applicative.Indexed as Applicative
open import Data.Fin.Substitution
open import Data.Nat hiding (_⊔_)
open import Data.Fin using (Fin; zero; suc; lift)
open import Data.Vec
import Data.Vec.Properties as VecProp
open import Function as Fun using (_∘_; _$_)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; sym; cong; cong₂)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (Star; ε; _◅_; _▻_)
open PropEq.≡-Reasoning
open import Level using (Level; _⊔_)
open import Relation.Unary using (Pred)

-- A lemma which does not refer to any substitutions.

lift-commutes : ∀ {n} k j (x : Fin (j + (k + n))) →
                lift j suc (lift j (lift k suc) x) ≡
                lift j (lift (suc k) suc) (lift j suc x)
lift-commutes k zero    x       = refl
lift-commutes k (suc j) zero    = refl
lift-commutes k (suc j) (suc x) = cong suc (lift-commutes k j x)

-- The modules below prove a number of substitution lemmas, on the
-- assumption that the underlying substitution machinery satisfies
-- certain properties.

record Lemmas₀ {ℓ : Level} (T : Pred ℕ ℓ) : Set ℓ where
  field simple : Simple T

  open Simple simple

  extensionality : ∀ {m n} {ρ₁ ρ₂ : Sub T m n} →
                   (∀ x → lookup ρ₁ x ≡ lookup ρ₂ x) → ρ₁ ≡ ρ₂
  extensionality {ρ₁ = []}      {[]}       hyp = refl
  extensionality {ρ₁ = t₁ ∷ ρ₁} { t₂ ∷ ρ₂} hyp with hyp zero
  extensionality {ρ₁ = t₁ ∷ ρ₁} {.t₁ ∷ ρ₂} hyp | refl =
    cong (_∷_ t₁) (extensionality (hyp ∘ suc))

  id-↑⋆ : ∀ {n} k → id ↑⋆ k ≡ id {k + n}
  id-↑⋆ zero    = refl
  id-↑⋆ (suc k) = begin
    (id ↑⋆ k) ↑ ≡⟨ cong _↑ (id-↑⋆ k) ⟩
    id        ↑ ∎

  lookup-map-weaken-↑⋆ : ∀ {m n} k x {ρ : Sub T m n} →
                         lookup (map weaken ρ ↑⋆ k) x ≡
                         lookup ((ρ ↑) ↑⋆ k) (lift k suc x)
  lookup-map-weaken-↑⋆ zero    x           = refl
  lookup-map-weaken-↑⋆ (suc k) zero        = refl
  lookup-map-weaken-↑⋆ (suc k) (suc x) {ρ} = begin
    lookup (map weaken (map weaken ρ ↑⋆ k)) x        ≡⟨ VecProp.lookup-map x weaken (map weaken ρ ↑⋆ k) ⟩
    weaken (lookup (map weaken ρ ↑⋆ k) x)            ≡⟨ cong weaken (lookup-map-weaken-↑⋆ k x) ⟩
    weaken (lookup ((ρ ↑) ↑⋆ k) (lift k suc x))      ≡⟨ sym $ VecProp.lookup-map (lift k suc x) weaken ((ρ ↑) ↑⋆ k) ⟩
    lookup (map weaken ((ρ ↑) ↑⋆ k)) (lift k suc x)  ∎

record Lemmas₁ {ℓ} (T : Pred ℕ ℓ) : Set ℓ where
  field lemmas₀ : Lemmas₀ T

  open Lemmas₀ lemmas₀
  open Simple simple

  field weaken-var : ∀ {n} {x : Fin n} → weaken (var x) ≡ var (suc x)

  lookup-map-weaken : ∀ {m n} x {y} {ρ : Sub T m n} →
                      lookup             ρ  x ≡ var      y →
                      lookup (map weaken ρ) x ≡ var (suc y)
  lookup-map-weaken x {y} {ρ} hyp = begin
    lookup (map weaken ρ) x  ≡⟨ VecProp.lookup-map x weaken ρ ⟩
    weaken (lookup ρ x)      ≡⟨ cong weaken hyp ⟩
    weaken (var y)           ≡⟨ weaken-var ⟩
    var (suc y)              ∎

  mutual

    lookup-id : ∀ {n} (x : Fin n) → lookup id x ≡ var x
    lookup-id zero    = refl
    lookup-id (suc x) = lookup-wk x

    lookup-wk : ∀ {n} (x : Fin n) → lookup wk x ≡ var (suc x)
    lookup-wk x = lookup-map-weaken x {ρ = id} (lookup-id x)

  lookup-↑⋆ : ∀ {m n} (f : Fin m → Fin n) {ρ : Sub T m n} →
              (∀ x → lookup ρ x ≡ var (f x)) →
              ∀ k x → lookup (ρ ↑⋆ k) x ≡ var (lift k f x)
  lookup-↑⋆ f         hyp zero    x       = hyp x
  lookup-↑⋆ f         hyp (suc k) zero    = refl
  lookup-↑⋆ f {ρ = ρ} hyp (suc k) (suc x) =
    lookup-map-weaken x {ρ = ρ ↑⋆ k} (lookup-↑⋆ f hyp k x)

  lookup-lift-↑⋆ : ∀ {m n} (f : Fin n → Fin m) {ρ : Sub T m n} →
                   (∀ x → lookup ρ (f x) ≡ var x) →
                   ∀ k x → lookup (ρ ↑⋆ k) (lift k f x) ≡ var x
  lookup-lift-↑⋆ f         hyp zero    x       = hyp x
  lookup-lift-↑⋆ f         hyp (suc k) zero    = refl
  lookup-lift-↑⋆ f {ρ = ρ} hyp (suc k) (suc x) =
    lookup-map-weaken (lift k f x) {ρ = ρ ↑⋆ k} (lookup-lift-↑⋆ f hyp k x)

  lookup-wk-↑⋆ : ∀ {n} k (x : Fin (k + n)) →
                 lookup (wk ↑⋆ k) x ≡ var (lift k suc x)
  lookup-wk-↑⋆ = lookup-↑⋆ suc lookup-wk

  lookup-wk-↑⋆-↑⋆ : ∀ {n} k j (x : Fin (j + (k + n))) →
                    lookup (wk ↑⋆ k ↑⋆ j) x ≡
                    var (lift j (lift k suc) x)
  lookup-wk-↑⋆-↑⋆ k = lookup-↑⋆ (lift k suc) (lookup-wk-↑⋆ k)

  lookup-sub-↑⋆ : ∀ {n t} k (x : Fin (k + n)) →
                  lookup (sub t ↑⋆ k) (lift k suc x) ≡ var x
  lookup-sub-↑⋆ = lookup-lift-↑⋆ suc lookup-id

  open Lemmas₀ lemmas₀ public

record Lemmas₂ {ℓ} (T : Pred ℕ ℓ) : Set ℓ where
  field
    lemmas₁     : Lemmas₁ T
    application : Application T T

  open Lemmas₁ lemmas₁

  subst : Subst T
  subst = record { simple = simple; application = application }

  open Subst subst

  field var-/ : ∀ {m n x} {ρ : Sub T m n} → var x / ρ ≡ lookup ρ x

  suc-/-sub : ∀ {n x} {t : T n} → var (suc x) / sub t ≡ var x
  suc-/-sub {x = x} {t} = begin
    var (suc x) / sub t     ≡⟨ var-/ ⟩
    lookup (sub t) (suc x)  ≡⟨ refl ⟩
    lookup id x             ≡⟨ lookup-id x ⟩
    var x                   ∎

  lookup-⊙ : ∀ {m n k} x {ρ₁ : Sub T m n} {ρ₂ : Sub T n k} →
             lookup (ρ₁ ⊙ ρ₂) x ≡ lookup ρ₁ x / ρ₂
  lookup-⊙ x {ρ₁} {ρ₂} = VecProp.lookup-map x (λ t → t / ρ₂) ρ₁

  lookup-⨀ : ∀ {m n} x (ρs : Subs T m n) →
             lookup (⨀ ρs) x ≡ var x /✶ ρs
  lookup-⨀ x ε                = lookup-id x
  lookup-⨀ x (ρ ◅ ε)          = sym var-/
  lookup-⨀ x (ρ ◅ (ρ′ ◅ ρs′)) = begin
    lookup (⨀ (ρ ◅ ρs)) x  ≡⟨ refl ⟩
    lookup (⨀ ρs ⊙ ρ) x    ≡⟨ lookup-⊙ x {ρ₁ = ⨀ (ρ′ ◅ ρs′)} ⟩
    lookup (⨀ ρs) x / ρ    ≡⟨ cong₂ _/_ (lookup-⨀ x (ρ′ ◅ ρs′)) refl ⟩
    var x /✶ ρs / ρ        ∎
    where ρs = ρ′ ◅ ρs′

  id-⊙ : ∀ {m n} {ρ : Sub T m n} → id ⊙ ρ ≡ ρ
  id-⊙ {ρ = ρ} = extensionality λ x → begin
    lookup (id ⊙ ρ) x  ≡⟨ lookup-⊙ x {ρ₁ = id} ⟩
    lookup  id x / ρ   ≡⟨ cong₂ _/_ (lookup-id x) refl ⟩
    var x        / ρ   ≡⟨ var-/ ⟩
    lookup ρ x         ∎

  lookup-wk-↑⋆-⊙ : ∀ {m n} k {x} {ρ : Sub T (k + suc m) n} →
                   lookup (wk ↑⋆ k ⊙ ρ) x ≡ lookup ρ (lift k suc x)
  lookup-wk-↑⋆-⊙ k {x} {ρ} = begin
    lookup (wk ↑⋆ k ⊙ ρ) x   ≡⟨ lookup-⊙ x {ρ₁ = wk ↑⋆ k} ⟩
    lookup (wk ↑⋆ k) x / ρ   ≡⟨ cong₂ _/_ (lookup-wk-↑⋆ k x) refl ⟩
    var (lift k suc x) / ρ   ≡⟨ var-/ ⟩
    lookup ρ (lift k suc x)  ∎

  wk-⊙-sub′ : ∀ {n} {t : T n} k → wk ↑⋆ k ⊙ sub t ↑⋆ k ≡ id
  wk-⊙-sub′ {t = t} k = extensionality λ x → begin
    lookup (wk ↑⋆ k ⊙ sub t ↑⋆ k) x     ≡⟨ lookup-wk-↑⋆-⊙ k ⟩
    lookup (sub t ↑⋆ k) (lift k suc x)  ≡⟨ lookup-sub-↑⋆ k x ⟩
    var x                               ≡⟨ sym (lookup-id x) ⟩
    lookup id x                         ∎

  wk-⊙-sub : ∀ {n} {t : T n} → wk ⊙ sub t ≡ id
  wk-⊙-sub = wk-⊙-sub′ zero

  var-/-wk-↑⋆ : ∀ {n} k (x : Fin (k + n)) →
                var x / wk ↑⋆ k ≡ var (lift k suc x)
  var-/-wk-↑⋆ k x = begin
    var x / wk ↑⋆ k     ≡⟨ var-/ ⟩
    lookup (wk ↑⋆ k) x  ≡⟨ lookup-wk-↑⋆ k x ⟩
    var (lift k suc x)  ∎

  wk-↑⋆-⊙-wk : ∀ {n} k j →
               wk {n} ↑⋆ k ↑⋆ j ⊙ wk ↑⋆ j ≡
               wk ↑⋆ j ⊙ wk ↑⋆ suc k ↑⋆ j
  wk-↑⋆-⊙-wk k j = extensionality λ x → begin
    lookup (wk ↑⋆ k ↑⋆ j ⊙ wk ↑⋆ j) x               ≡⟨ lookup-⊙ x {ρ₁ = wk ↑⋆ k ↑⋆ j} ⟩
    lookup (wk ↑⋆ k ↑⋆ j) x / wk ↑⋆ j               ≡⟨ cong₂ _/_ (lookup-wk-↑⋆-↑⋆ k j x) refl ⟩
    var (lift j (lift k suc) x) / wk ↑⋆ j           ≡⟨ var-/-wk-↑⋆ j (lift j (lift k suc) x) ⟩
    var (lift j suc (lift j (lift k suc) x))        ≡⟨ cong var (lift-commutes k j x) ⟩
    var (lift j (lift (suc k) suc) (lift j suc x))  ≡⟨ sym (lookup-wk-↑⋆-↑⋆ (suc k) j (lift j suc x)) ⟩
    lookup (wk ↑⋆ suc k ↑⋆ j) (lift j suc x)        ≡⟨ sym var-/ ⟩
    var (lift j suc x) / wk ↑⋆ suc k ↑⋆ j           ≡⟨ cong₂ _/_ (sym (lookup-wk-↑⋆ j x)) refl ⟩
    lookup (wk ↑⋆ j) x / wk ↑⋆ suc k ↑⋆ j           ≡⟨ sym (lookup-⊙ x {ρ₁ = wk ↑⋆ j}) ⟩
    lookup (wk ↑⋆ j ⊙ wk ↑⋆ suc k ↑⋆ j) x           ∎

  open Subst   subst   public hiding (simple; application)
  open Lemmas₁ lemmas₁ public

record Lemmas₃ {ℓ} (T : Pred ℕ ℓ) : Set ℓ where
  field lemmas₂ : Lemmas₂ T

  open Lemmas₂ lemmas₂

  field
    /✶-↑✶ : ∀ {m n} (ρs₁ ρs₂ : Subs T m n) →
            (∀ k x → var x /✶ ρs₁ ↑✶ k ≡ var x /✶ ρs₂ ↑✶ k) →
            ∀ k t → t /✶ ρs₁ ↑✶ k ≡ t /✶ ρs₂ ↑✶ k

  /✶-↑✶′ : ∀ {m n} (ρs₁ ρs₂ : Subs T m n) →
           (∀ k → ⨀ (ρs₁ ↑✶ k) ≡ ⨀ (ρs₂ ↑✶ k)) →
           ∀ k t → t /✶ ρs₁ ↑✶ k ≡ t /✶ ρs₂ ↑✶ k
  /✶-↑✶′ ρs₁ ρs₂ hyp = /✶-↑✶ ρs₁ ρs₂ (λ k x → begin
    var x /✶ ρs₁ ↑✶ k        ≡⟨ sym (lookup-⨀ x (ρs₁ ↑✶ k)) ⟩
    lookup (⨀ (ρs₁ ↑✶ k)) x  ≡⟨ cong (Fun.flip lookup x) (hyp k) ⟩
    lookup (⨀ (ρs₂ ↑✶ k)) x  ≡⟨ lookup-⨀ x (ρs₂ ↑✶ k) ⟩
    var x /✶ ρs₂ ↑✶ k        ∎)

  id-vanishes : ∀ {n} (t : T n) → t / id ≡ t
  id-vanishes = /✶-↑✶′ (ε ▻ id) ε id-↑⋆ zero

  ⊙-id : ∀ {m n} {ρ : Sub T m n} → ρ ⊙ id ≡ ρ
  ⊙-id {ρ = ρ} = begin
    map (λ t → t / id) ρ  ≡⟨ VecProp.map-cong id-vanishes ρ ⟩
    map Fun.id         ρ  ≡⟨ VecProp.map-id ρ ⟩
    ρ                     ∎

  open Lemmas₂ lemmas₂ public hiding (wk-⊙-sub′)

record Lemmas₄ {ℓ} (T : Pred ℕ ℓ) : Set ℓ where
  field lemmas₃ : Lemmas₃ T

  open Lemmas₃ lemmas₃

  field /-wk : ∀ {n} {t : T n} → t / wk ≡ weaken t

  private

    ↑-distrib′ : ∀ {m n k} {ρ₁ : Sub T m n} {ρ₂ : Sub T n k} →
                 (∀ t → t / ρ₂ / wk ≡ t / wk / ρ₂ ↑) →
                 (ρ₁ ⊙ ρ₂) ↑ ≡ ρ₁ ↑ ⊙ ρ₂ ↑
    ↑-distrib′ {ρ₁ = ρ₁} {ρ₂} hyp = begin
      (ρ₁ ⊙ ρ₂) ↑                             ≡⟨ refl ⟩
      var zero        ∷ map weaken (ρ₁ ⊙ ρ₂)  ≡⟨ cong₂ _∷_ (sym var-/) lemma ⟩
      var zero / ρ₂ ↑ ∷ map weaken ρ₁ ⊙ ρ₂ ↑  ≡⟨ refl ⟩
      ρ₁ ↑ ⊙ ρ₂ ↑                             ∎
      where
      lemma = begin
        map weaken (map (λ t → t / ρ₂) ρ₁)    ≡⟨ sym (VecProp.map-∘ _ _ _) ⟩
        map (λ t → weaken (t / ρ₂)) ρ₁        ≡⟨ VecProp.map-cong (λ t → begin
                                                   weaken (t / ρ₂)  ≡⟨ sym /-wk ⟩
                                                   t / ρ₂ / wk      ≡⟨ hyp t ⟩
                                                   t / wk / ρ₂ ↑    ≡⟨ cong₂ _/_ /-wk refl ⟩
                                                   weaken t / ρ₂ ↑  ∎) ρ₁ ⟩
        map (λ t → weaken t / ρ₂ ↑) ρ₁        ≡⟨ VecProp.map-∘ _ _ _ ⟩
        map (λ t → t / ρ₂ ↑) (map weaken ρ₁)  ∎

    ↑⋆-distrib′ : ∀ {m n o} {ρ₁ : Sub T m n} {ρ₂ : Sub T n o} →
                  (∀ k t → t / ρ₂ ↑⋆ k / wk ≡ t / wk / ρ₂ ↑⋆ suc k) →
                  ∀ k → (ρ₁ ⊙ ρ₂) ↑⋆ k ≡ ρ₁ ↑⋆ k ⊙ ρ₂ ↑⋆ k
    ↑⋆-distrib′                hyp zero    = refl
    ↑⋆-distrib′ {ρ₁ = ρ₁} {ρ₂} hyp (suc k) = begin
      (ρ₁ ⊙ ρ₂) ↑⋆ suc k         ≡⟨ cong _↑ (↑⋆-distrib′ hyp k) ⟩
      (ρ₁ ↑⋆ k ⊙ ρ₂ ↑⋆ k) ↑      ≡⟨ ↑-distrib′ (hyp k) ⟩
      ρ₁ ↑⋆ suc k ⊙ ρ₂ ↑⋆ suc k  ∎

  map-weaken : ∀ {m n} {ρ : Sub T m n} → map weaken ρ ≡ ρ ⊙ wk
  map-weaken {ρ = ρ} = begin
    map weaken ρ          ≡⟨ VecProp.map-cong (λ _ → sym /-wk) ρ ⟩
    map (λ t → t / wk) ρ  ≡⟨ refl ⟩
    ρ ⊙ wk                ∎

  private

    ⊙-wk′ : ∀ {m n} {ρ : Sub T m n} k →
            ρ ↑⋆ k ⊙ wk ↑⋆ k ≡ wk ↑⋆ k ⊙ ρ ↑ ↑⋆ k
    ⊙-wk′ {ρ = ρ} k = sym (begin
      wk ↑⋆ k ⊙ ρ ↑ ↑⋆ k  ≡⟨ lemma ⟩
      map weaken ρ ↑⋆ k   ≡⟨ cong (λ ρ′ → ρ′ ↑⋆ k) map-weaken ⟩
      (ρ ⊙ wk) ↑⋆ k       ≡⟨ ↑⋆-distrib′ (λ k t →
                               /✶-↑✶′ (ε ▻ wk ↑⋆ k ▻ wk) (ε ▻ wk ▻ wk ↑⋆ suc k)
                                      (wk-↑⋆-⊙-wk k) zero t) k ⟩
      ρ ↑⋆ k ⊙ wk ↑⋆ k    ∎)
      where
      lemma = extensionality λ x → begin
        lookup (wk ↑⋆ k ⊙ ρ ↑ ↑⋆ k) x     ≡⟨ lookup-wk-↑⋆-⊙ k ⟩
        lookup (ρ ↑ ↑⋆ k) (lift k suc x)  ≡⟨ sym (lookup-map-weaken-↑⋆ k x) ⟩
        lookup (map weaken ρ ↑⋆ k) x      ∎

  ⊙-wk : ∀ {m n} {ρ : Sub T m n} → ρ ⊙ wk ≡ wk ⊙ ρ ↑
  ⊙-wk = ⊙-wk′ zero

  wk-commutes : ∀ {m n} {ρ : Sub T m n} t →
                t / ρ / wk ≡ t / wk / ρ ↑
  wk-commutes {ρ = ρ} = /✶-↑✶′ (ε ▻ ρ ▻ wk) (ε ▻ wk ▻ ρ ↑) ⊙-wk′ zero

  ↑⋆-distrib : ∀ {m n o} {ρ₁ : Sub T m n} {ρ₂ : Sub T n o} →
               ∀ k → (ρ₁ ⊙ ρ₂) ↑⋆ k ≡ ρ₁ ↑⋆ k ⊙ ρ₂ ↑⋆ k
  ↑⋆-distrib = ↑⋆-distrib′ (λ _ → wk-commutes)

  /-⊙ : ∀ {m n k} {ρ₁ : Sub T m n} {ρ₂ : Sub T n k} t →
        t / ρ₁ ⊙ ρ₂ ≡ t / ρ₁ / ρ₂
  /-⊙ {ρ₁ = ρ₁} {ρ₂} t =
    /✶-↑✶′ (ε ▻ ρ₁ ⊙ ρ₂) (ε ▻ ρ₁ ▻ ρ₂) ↑⋆-distrib zero t

  ⊙-assoc : ∀ {m n k o}
              {ρ₁ : Sub T m n} {ρ₂ : Sub T n k} {ρ₃ : Sub T k o} →
            ρ₁ ⊙ (ρ₂ ⊙ ρ₃) ≡ (ρ₁ ⊙ ρ₂) ⊙ ρ₃
  ⊙-assoc {ρ₁ = ρ₁} {ρ₂} {ρ₃} = begin
    map (λ t → t / ρ₂ ⊙ ρ₃) ρ₁                  ≡⟨ VecProp.map-cong /-⊙ ρ₁ ⟩
    map (λ t → t / ρ₂ / ρ₃) ρ₁                  ≡⟨ VecProp.map-∘ _ _ _ ⟩
    map (λ t → t / ρ₃) (map (λ t → t / ρ₂) ρ₁)  ∎

  map-weaken-⊙-sub : ∀ {m n} {ρ : Sub T m n} {t} → map weaken ρ ⊙ sub t ≡ ρ
  map-weaken-⊙-sub {ρ = ρ} {t} = begin
    map weaken ρ ⊙ sub t  ≡⟨ cong₂ _⊙_ map-weaken refl ⟩
    ρ ⊙ wk ⊙ sub t        ≡⟨ sym ⊙-assoc ⟩
    ρ ⊙ (wk ⊙ sub t)      ≡⟨ cong (_⊙_ ρ) wk-⊙-sub ⟩
    ρ ⊙ id                ≡⟨ ⊙-id ⟩
    ρ                     ∎

  sub-⊙ : ∀ {m n} {ρ : Sub T m n} t → sub t ⊙ ρ ≡ ρ ↑ ⊙ sub (t / ρ)
  sub-⊙ {ρ = ρ} t = begin
    sub t ⊙ ρ                           ≡⟨ refl ⟩
    t / ρ ∷ id ⊙ ρ                      ≡⟨ cong (_∷_ (t / ρ)) id-⊙ ⟩
    t / ρ ∷ ρ                           ≡⟨ cong (_∷_ (t / ρ)) (sym map-weaken-⊙-sub) ⟩
    t / ρ ∷ map weaken ρ ⊙ sub (t / ρ)  ≡⟨ cong₂ _∷_ (sym var-/) refl ⟩
    ρ ↑ ⊙ sub (t / ρ)                   ∎

  suc-/-↑ : ∀ {m n} {ρ : Sub T m n} x →
            var (suc x) / ρ ↑ ≡ var x / ρ / wk
  suc-/-↑ {ρ = ρ} x = begin
    var (suc x) / ρ ↑        ≡⟨ var-/ ⟩
    lookup (map weaken ρ) x  ≡⟨ cong (Fun.flip lookup x) (map-weaken {ρ = ρ}) ⟩
    lookup (ρ ⊙ wk)       x  ≡⟨ lookup-⊙ x {ρ₁ = ρ} ⟩
    lookup ρ x / wk          ≡⟨ cong₂ _/_ (sym var-/) refl ⟩
    var x / ρ / wk           ∎

  open Lemmas₃ lemmas₃ public
    hiding (/✶-↑✶; /✶-↑✶′; wk-↑⋆-⊙-wk;
            lookup-wk-↑⋆-⊙; lookup-map-weaken-↑⋆)

-- For an example of how AppLemmas can be used, see
-- Data.Fin.Substitution.List.

record AppLemmas {ℓ₁ ℓ₂} (T₁ : Pred ℕ ℓ₁) (T₂ : Pred ℕ ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
  field
    application : Application T₁ T₂
    lemmas₄     : Lemmas₄ T₂

  open Application application using (_/_; _/✶_)
  open Lemmas₄ lemmas₄
    using (id; _⊙_; wk; weaken; sub; _↑; ⨀) renaming (_/_ to _⊘_)

  field
    id-vanishes : ∀ {n} (t : T₁ n) → t / id ≡ t
    /-⊙         : ∀ {m n k} {ρ₁ : Sub T₂ m n} {ρ₂ : Sub T₂ n k} t →
                  t / ρ₁ ⊙ ρ₂ ≡ t / ρ₁ / ρ₂

  private module L₄ = Lemmas₄ lemmas₄

  /-⨀ : ∀ {m n} t (ρs : Subs T₂ m n) → t / ⨀ ρs ≡ t /✶ ρs
  /-⨀ t ε                = id-vanishes t
  /-⨀ t (ρ ◅ ε)          = refl
  /-⨀ t (ρ ◅ (ρ′ ◅ ρs′)) = begin
    t / ⨀ ρs ⊙ ρ  ≡⟨ /-⊙ t ⟩
    t / ⨀ ρs / ρ  ≡⟨ cong₂ _/_ (/-⨀ t (ρ′ ◅ ρs′)) refl ⟩
    t /✶ ρs / ρ   ∎
    where ρs = ρ′ ◅ ρs′

  ⨀→/✶ : ∀ {m n} (ρs₁ ρs₂ : Subs T₂ m n) →
         ⨀ ρs₁ ≡ ⨀ ρs₂ → ∀ t → t /✶ ρs₁ ≡ t /✶ ρs₂
  ⨀→/✶ ρs₁ ρs₂ hyp t = begin
    t /✶ ρs₁   ≡⟨ sym (/-⨀ t ρs₁) ⟩
    t / ⨀ ρs₁  ≡⟨ cong (_/_ t) hyp ⟩
    t / ⨀ ρs₂  ≡⟨ /-⨀ t ρs₂ ⟩
    t /✶ ρs₂   ∎

  wk-commutes : ∀ {m n} {ρ : Sub T₂ m n} t →
                t / ρ / wk ≡ t / wk / ρ ↑
  wk-commutes {ρ = ρ} = ⨀→/✶ (ε ▻ ρ ▻ wk) (ε ▻ wk ▻ ρ ↑) L₄.⊙-wk

  sub-commutes : ∀ {m n} {t′} {ρ : Sub T₂ m n} t →
                 t / sub t′ / ρ ≡ t / ρ ↑ / sub (t′ ⊘ ρ)
  sub-commutes {t′ = t′} {ρ} =
    ⨀→/✶ (ε ▻ sub t′ ▻ ρ) (ε ▻ ρ ↑ ▻ sub (t′ ⊘ ρ)) (L₄.sub-⊙ t′)

  wk-sub-vanishes : ∀ {n t′} (t : T₁ n) → t / wk / sub t′ ≡ t
  wk-sub-vanishes {t′ = t′} = ⨀→/✶ (ε ▻ wk ▻ sub t′) ε L₄.wk-⊙-sub

  /-weaken : ∀ {m n} {ρ : Sub T₂ m n} t → t / map weaken ρ ≡ t / ρ / wk
  /-weaken {ρ = ρ} = ⨀→/✶ (ε ▻ map weaken ρ) (ε ▻ ρ ▻ wk) L₄.map-weaken

  open Application application public
  open L₄ public
    hiding (application; _⊙_; _/_; _/✶_;
            id-vanishes; /-⊙; wk-commutes)

record Lemmas₅ {ℓ} (T : Pred ℕ ℓ) : Set ℓ where
  field lemmas₄ : Lemmas₄ T

  private module L₄ = Lemmas₄ lemmas₄

  appLemmas : AppLemmas T T
  appLemmas = record
    { application = L₄.application
    ; lemmas₄     = lemmas₄
    ; id-vanishes = L₄.id-vanishes
    ; /-⊙         = L₄./-⊙
    }

  open AppLemmas appLemmas public hiding (lemmas₄)

------------------------------------------------------------------------
-- Instantiations and code for facilitating instantiations

-- Lemmas about variable substitutions (renamings).

module VarLemmas where

  open VarSubst

  lemmas₃ : Lemmas₃ Fin
  lemmas₃ = record
    { lemmas₂ = record
      { lemmas₁ = record
        { lemmas₀ = record
          { simple = simple
          }
        ; weaken-var = refl
        }
      ; application = application
      ; var-/       = refl
      }
    ; /✶-↑✶ = λ _ _ hyp → hyp
    }

  private module L₃ = Lemmas₃ lemmas₃

  lemmas₅ : Lemmas₅ Fin
  lemmas₅ = record
    { lemmas₄ = record
      { lemmas₃ = lemmas₃
      ; /-wk    = L₃.lookup-wk _
      }
    }

  open Lemmas₅ lemmas₅ public hiding (lemmas₃)

-- Lemmas about "term" substitutions.

record TermLemmas (T : ℕ → Set) : Set₁ where
  field
    termSubst : TermSubst T

  open TermSubst termSubst

  field
    app-var : ∀ {T′} {lift : Lift T′ T} {m n x} {ρ : Sub T′ m n} →
              app lift (var x) ρ ≡ Lift.lift lift (lookup ρ x)
    /✶-↑✶   : ∀ {T₁ T₂} {lift₁ : Lift T₁ T} {lift₂ : Lift T₂ T} →
              let open Lifted lift₁
                    using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
                  open Lifted lift₂
                    using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)
              in
              ∀ {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

  private module V = VarLemmas

  lemmas₃ : Lemmas₃ T
  lemmas₃ = record
    { lemmas₂ = record
      { lemmas₁ = record
        { lemmas₀ = record
          { simple = simple
          }
        ; weaken-var = λ {_ x} → begin
            var x /Var V.wk      ≡⟨ app-var ⟩
            var (lookup V.wk x)  ≡⟨ cong var (V.lookup-wk x) ⟩
            var (suc x)          ∎
        }
      ; application = Subst.application subst
      ; var-/       = app-var
      }
    ; /✶-↑✶ = /✶-↑✶
    }

  private module L₃ = Lemmas₃ lemmas₃

  lemmas₅ : Lemmas₅ T
  lemmas₅ = record
    { lemmas₄ = record
      { lemmas₃ = lemmas₃
      ; /-wk    = λ {_ t} → begin
          t / wk       ≡⟨ /✶-↑✶ (ε ▻ wk) (ε ▻ V.wk)
                            (λ k x → begin
                               var x / wk ↑⋆ k                 ≡⟨ L₃.var-/-wk-↑⋆ k x ⟩
                               var (lift k suc x)              ≡⟨ cong var (sym (V.var-/-wk-↑⋆ k x)) ⟩
                               var (lookup (V._↑⋆_ V.wk k) x)  ≡⟨ sym app-var ⟩
                               var x /Var V._↑⋆_ V.wk k        ∎)
                            zero t ⟩
          t /Var V.wk  ≡⟨⟩
          weaken t     ∎
      }
    }

  open Lemmas₅ lemmas₅ public hiding (lemmas₃)


{-

This file contains:
- The quotient of finite sets by decidable equivalence relation is still finite, by using equivalence class.

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

module Cubical.Data.FinSet.Quotients where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Univalence

open import Cubical.HITs.PropositionalTruncation as Prop
open import Cubical.HITs.SetQuotients as SetQuot
open import Cubical.HITs.SetQuotients.EqClass

open import Cubical.Data.Nat
open import Cubical.Data.Bool
open import Cubical.Data.Sigma

open import Cubical.Data.SumFin
open import Cubical.Data.FinSet.Base
open import Cubical.Data.FinSet.Properties
open import Cubical.Data.FinSet.DecidablePredicate
open import Cubical.Data.FinSet.Constructors
open import Cubical.Data.FinSet.Cardinality

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidablePropositions
open import Cubical.Relation.Binary

private
  variable
    ℓ ℓ' ℓ'' : Level

LiftDecProp : {ℓ ℓ' : Level}{P : Type ℓ} → (p : isDecProp P) → P ≃ Bool→Type* {ℓ'} (p .fst)
LiftDecProp p = p .snd ⋆ BoolProp≃BoolProp*

open Iso

module _
  (X : Type ℓ) where

  ℙEff : Type ℓ
  ℙEff = X → Bool

  isSetℙEff : isSet ℙEff
  isSetℙEff = isSetΠ (λ _ → isSetBool)

  ℙEff→ℙDec : ℙEff → ℙDec {ℓ' = ℓ'} X
  ℙEff→ℙDec f .fst x = Bool→Type* (f x) , isPropBool→Type*
  ℙEff→ℙDec f .snd x = DecBool→Type*

  Iso-ℙEff-ℙDec : Iso ℙEff (ℙDec {ℓ' = ℓ'} X)
  Iso-ℙEff-ℙDec .fun = ℙEff→ℙDec
  Iso-ℙEff-ℙDec .inv (P , dec) x = Dec→Bool (dec x)
  Iso-ℙEff-ℙDec {ℓ' = ℓ'} .leftInv f i x = Bool≡BoolDec* {ℓ = ℓ'} {a = f x} (~ i)
  Iso-ℙEff-ℙDec .rightInv (P , dec) i .fst x .fst = ua (Dec≃DecBool* (P x .snd) (dec x)) (~ i)
  Iso-ℙEff-ℙDec .rightInv (P , dec) i .fst x .snd =
    isProp→PathP {B = λ i → isProp (Iso-ℙEff-ℙDec .rightInv (P , dec) i .fst x .fst)}
      (λ i → isPropIsProp)
      (Iso-ℙEff-ℙDec .fun (Iso-ℙEff-ℙDec .inv (P , dec)) .fst x .snd) (P x .snd) i
  Iso-ℙEff-ℙDec .rightInv (P , dec) i .snd x =
    isProp→PathP {B = λ i → Dec (Iso-ℙEff-ℙDec .rightInv (P , dec) i .fst x .fst)}
      (λ i → isPropDec (Iso-ℙEff-ℙDec .rightInv (P , dec) i .fst x .snd))
      (Iso-ℙEff-ℙDec .fun (Iso-ℙEff-ℙDec .inv (P , dec)) .snd x) (dec x) i

  ℙEff≃ℙDec : ℙEff ≃ (ℙDec {ℓ' = ℓ'} X)
  ℙEff≃ℙDec = isoToEquiv Iso-ℙEff-ℙDec

module _
  (X : Type ℓ)(p : isFinOrd X) where

  private
    e = p .snd

  isFinOrdℙEff : isFinOrd (ℙEff X)
  isFinOrdℙEff = _ , preCompEquiv (invEquiv e) ⋆ SumFinℙ≃ _

module _
  (X : FinSet ℓ) where

  isFinSetℙEff : isFinSet (ℙEff (X .fst))
  isFinSetℙEff = 2 ^ (card X) ,
    Prop.elim (λ _ → isPropPropTrunc {A = _ ≃ Fin _})
      (λ p → ∣ isFinOrdℙEff (X .fst) (_ , p) .snd ∣)
      (X .snd .snd)

module _
  (X : FinSet ℓ)
  (R : X .fst → X .fst → Type ℓ')
  (dec : (x x' : X .fst) → isDecProp (R x x')) where

  isEqClassEff : ℙEff (X .fst) → Type ℓ
  isEqClassEff f = ∥ Σ[ x ∈ X .fst ] ((a : X .fst) → f a ≡ dec a x .fst) ∥

  isDecPropIsEqClassEff : {f : ℙEff (X .fst)} → isDecProp (isEqClassEff f)
  isDecPropIsEqClassEff = isDecProp∃ X (λ _ → _ , isDecProp∀ X (λ _ → _ , _ , Bool≡≃ _ _))

  isEqClassEff→isEqClass' : (f : ℙEff (X .fst))(x : X .fst)
    → ((a : X .fst) → f a ≡ dec a x .fst)
    → (a : X .fst) → Bool→Type* {ℓ = ℓ'} (f a) ≃ ∥ R a x ∥
  isEqClassEff→isEqClass' f x h a =
      pathToEquiv (cong Bool→Type* (h a))
    ⋆ invEquiv (LiftDecProp (dec a x))
    ⋆ invEquiv (propTruncIdempotent≃ (isDecProp→isProp (dec a x)))

  isEqClass→isEqClassEff' : (f : ℙEff (X .fst))(x : X .fst)
    → ((a : X .fst) → Bool→Type* {ℓ = ℓ'} (f a) ≃ ∥ R a x ∥)
    → (a : X .fst) → f a ≡ dec a x .fst
  isEqClass→isEqClassEff' f x h a =
    Bool→TypeInj* _ _
        (h a ⋆ propTruncIdempotent≃ (isDecProp→isProp (dec a x)) ⋆ LiftDecProp (dec a x))

  isEqClassEff→isEqClass : (f : ℙEff (X .fst)) → isEqClassEff f ≃ isEqClass {ℓ' = ℓ'} _ R (ℙEff→ℙDec  _ f .fst)
  isEqClassEff→isEqClass f =
    propBiimpl→Equiv isPropPropTrunc isPropPropTrunc
      (Prop.map (λ (x , p) → x , isEqClassEff→isEqClass' f x p))
      (Prop.map (λ (x , p) → x , isEqClass→isEqClassEff' f x p))

  _∥Eff_ : Type ℓ
  _∥Eff_ = Σ[ f ∈ ℙEff (X .fst) ] isEqClassEff f

  ∥Eff≃∥Dec : _∥Eff_ ≃ _∥Dec_ (X .fst) R (λ x x' → isDecProp→Dec (dec x x'))
  ∥Eff≃∥Dec = Σ-cong-equiv (ℙEff≃ℙDec (X .fst)) isEqClassEff→isEqClass

  isFinSet∥Eff : isFinSet _∥Eff_
  isFinSet∥Eff = isFinSetSub (_ , isFinSetℙEff X) (λ _ → _ , isDecPropIsEqClassEff)

open BinaryRelation

module _
  (X : FinSet ℓ)
  (R : X .fst → X .fst → Type ℓ')
  (h : isEquivRel R)
  (dec : (x x' : X .fst) → isDecProp (R x x')) where

  isFinSetQuot : isFinSet (X .fst / R)
  isFinSetQuot =
    EquivPresIsFinSet
      ( ∥Eff≃∥Dec X _ dec
      ⋆ ∥Dec≃∥ _ _ (λ x x' → isDecProp→Dec (dec x x'))
      ⋆ invEquiv (equivQuot {ℓ' = ℓ'} _ _ h))
      (isFinSet∥Eff X _ dec)