module Properties.Step where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.Maybe using (just; nothing)
open import Luau.Heap using (Heap; lookup; alloc; ok; function_⟨_⟩_end)
open import Luau.Syntax using (Block; Expr; nil; var; addr; function⟨_⟩_end; block_is_end; _$_; local_←_; function_⟨_⟩_end; return; done; _∙_)
open import Luau.OpSem using (_⊢_⟶ᴱ_⊣_; _⊢_⟶ᴮ_⊣_; app ; beta; function; block; return; done; local; subst)
open import Luau.RuntimeError using (RuntimeErrorᴱ; RuntimeErrorᴮ; NilIsNotAFunction; UnboundVariable; SEGV; app; block; local; return)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Luau.Value using (nil; addr; val)
open import Properties.Remember using (remember; _,_)

data StepResultᴮ (H : Heap) (B : Block) : Set
data StepResultᴱ (H : Heap) (M : Expr) : Set

data StepResultᴮ H B where
  step : ∀ H′ B′ → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → StepResultᴮ H B
  return : ∀ V {B′} → (B ≡ (return (val V) ∙ B′)) → StepResultᴮ H B
  done : (B ≡ done) → StepResultᴮ H B
  error : (RuntimeErrorᴮ H B) → StepResultᴮ H B

data StepResultᴱ H M where
  step : ∀ H′ M′ → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → StepResultᴱ H M
  value : ∀ V → (M ≡ val V) → StepResultᴱ H M
  error : (RuntimeErrorᴱ H M) → StepResultᴱ H M

stepᴱ : ∀ H M → StepResultᴱ H M
stepᴮ : ∀ H B → StepResultᴮ H B

stepᴱ H nil = value nil refl
stepᴱ H (var x) = error (UnboundVariable x)
stepᴱ H (addr a) = value (addr a) refl
stepᴱ H (M $ N) with stepᴱ H M
stepᴱ H (M $ N) | step H′ M′ D = step H′ (M′ $ N) (app D)
stepᴱ H (nil $ N) | value nil refl = error NilIsNotAFunction
stepᴱ H (addr a $ N) | value (addr a) refl with remember (lookup H a)
stepᴱ H (addr a $ N) | value (addr a) refl | (nothing , p) = error (app (SEGV a p))
stepᴱ H (addr a $ N) | value (addr a) refl | (just(function f ⟨ x ⟩ B end) , p) = step H (block f is local x ← N ∙ B end) (beta p)
stepᴱ H (M $ N) | error E = error (app E)
stepᴱ H (function⟨ x ⟩ B end) with alloc H (function "anon" ⟨ x ⟩ B end)
stepᴱ H (function⟨ x ⟩ B end) | ok a H′ p = step H′ (addr a) (function p)
stepᴱ H (block b is B end) with stepᴮ H B
stepᴱ H (block b is B end) | step H′ B′ D = step H′ (block b is B′ end) (block D)
stepᴱ H (block b is (return _ ∙ B′) end) | return V refl = step H (val V) return
stepᴱ H (block b is done end) | done refl = step H nil done
stepᴱ H (block b is B end) | error E = error (block b E)

stepᴮ H (function f ⟨ x ⟩ C end ∙ B) with alloc H (function f ⟨ x ⟩ C end)
stepᴮ H (function f ⟨ x ⟩ C end ∙ B) | ok a H′ p = step H′ (B [ addr a / f ]ᴮ) (function p)
stepᴮ H (local x ← M ∙ B) with stepᴱ H M
stepᴮ H (local x ← M ∙ B) | step H′ M′ D = step H′ (local x ← M′ ∙ B) (local D)
stepᴮ H (local x ← _ ∙ B) | value V refl = step H (B [ V / x ]ᴮ) subst
stepᴮ H (local x ← M ∙ B) | error E = error (local x E)
stepᴮ H (return M ∙ B) with stepᴱ H M
stepᴮ H (return M ∙ B) | step H′ M′ D = step H′ (return M′ ∙ B) (return D)
stepᴮ H (return _ ∙ B) | value V refl = return V refl
stepᴮ H (return M ∙ B) | error E = error (return E)
stepᴮ H done = done refl


open import Agda.Primitive

variable
  ℓ : Level
  A : Set ℓ

postulate
  w/e : ∀ {a} {A : Set a} → A

  Sub : {a : Level} (A : Set a) → (Set → A) → Set

  hcomp-equivFillerSub : Sub A (λ { _ → w/e {_} {_} })


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

open import HoTT
open import groups.Cokernel
open import groups.Image
import homotopy.ConstantToSetExtendsToProp as ConstExt

-- A collection of useful lemmas about exactness

module groups.Exactness where

module Exact {i j k} {G : Group i} {H : Group j} {K : Group k}
  {φ : G →ᴳ H} {ψ : H →ᴳ K} (φ-ψ-is-exact : is-exact φ ψ) where

  private
    module G = Group G
    module H = Group H
    module K = Group K
    module φ = GroupHom φ
    module ψ = GroupHom ψ
    module E = is-exact φ-ψ-is-exact

  abstract
    φ-const-implies-ψ-is-inj : (∀ g →  φ.f g == H.ident) → is-injᴳ ψ
    φ-const-implies-ψ-is-inj φ-is-const =
      has-trivial-ker-is-injᴳ ψ λ h ψh=0 →
        Trunc-rec (H.El-is-set _ _)
          (λ{(g , φg=h) → ! φg=h ∙ φ-is-const g})
          (E.ker-sub-im h ψh=0)

    G-trivial-implies-ψ-is-inj : is-trivialᴳ G → is-injᴳ ψ
    G-trivial-implies-ψ-is-inj G-is-triv =
      φ-const-implies-ψ-is-inj λ g → ap φ.f (G-is-triv g) ∙ φ.pres-ident

  G-to-ker : G →ᴳ Ker.grp ψ
  G-to-ker = Ker.inject-lift ψ φ (λ g → E.im-sub-ker (φ.f g) [ g , idp ])

  abstract
    φ-inj-implies-G-to-ker-is-equiv : is-injᴳ φ → is-equiv (GroupHom.f G-to-ker)
    φ-inj-implies-G-to-ker-is-equiv φ-is-inj = is-eq _ from to-from from-to
      where
        to : G.El → Ker.El ψ
        to = GroupHom.f G-to-ker

        module From (k : Ker.El ψ)
          = ConstExt {A = hfiber φ.f (fst k)} {B = G.El}
              G.El-is-set (λ hf → fst hf)
              (λ hf₁ hf₂ → φ-is-inj _ _ (snd hf₁ ∙ ! (snd hf₂)))

        from : Ker.El ψ → G.El
        from = λ k → From.ext k (uncurry E.ker-sub-im k)

        to-from : ∀ k → to (from k) == k
        to-from k = Ker.El=-out ψ $
          Trunc-elim
            {P = λ hf → φ.f (From.ext k hf) == fst k}
            (λ _ → H.El-is-set _ _)
            (λ{(g , p) → p})
            (uncurry E.ker-sub-im k)

        from-to : ∀ g → from (to g) == g
        from-to g = From.ext-is-const (to g) (uncurry E.ker-sub-im (to g)) [ g , idp ]

  φ-inj-implies-G-iso-ker : is-injᴳ φ → G ≃ᴳ Ker.grp ψ
  φ-inj-implies-G-iso-ker φ-is-inj = G-to-ker , φ-inj-implies-G-to-ker-is-equiv φ-is-inj

  abstract
    K-trivial-implies-φ-is-surj : is-trivialᴳ K → is-surjᴳ φ
    K-trivial-implies-φ-is-surj K-is-triv h = E.ker-sub-im h (K-is-triv (ψ.f h))

  coker-to-K : (H-is-abelian : is-abelian H) → Coker φ H-is-abelian →ᴳ K
  coker-to-K H-is-abelian = record {M} where
    module M where
      module Cok = Coker φ H-is-abelian
      abstract
        f-rel : ∀ {h₁ h₂ : H.El} (h₁h₂⁻¹-in-im : SubgroupProp.prop (im-propᴳ φ) (H.diff h₁ h₂))
          → ψ.f h₁ == ψ.f h₂
        f-rel {h₁} {h₂} h₁h₂⁻¹-in-im = K.zero-diff-same _ _ $
          ! (ψ.pres-diff h₁ h₂) ∙ E.im-sub-ker (H.diff h₁ h₂) h₁h₂⁻¹-in-im

      f : Cok.El → K.El
      f = SetQuot-rec K.El-is-set ψ.f f-rel
      abstract
        pres-comp : ∀ h₁ h₂ → f (Cok.comp h₁ h₂) == K.comp (f h₁) (f h₂)
        pres-comp = SetQuot-elim
          (λ _ → Π-is-set λ _ → =-preserves-set K.El-is-set)
          (λ h₁ → SetQuot-elim
            (λ _ → =-preserves-set K.El-is-set)
            (λ h₂ → ψ.pres-comp h₁ h₂)
            (λ _ → prop-has-all-paths-↓ (K.El-is-set _ _)))
          (λ _ → prop-has-all-paths-↓ (Π-is-prop λ _ → K.El-is-set _ _))

  abstract
    ψ-surj-implies-coker-to-K-is-equiv : (H-is-abelian : is-abelian H)
      → is-surjᴳ ψ → is-equiv (GroupHom.f (coker-to-K H-is-abelian))
    ψ-surj-implies-coker-to-K-is-equiv H-is-abelian ψ-is-surj =
      is-eq to from to-from from-to
      where
        module Cok = Coker φ H-is-abelian

        to : Cok.El → K.El
        to = GroupHom.f (coker-to-K H-is-abelian)

        module From (k : K.El)
          = ConstExt {A = hfiber ψ.f k} {B = Cok.El}
              Cok.El-is-set (λ hf → q[ fst hf ])
              (λ{(h₁ , p₁) (h₂ , p₂) → quot-rel $
                E.ker-sub-im (H.diff h₁ h₂) $
                  ψ.pres-diff h₁ h₂ ∙ ap2 K.diff p₁ p₂ ∙ K.inv-r k})

        from : K.El → Cok.El
        from k = From.ext k (ψ-is-surj k)

        to-from : ∀ k → to (from k) == k
        to-from k = Trunc-elim
          {P = λ hf → to (From.ext k hf) == k}
          (λ _ → K.El-is-set _ _)
          (λ{(h , p) → p})
          (ψ-is-surj k)

        from-to : ∀ c → from (to c) == c
        from-to = SetQuot-elim
          (λ _ → =-preserves-set Cok.El-is-set)
          (λ h → From.ext-is-const (ψ.f h) (ψ-is-surj (ψ.f h)) [ h , idp ])
          (λ _ → prop-has-all-paths-↓ (Cok.El-is-set _ _))

  ψ-surj-implies-coker-iso-K : (H-is-abelian : is-abelian H)
    → is-surjᴳ ψ → Coker φ H-is-abelian ≃ᴳ K
  ψ-surj-implies-coker-iso-K H-is-abelian ψ-is-surj =
    coker-to-K H-is-abelian , ψ-surj-implies-coker-to-K-is-equiv H-is-abelian ψ-is-surj

  -- right split lemma
  module _ (H-is-abelian : is-abelian H) (φ-inj : is-injᴳ φ)
    (χ : K →ᴳ H) (χ-inv-r : (k : Group.El K) → GroupHom.f (ψ ∘ᴳ χ) k == k) where

    {- Splitting Lemma - Right Split
       Assume an exact sequence:

                 φ   ψ
           0 → G → H → K

       where H is abelian. If ψ has a right inverse χ, then H == G × K. Over
       this path φ becomes the natural injection and ψ the natural projection.
    -}

    private
      module χ = GroupHom χ

      {- H ≃ᴳ Ker ψ × Im χ -}

      ker-part : H →ᴳ Ker ψ
      ker-part = Ker.inject-lift ψ
        (hom-comp H (H , H-is-abelian) (idhom H) (inv-hom (H , H-is-abelian) ∘ᴳ (χ ∘ᴳ ψ)))
        (λ h →
          ψ.f (H.comp h (H.inv (χ.f (ψ.f h))))
            =⟨ ψ.pres-comp h (H.inv (χ.f (ψ.f h))) ⟩
          K.comp (ψ.f h) (ψ.f (H.inv (χ.f (ψ.f h))))
            =⟨ ! (χ.pres-inv (ψ.f h))
               |in-ctx (λ w → K.comp (ψ.f h) (ψ.f w)) ⟩
          K.comp (ψ.f h) (ψ.f (χ.f (K.inv (ψ.f h))))
            =⟨ χ-inv-r (K.inv (ψ.f h)) |in-ctx K.comp (ψ.f h) ⟩
          K.comp (ψ.f h) (K.inv (ψ.f h))
            =⟨ K.inv-r (ψ.f h) ⟩
          K.ident ∎)

      abstract
        ker-part-kerψ : (ker : Ker.El ψ) → GroupHom.f ker-part (fst ker) == ker
        ker-part-kerψ (h , p) = Ker.El=-out ψ $
          H.comp h (H.inv (χ.f (ψ.f h)))
            =⟨ p |in-ctx (λ w → H.comp h (H.inv (χ.f w))) ⟩
          H.comp h (H.inv (χ.f K.ident))
            =⟨ χ.pres-ident |in-ctx (λ w → H.comp h (H.inv w)) ⟩
          H.comp h (H.inv H.ident)
            =⟨ H.inv-ident |in-ctx H.comp h ⟩
          H.comp h H.ident
            =⟨ H.unit-r h ⟩
          h =∎

        ker-part-imχ : (im : Im.El χ) → GroupHom.f ker-part (fst im) == Ker.ident ψ
        ker-part-imχ (h , s) = Trunc-rec (Ker.El-level ψ _ _)
          (λ {(k , p) → Ker.El=-out ψ $
            H.comp h (H.inv (χ.f (ψ.f h)))
              =⟨ ! p |in-ctx (λ w → H.comp w (H.inv (χ.f (ψ.f w)))) ⟩
            H.comp (χ.f k) (H.inv (χ.f (ψ.f (χ.f k))))
              =⟨ χ-inv-r k |in-ctx (λ w → H.comp (χ.f k) (H.inv (χ.f w))) ⟩
            H.comp (χ.f k) (H.inv (χ.f k))
              =⟨ H.inv-r (χ.f k) ⟩
            H.ident
              =∎})
          s

      im-part : H →ᴳ Im χ
      im-part = im-lift χ ∘ᴳ ψ

      abstract
        im-part-kerψ : (ker : Ker.El ψ) → GroupHom.f im-part (fst ker) == Im.ident χ
        im-part-kerψ (h , p) = Im.El=-out χ (ap χ.f p ∙ χ.pres-ident)

        im-part-imχ : (im : Im.El χ) → GroupHom.f im-part (fst im) == im
        im-part-imχ (h , s) = Trunc-rec (Im.El-level χ _ _)
            (λ {(k , p) → Im.El=-out χ $
              χ.f (ψ.f h)        =⟨ ! p |in-ctx (χ.f ∘ ψ.f) ⟩
              χ.f (ψ.f (χ.f k))  =⟨ χ-inv-r k |in-ctx χ.f ⟩
              χ.f k              =⟨ p ⟩
              h                  =∎})
            s

      decomp : H →ᴳ Ker ψ ×ᴳ Im χ
      decomp = ×ᴳ-fanout ker-part im-part

      decomp-is-equiv : is-equiv (GroupHom.f decomp)
      decomp-is-equiv = is-eq _ dinv decomp-dinv dinv-decomp
        where
        dinv : Group.El (Ker ψ ×ᴳ Im χ) → H.El
        dinv ((h₁ , _) , (h₂ , _)) = H.comp h₁ h₂

        abstract
          decomp-dinv : ∀ s → GroupHom.f decomp (dinv s) == s
          decomp-dinv ((h₁ , kr) , (h₂ , im)) = pair×=
            (GroupHom.f ker-part (H.comp h₁ h₂)
               =⟨ GroupHom.pres-comp ker-part h₁ h₂ ⟩
             Ker.comp ψ (GroupHom.f ker-part h₁) (GroupHom.f ker-part h₂)
               =⟨ ap2 (Ker.comp ψ) (ker-part-kerψ (h₁ , kr)) (ker-part-imχ (h₂ , im)) ⟩
             Ker.comp ψ (h₁ , kr) (Ker.ident ψ)
               =⟨ Ker.unit-r ψ (h₁ , kr) ⟩
             (h₁ , kr)
               =∎)
            (GroupHom.f im-part (H.comp h₁ h₂)
               =⟨ GroupHom.pres-comp im-part h₁ h₂ ⟩
             Im.comp χ (GroupHom.f im-part h₁) (GroupHom.f im-part h₂)
               =⟨ ap2 (Im.comp χ) (im-part-kerψ (h₁ , kr)) (im-part-imχ (h₂ , im)) ⟩
             Im.comp χ (Im.ident χ) (h₂ , im)
               =⟨ Im.unit-l χ (h₂ , im) ⟩
             (h₂ , im) ∎)

          dinv-decomp : ∀ h → dinv (GroupHom.f decomp h) == h
          dinv-decomp h =
            H.comp (H.comp h (H.inv (χ.f (ψ.f h)))) (χ.f (ψ.f h))
              =⟨ H.assoc h (H.inv (χ.f (ψ.f h))) (χ.f (ψ.f h)) ⟩
            H.comp h (H.comp (H.inv (χ.f (ψ.f h))) (χ.f (ψ.f h)))
              =⟨ H.inv-l (χ.f (ψ.f h)) |in-ctx H.comp h ⟩
            H.comp h H.ident
              =⟨ H.unit-r h ⟩
            h ∎

      decomp-equiv : H.El ≃ Group.El (Ker ψ ×ᴳ Im χ)
      decomp-equiv = (_ , decomp-is-equiv)

      decomp-iso : H ≃ᴳ Ker ψ ×ᴳ Im χ
      decomp-iso = decomp , decomp-is-equiv

      {- K == Im χ -}

      K-iso-Imχ : K ≃ᴳ Im χ
      K-iso-Imχ = surjᴳ-and-injᴳ-iso (im-lift χ) (im-lift-is-surj χ) inj where
        abstract
          inj = has-trivial-ker-is-injᴳ (im-lift χ)
                  (λ k p → ! (χ-inv-r k) ∙ ap ψ.f (ap fst p) ∙ ψ.pres-ident)

    φ-inj-and-ψ-has-rinv-split : H ≃ᴳ G ×ᴳ K
    φ-inj-and-ψ-has-rinv-split =
      ×ᴳ-emap (φ-inj-implies-G-iso-ker φ-inj ⁻¹ᴳ) (K-iso-Imχ ⁻¹ᴳ) ∘eᴳ decomp-iso

    abstract
      φ-inj-and-ψ-has-rinv-implies-φ-comm-inl : CommSquareᴳ φ ×ᴳ-inl
        (idhom _) (–>ᴳ φ-inj-and-ψ-has-rinv-split )
      φ-inj-and-ψ-has-rinv-implies-φ-comm-inl = comm-sqrᴳ λ g → pair×=
        (ap (GroupIso.g (φ-inj-implies-G-iso-ker φ-inj))
              (ker-part-kerψ (GroupHom.f G-to-ker g))
          ∙ GroupIso.g-f (φ-inj-implies-G-iso-ker φ-inj) g)
        (im-sub-ker-out φ ψ E.im-sub-ker g)

    φ-inj-and-ψ-has-rinv-implies-ψ-comm-snd : CommSquareᴳ ψ (×ᴳ-snd {G = G})
      (–>ᴳ φ-inj-and-ψ-has-rinv-split ) (idhom _)
    φ-inj-and-ψ-has-rinv-implies-ψ-comm-snd = comm-sqrᴳ λ h → idp

abstract
  pre∘-is-exact : ∀ {i j k l} {G : Group i} {H : Group j} {K : Group k} {L : Group l}
    (φ : G →ᴳ H) {ψ : H →ᴳ K} {ξ : K →ᴳ L} → is-surjᴳ φ → is-exact ψ ξ → is-exact (ψ ∘ᴳ φ) ξ
  pre∘-is-exact φ {ψ = ψ} φ-is-surj ψ-ξ-is-exact = record {
    ker-sub-im = λ k → im-sub-im-∘ ψ φ φ-is-surj k ∘ ker-sub-im ψ-ξ-is-exact k;
    im-sub-ker = λ k → im-sub-ker ψ-ξ-is-exact k ∘ im-∘-sub-im ψ φ k}

module Exact2 {i j k l} {G : Group i} {H : Group j} {K : Group k} {L : Group l}
  {φ : G →ᴳ H} {ψ : H →ᴳ K} {ξ : K →ᴳ L}
  (φ-ψ-is-exact : is-exact φ ψ) (ψ-ξ-is-exact : is-exact ψ ξ) where

  private
    module G = Group G
    module H = Group H
    module K = Group K
    module L = Group L
    module φ = GroupHom φ
    module ψ = GroupHom ψ
    module ξ = GroupHom ξ
    module E1 = is-exact φ-ψ-is-exact
    module E2 = is-exact ψ-ξ-is-exact
    {- [L] for "lemmas" -}
    module EL1 = Exact φ-ψ-is-exact
    module EL2 = Exact ψ-ξ-is-exact

  abstract
    G-trivial-and-L-trivial-implies-H-iso-K :
      is-trivialᴳ G → is-trivialᴳ L → H ≃ᴳ K
    G-trivial-and-L-trivial-implies-H-iso-K G-is-triv L-is-triv
      = surjᴳ-and-injᴳ-iso ψ
          (EL2.K-trivial-implies-φ-is-surj L-is-triv)
          (EL1.G-trivial-implies-ψ-is-inj G-is-triv)

  G-trivial-implies-H-iso-ker :
    is-trivialᴳ G → H ≃ᴳ Ker.grp ξ
  G-trivial-implies-H-iso-ker G-is-triv
    = EL2.φ-inj-implies-G-iso-ker $
        EL1.G-trivial-implies-ψ-is-inj G-is-triv

  L-trivial-implies-coker-iso-K : (H-is-abelian : is-abelian H)
    → is-trivialᴳ L → Coker φ H-is-abelian ≃ᴳ K
  L-trivial-implies-coker-iso-K H-is-abelian L-is-triv
    = EL1.ψ-surj-implies-coker-iso-K H-is-abelian $
        EL2.K-trivial-implies-φ-is-surj L-is-triv

abstract
  equiv-preserves-exact : ∀ {i₀ i₁ j₀ j₁ l₀ l₁}
    {G₀ : Group i₀} {G₁ : Group i₁} {H₀ : Group j₀} {H₁ : Group j₁} {K₀ : Group l₀} {K₁ : Group l₁}
    {φ₀ : G₀ →ᴳ H₀} {ψ₀ : H₀ →ᴳ K₀} {φ₁ : G₁ →ᴳ H₁} {ψ₁ : H₁ →ᴳ K₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁} {ξK : K₀ →ᴳ K₁}
    → CommSquareᴳ φ₀ φ₁ ξG ξH → CommSquareᴳ ψ₀ ψ₁ ξH ξK
    → is-equiv (GroupHom.f ξG) → is-equiv (GroupHom.f ξH) → is-equiv (GroupHom.f ξK)
    → is-exact φ₀ ψ₀ → is-exact φ₁ ψ₁
  equiv-preserves-exact {K₀ = K₀} {K₁} {φ₀ = φ₀} {ψ₀} {φ₁} {ψ₁} {ξG} {ξH} {ξK}
    (comm-sqrᴳ φ□) (comm-sqrᴳ ψ□) ξG-is-equiv ξH-is-equiv ξK-is-equiv exact₀
    = record {
      im-sub-ker = λ h₁ → Trunc-rec (SubgroupProp.level (ker-propᴳ ψ₁) h₁)
        (λ{(g₁ , φ₁g₁=h₁) →
          ψ₁.f h₁
            =⟨ ap ψ₁.f $ ! $ ξH.f-g h₁ ⟩
          ψ₁.f (ξH.f (ξH.g h₁))
            =⟨ ! $ ψ□ (ξH.g h₁) ⟩
          ξK.f (ψ₀.f (ξH.g h₁))
            =⟨ ap ξK.f $ im-sub-ker exact₀ (ξH.g h₁) [ ξG.g g₁ ,_ $
                φ₀.f (ξG.g g₁)
                  =⟨ ! (ξH.g-f (φ₀.f (ξG.g g₁))) ⟩
                ξH.g (ξH.f (φ₀.f (ξG.g g₁)))
                  =⟨ ap ξH.g $ φ□ (ξG.g g₁) ∙ ap φ₁.f (ξG.f-g g₁) ∙ φ₁g₁=h₁ ⟩
                ξH.g h₁
                  =∎ ] ⟩
          ξK.f (Group.ident K₀)
            =⟨ ξK.pres-ident ⟩
          Group.ident K₁
            =∎});
      ker-sub-im = λ h₁ ψ₁h₁=0 →
        Trunc-rec (SubgroupProp.level (im-propᴳ φ₁) h₁)
          (λ{(g₀ , φ₀g₀=ξH⁻¹h₁) → [ ξG.f g₀ ,_ $
            φ₁.f (ξG.f g₀)
              =⟨ ! $ φ□ g₀ ⟩
            ξH.f (φ₀.f g₀)
              =⟨ ap ξH.f φ₀g₀=ξH⁻¹h₁ ⟩
            ξH.f (ξH.g h₁)
              =⟨ ξH.f-g h₁ ⟩
            h₁
              =∎ ]})
          (ker-sub-im exact₀ (ξH.g h₁) $
            ψ₀.f (ξH.g h₁)
              =⟨ ! $ ξK.g-f (ψ₀.f (ξH.g h₁)) ⟩
            ξK.g (ξK.f (ψ₀.f (ξH.g h₁)))
              =⟨ ap ξK.g $ ψ□ (ξH.g h₁) ∙ ap ψ₁.f (ξH.f-g h₁) ∙ ψ₁h₁=0 ⟩
            ξK.g (Group.ident K₁)
              =⟨ GroupHom.pres-ident ξK.g-hom ⟩
            Group.ident K₀
              =∎)}
    where
      module φ₀ = GroupHom φ₀
      module φ₁ = GroupHom φ₁
      module ψ₀ = GroupHom ψ₀
      module ψ₁ = GroupHom ψ₁
      module ξG = GroupIso (ξG , ξG-is-equiv)
      module ξH = GroupIso (ξH , ξH-is-equiv)
      module ξK = GroupIso (ξK , ξK-is-equiv)

abstract
  equiv-preserves'-exact : ∀ {i₀ i₁ j₀ j₁ l₀ l₁}
    {G₀ : Group i₀} {G₁ : Group i₁} {H₀ : Group j₀} {H₁ : Group j₁} {K₀ : Group l₀} {K₁ : Group l₁}
    {φ₀ : G₀ →ᴳ H₀} {ψ₀ : H₀ →ᴳ K₀} {φ₁ : G₁ →ᴳ H₁} {ψ₁ : H₁ →ᴳ K₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁} {ξK : K₀ →ᴳ K₁}
    → CommSquareᴳ φ₀ φ₁ ξG ξH → CommSquareᴳ ψ₀ ψ₁ ξH ξK
    → is-equiv (GroupHom.f ξG) → is-equiv (GroupHom.f ξH) → is-equiv (GroupHom.f ξK)
    → is-exact φ₁ ψ₁ → is-exact φ₀ ψ₀
  equiv-preserves'-exact cs₀ cs₁ ξG-ise ξH-ise ξK-ise ex =
    equiv-preserves-exact
      (CommSquareᴳ-inverse-v cs₀ ξG-ise ξH-ise)
      (CommSquareᴳ-inverse-v cs₁ ξH-ise ξK-ise)
      (is-equiv-inverse ξG-ise)
      (is-equiv-inverse ξH-ise)
      (is-equiv-inverse ξK-ise)
      ex


module silly0 where

record SingleSortedAlgebra : Set₁ where
  field
    Carrier : Set
    _⊕_     : Carrier → Carrier → Carrier

{-

One of my aims to introduce construct “fields-of”:

    record SingleSortedAlgebraWithConstant : Set₁ where
       fields-of SingleSortedAlgebra renaming (_⊕_ to _⟨$⟩_)
       field
         ε : Carrier

Should have the same net result as:

    record SingleSortedAlgebraWithConstant : Set₁ where
       field
         Carrier : Set
         _⟨$⟩_   : Carrier → Carrier → Carrier
         ε       : Carrier

-}


open import Algebra.Apartness using (HeytingField)

module Data.Real.Abstract.Bundles
  c ℓ₁ ℓ₂ r
  where

open import Relation.Binary using (Rel)
open import Data.Real.Abstract.Structures
open import Level using (_⊔_; suc)

record OrderedHeytingField : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂ ⊔ r)) where
  field
    f : HeytingField c ℓ₁ ℓ₂

  open HeytingField f public

  field
    _<_ : Rel Carrier r
    isOrderedHeytingField : IsOrderedHeytingField f _<_

record ArchimedanHeytingField : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂ ⊔ r)) where
  field
    f : HeytingField c ℓ₁ ℓ₂

  open HeytingField f public

  field
    _<_ : Rel Carrier r
    isArchimedanHeytingField : IsArchimedanHeytingField f _<_


module hnf-tests where

open import bool
open import list
open import nat
open import product
open import string

open import cedille-types
open import conversion
open import ctxt
open import is-free
open import rename
open import subst
open import syntax-util
open import to-string

S : term
S = mlam "n" (mlam "s" (mlam "z" (mapp (mvar "s") (mapp (mapp (mvar "n") (mvar "s")) (mvar "z")))))

plus : term
plus = mlam "n" (mlam "m" (mapp (mapp (mvar "n") S) (mvar "m")))

run : term → term
run t = hnf new-ctxt unfold-head t

show : term → string
show t = term-to-string t

s2 = show (run (mapp S (mvar "z")))

-- λ s . (λ x . λ s . x λ s' . f s' s) s

t1 = mlam "s" (mapp (mlam "x" (mlam "s" (mapp (mvar "x") (mlam "s'" (mapp (mapp (mvar "f") (mvar "s'")) (mvar "s")))))) (mvar "s"))

s1 = show (run t1)

Γ = ctxt-var-decl "s" new-ctxt

q = show (subst-term Γ (mvar "s") "x" (mlam "s" (mapp (mvar "x") (mlam "s'" (mapp (mapp (mvar "f") (mvar "s'")) (mvar "s"))))))

r = show (subst-term Γ (mvar "s") "x" (mlam "s" (mlam "s'" (mapp (mapp (mvar "f") (mvar "s'")) (mvar "s")))))

aa = rename-var-if Γ empty-renamectxt "s" (mvar "s")

Γ' = ctxt-var-decl "s'" Γ
ρ = renamectxt-insert empty-renamectxt "s" "s'"

bb = show (substh-term Γ' ρ (mvar "s") "x" (mlam "s'" (mapp (mapp (mvar "f") (mvar "s'")) (mvar "s"))))

cc = rename-var-if Γ' ρ "s'" (mvar "s")

try-pull-lift-types : type → type → type
try-pull-lift-types tp1 tp2 with decompose-tpapps tp1 | decompose-tpapps (hnf new-ctxt unfold-head tp2)
try-pull-lift-types tp1 tp2 | Lft _ _ X t l , args1 | Lft _ _ X' t' l' , args2 =
   if conv-tty* new-ctxt args1 args2 then
      try-pull-term-in t l (length args1) [] []
   else
      TpApp tp1 tp2
   where try-pull-term-in : term → liftingType → ℕ → 𝕃 var → 𝕃 liftingType → type
         try-pull-term-in t (LiftParens _ l _) n vars ltps = try-pull-term-in t l n vars ltps
         try-pull-term-in t (LiftArrow _ l) 0 vars ltps =
           recompose-tpapps
             (Lft posinfo-gen posinfo-gen X (Lam* vars (hnf Γ no-unfolding (App t NotErased (App* t' (map mvar vars)))))
               (LiftArrow* ltps l) , args1)
         try-pull-term-in (Lam _ _ _ x _ t) (LiftArrow l1 l2) (suc n) vars ltps =
           try-pull-term-in t l2 n (x :: vars) (l1 :: ltps)
         try-pull-term-in t (LiftArrow l1 l2) (suc n) vars ltps =
           let x = fresh-var "x" (ctxt-binds-var Γ) empty-renamectxt in
             try-pull-term-in (App t NotErased (mvar x)) l2 n (x :: vars) (l1 :: ltps)
         try-pull-term-in t l n vars ltps = TpApp tp1 tp2

try-pull-lift-types tp1 tp2 | h , a | h' , a' = TpApp tp1 tp2

lta = (TpApp (Lft posinfo-gen posinfo-gen "X" (mvar "f")
               (LiftArrow (LiftStar posinfo-gen) (LiftArrow (LiftStar posinfo-gen) (LiftStar posinfo-gen))))
             (mtpvar "doit"))
ltb = (TpApp (Lft posinfo-gen posinfo-gen "X" (mvar "t") (LiftStar posinfo-gen)) (mtpvar "doit"))

lt = try-pull-lift-types lta ltb

lts = to-string lt


module Prelude where
  open import Agda.Primitive using (Level; lzero; lsuc) renaming (_⊔_ to lmax)
  open import Relation.Binary.PropositionalEquality as Eq

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

  open import Data.List.Membership.DecSetoid ≡-decSetoid

  open import Data.List.Relation.Unary.Any
  open import Data.Empty

  open import Data.List.Relation.Unary.All

  -- sums
  data _+̇_ (A B : Set) : Set where
    Inl : A → A +̇ B
    Inr : B → A +̇ B

 -- Basic properties of lists
  emptyListIsEmpty : ∀ {x}
                     → x ∉ []
  emptyListIsEmpty ()

  listNoncontainment : ∀ {x x' L}
                        → x ∉ L
                        → x' ∈ L
                        → x ≢ x'
  listNoncontainment {x} {x'} {L} xNotInL x'InL = λ xEqx' → xNotInL (Eq.subst (λ a → a ∈ L) (Eq.sym xEqx') x'InL)

  listConcatNoncontainment : ∀ {x x' L}
                             → x ≢ x'
                             → x ∉ L
                             → x ∉ (x' ∷ L)
  listConcatNoncontainment {x} {x'} {L} xNeqx' xNotInL (here xEqx') = xNeqx' xEqx'
  listConcatNoncontainment {x} {x'} {L} xNeqx' xNotInL (there xInConcat) = xNotInL xInConcat

  listConcatContainment : ∀ {x x' t}
                          → x ∈ (x' ∷ t)
                          → x' ≢ x
                          → x ∈ t

  listConcatContainment {x} {x'} {t} (here px) x'Neqx = ⊥-elim (x'Neqx (Eq.sym px))
  listConcatContainment {x} {x'} {t} (there xInCons) x'Neqx = xInCons

-- Basic properties of equality
  ≢-sym : ∀ {a} {A : Set a} → {x x' : A}
          → x ≢ x'
          → x' ≢ x
  ≢-sym xNeqx' = λ x'Eqx → xNeqx' (Eq.sym x'Eqx)

-- Congruence
  cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
        (f : A → B → C → D) {x y u v w t} → x ≡ y → u ≡ v → w ≡ t → f x u w ≡ f y v t
  cong₃ f refl refl refl = refl

-- All
  allInsideOut : {A : Set}
                 → {L L' : List A}
                 → {P : A → A → Set}
                 → (∀ {T T'} → P T T' → P T' T)
                 → All (λ T → All (λ T' → P T T') L) L'
                 → All (λ T → All (λ T' → P T T') L') L
  allInsideOut {A} {[]} {.[]} sym [] = []
  allInsideOut {A} {x ∷ L} {.[]} sym [] = [] ∷ allRelatedToEmpty
    where
      allRelatedToEmpty : {A : Set}
                          → {L : List A}
                          → {P : A → A → Set}
                          → All (λ T → All (P T) []) L
      allRelatedToEmpty {A} {[]} {P} = []
      allRelatedToEmpty {A} {x ∷ L} {P} = [] ∷ allRelatedToEmpty
  allInsideOut {A} {[]} {.(_ ∷ _)} sym (all₁ ∷ all₂) = []
  allInsideOut {A} {x ∷ L} {(x' ∷ L')} {P} sym (all₁ ∷ all₂) =
    ((sym (Data.List.Relation.Unary.All.head all₁)) ∷ unwrap L' all₂) ∷
      allInsideOut sym (Data.List.Relation.Unary.All.tail all₁ ∷  unwrap2 L' all₂)
    where
      unwrap : (M : List A)
               → All (λ T → All (P T) (x ∷ L)) M
               → All (λ T' → P x T') M
      unwrap .[] [] = []
      unwrap (x ∷ r) (h ∷ t) = (sym (Data.List.Relation.Unary.All.head h)) ∷ unwrap r t

      unwrap2 : (M : List A)
                → All (λ T → All (P T) (x ∷ L)) M
                → All (λ T → All (P T) L) M
      unwrap2 [] all = []
      unwrap2 (x ∷ M) (all₁ ∷ all₂) = (Data.List.Relation.Unary.All.tail all₁) ∷ unwrap2 M all₂

{-
-- equality of naturals is decidable. we represent this as computing a
  -- choice of units, with inl <> meaning that the naturals are indeed the
  -- same and inr <> that they are not.
  natEQ : (x y : ℕ) → ((x ≡ y) + ((x ≡ y) → ⊥))
  natEQ Z Z = Inl refl
  natEQ Z (1+ y) = Inr (λ ())
  natEQ (1+ x) Z = Inr (λ ())
  natEQ (1+ x) (1+ y) with natEQ x y
  natEQ (1+ x) (1+ .x) | Inl refl = Inl refl
  ... | Inr b = Inr (λ x₁ → b (1+inj x y x₁))

  -- nat equality as a predicate. this saves some very repetative casing.
  natEQp : (x y : ℕ) → Set
  natEQp x y with natEQ x y
  natEQp x .x | Inl refl = ⊥
  natEQp x y | Inr x₁ = ⊤
-}

{-

  -- equality
  data _≡_ {l : Level} {A : Set l} (M : A) : A → Set l where
    refl : M ≡ M

  infixr 9 _≡_

  {-# BUILTIN EQUALITY _≡_ #-}

  -- transitivity of equality
  _·_ : {l : Level} {α : Set l} {x y z : α} → x ≡ y → y ≡ z → x ≡ z
  refl · refl = refl

  -- symmetry of equality
  ! : {l : Level} {α : Set l} {x y : α} → x ≡ y → y ≡ x
  ! refl = refl

  -- ap, in the sense of HoTT, that all functions respect equality in their
  -- arguments. named in a slightly non-standard way to avoid naming
  -- clashes with hazelnut constructors.
  ap1 : {l1 l2 : Level} {α : Set l1} {β : Set l2} {x y : α} (F : α → β)
          → x ≡ y → F x ≡ F y
  ap1 F refl = refl

  -- transport, in the sense of HoTT, that fibrations respect equality
  tr : {l1 l2 : Level} {α : Set l1} {x y : α}
                    (B : α → Set l2)
                    → x ≡ y
                    → B x
                    → B y
  tr B refl x₁ = x₁

  -- options
  data Maybe (A : Set) : Set where
    Some : A → Maybe A
    None : Maybe A

  -- the some constructor is injective. perhaps unsurprisingly.
  someinj : {A : Set} {x y : A} → Some x ≡ Some y → x ≡ y
  someinj refl = refl

  --  some isn't none.
  somenotnone : {A : Set} {x : A} → Some x ≡ None → ⊥
  somenotnone ()

  -- function extensionality, used to reason about contexts as finite
  -- functions.
  postulate
     funext : {A : Set} {B : A → Set} {f g : (x : A) → (B x)} →
              ((x : A) → f x ≡ g x) → f ≡ g

  -- non-equality is commutative
  flip : {A : Set} {x y : A} → (x ≡ y → ⊥) → (y ≡ x → ⊥)
  flip neq eq = neq (! eq)

  -- two types are said to be equivalent, or isomorphic, if there is a pair
  -- of functions between them where both round-trips are stable up to ≡
  _≃_ : Set → Set → Set
  _≃_ A B = Σ[ f ∈ (A → B) ] Σ[ g ∈ (B → A) ]
             (((a : A) → g (f a) ≡ a) × (((b : B) → f (g b) ≡ b)))

 -}


------------------------------------------------------------------------
-- The Step function, used to define strong and weak bisimilarity as
-- well as expansion
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude

open import Labelled-transition-system

module Bisimilarity.Step
         {ℓ}
         (lts : LTS ℓ)
         (open LTS lts)
         (_[_]↝₁_ _[_]↝₂_ : Proc → Label → Proc → Type ℓ)
         where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)

open import Bijection equality-with-J using (_↔_)
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level.Closure equality-with-J

import Similarity.Step lts as One-sided
open import Indexed-container hiding (⟨_⟩)
open import Indexed-container.Combinators hiding (_∘_)
open import Relation

private
 module Temporarily-private where

  -- If _[_]↝₁_ and _[_]↝₂_ are instantiated with _[_]⟶_, then this is
  -- basically the function from Definition 6.3.1 in Pous and
  -- Sangiorgi's "Enhancements of the bisimulation proof method",
  -- except that clause (3) is omitted.
  --
  -- Similarly, if the relations are instantiated with _[_]⇒̂_, then
  -- this is basically the function wb₁, again with the exception that
  -- clause (3) is omitted.
  --
  -- Finally, if _[_]↝₁_ is instantiated with _[_]⟶̂_ and _[_]↝₂_ is
  -- instantiated with _[_]⇒_, then we get the expansion relation's
  -- "step" function.

  record Step {r} (R : Rel₂ r Proc) (pq : Proc × Proc) :
              Type (ℓ ⊔ r) where
    constructor ⟨_,_⟩

    private
      p = proj₁ pq
      q = proj₂ pq

    field
      left-to-right : ∀ {p′ μ} →
                      p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]↝₁ q′ × R (p′ , q′)
      right-to-left : ∀ {q′ μ} →
                      q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]↝₂ p′ × R (p′ , q′)

open Temporarily-private using (Step)

-- The Step function, expressed as an indexed container.

StepC : Container (Proc × Proc) (Proc × Proc)
StepC = One-sided.StepC _[_]↝₁_ ⟷ One-sided.StepC _[_]↝₂_

-- The strong bisimilarity container presented in the paper,
-- generalised to use _[_]↝₁_ and _[_]↝₂_.

StepC′ : Container (Proc × Proc) (Proc × Proc)
StepC′ =
  (λ { (p , q) → (∀ {p′ μ} → p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]↝₁ q′) ×
                 (∀ {q′ μ} → q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]↝₂ p′)
     })
    ◁
  (λ { {(p , q)} (lr , rl) (p′ , q′) →
       (∃ λ μ → ∃ λ (p⟶p′ : p [ μ ]⟶ p′) → proj₁ (lr p⟶p′) ≡ q′) ⊎
       (∃ λ μ → ∃ λ (q⟶q′ : q [ μ ]⟶ q′) → proj₁ (rl q⟶q′) ≡ p′)
     })

-- The interpretations of the two containers above are pointwise
-- logically equivalent, and in the presence of extensionality they
-- are pointwise isomorphic.

StepC↔StepC′ :
  ∀ {k r} {R : Rel₂ r Proc} {pq} →
  Extensionality? k ℓ (ℓ ⊔ r) →
  ⟦ StepC ⟧ R pq ↝[ k ] ⟦ StepC′ ⟧ R pq
StepC↔StepC′ {pq = p , q} =
  inverse-ext? λ {k} ext →
  Σ-cong (inverse $
          drop-⊤-left-Σ (One-sided.Magic↔⊤ _)
            ×-cong
          drop-⊤-left-Σ (One-sided.Magic↔⊤ _)) λ { (lr , rl) →
  implicit-∀-cong ext λ { {p′ , q′} →
  Π-cong (lower-extensionality? k lzero ℓ ext)
    (F.id ⊎-cong (

       (∃ λ μ → ∃ λ (q⟶q′ : q [ μ ]⟶ q′) →
            proj₁ (rl q⟶q′) ≡ p′)                            ↝⟨ inverse $ drop-⊤-left-Σ (_⇔_.to contractible⇔↔⊤ (singleton-contractible _)) ⟩

       (∃ λ (q′p′≡ : ∃ λ q′p′ → q′p′ ≡ (q′ , p′)) →
        ∃ λ μ → ∃ λ (q⟶q′ : q [ μ ]⟶ proj₁ (proj₁ q′p′≡)) →
          proj₁ (rl q⟶q′) ≡ proj₂ (proj₁ q′p′≡))             ↝⟨ inverse Σ-assoc ⟩

       (∃ λ q′p′ → q′p′ ≡ (q′ , p′) ×
        ∃ λ μ → ∃ λ (q⟶q′ : q [ μ ]⟶ proj₁ q′p′) →
          proj₁ (rl q⟶q′) ≡ proj₂ q′p′)                      ↔⟨ (∃-cong λ _ → (inverse $ Eq.≃-≡ (Eq.↔⇒≃ ×-comm)) ×-cong F.id) ⟩□

       (∃ λ q′p′ → swap q′p′ ≡ (p′ , q′) ×
        ∃ λ μ → ∃ λ (q⟶q′ : q [ μ ]⟶ proj₁ q′p′) →
          proj₁ (rl q⟶q′) ≡ proj₂ q′p′)                      □))

    (λ _ → F.id) }}

-- The definition of Step in terms of a container is pointwise
-- logically equivalent to the direct definition, and in the presence
-- of extensionality it is pointwise isomorphic to the direct
-- definition.

Step↔StepC :
  ∀ {k r} {R : Rel₂ r Proc} {pq} →
  Extensionality? k ℓ (ℓ ⊔ r) →
  Step R pq ↝[ k ] ⟦ StepC ⟧ R pq
Step↔StepC {R = R} {pq} ext =
  Step R pq                                     ↔⟨ lemma ⟩

  One-sided.Step _[_]↝₁_ R pq
    ×
  One-sided.Step _[_]↝₂_ (R ⁻¹) (swap pq)       ↝⟨ One-sided.Step↔StepC _ ext ×-cong One-sided.Step↔StepC _ ext ⟩

  ⟦ One-sided.StepC _[_]↝₁_ ⟧ R pq
    ×
  ⟦ One-sided.StepC _[_]↝₂_ ⟧ (R ⁻¹) (swap pq)  ↝⟨ inverse-ext? (λ ext → ⟦⟷⟧↔ ext (One-sided.StepC _[_]↝₁_) (One-sided.StepC _[_]↝₂_)) ext ⟩□

  ⟦ StepC ⟧ R pq                                □
  where
  lemma : _ ↔ _
  lemma = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ s → One-sided.⟨ Step.left-to-right s ⟩
                     , One-sided.⟨ Step.right-to-left s ⟩
        ; from = λ { (lr , rl) →
                     Temporarily-private.⟨ One-sided.Step.challenge lr
                                         , One-sided.Step.challenge rl
                                         ⟩
                   }
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    }

-- A variant of the previous lemma, stated for StepC′ instead of
-- StepC.

Step↔StepC′ :
  ∀ {k r} {R : Rel₂ r Proc} {pq} →
  Extensionality? k ℓ (ℓ ⊔ r) →
  Step R pq ↝[ k ] ⟦ StepC′ ⟧ R pq
Step↔StepC′ {R = R} {pq} ext =
  Step R pq        ↝⟨ Step↔StepC   ext ⟩
  ⟦ StepC  ⟧ R pq  ↝⟨ StepC↔StepC′ ext ⟩□
  ⟦ StepC′ ⟧ R pq  □

module StepC {r} {R : Rel₂ r Proc} {p q} where

  -- A "constructor".

  ⟨_,_⟩ :
    (∀ {p′ μ} → p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]↝₁ q′ × R (p′ , q′)) →
    (∀ {q′ μ} → q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]↝₂ p′ × R (p′ , q′)) →
    ⟦ StepC ⟧ R (p , q)
  ⟨ lr , rl ⟩ = _⇔_.to (Step↔StepC _) Temporarily-private.⟨ lr , rl ⟩

  -- Some "projections".

  left-to-right :
    ⟦ StepC ⟧ R (p , q) →
    ∀ {p′ μ} → p [ μ ]⟶ p′ → ∃ λ q′ → q [ μ ]↝₁ q′ × R (p′ , q′)
  left-to-right = Step.left-to-right ∘ _⇔_.from (Step↔StepC _)

  right-to-left :
    ⟦ StepC ⟧ R (p , q) →
    ∀ {q′ μ} → q [ μ ]⟶ q′ → ∃ λ p′ → p [ μ ]↝₂ p′ × R (p′ , q′)
  right-to-left = Step.right-to-left ∘ _⇔_.from (Step↔StepC _)

open Temporarily-private public


{-# OPTIONS --without-K #-}
open import Equivalence

module PathStructure.Id.Ap {a b} {A : Set a} {B : Set b}
  (f : A → B) (qi : qinv f) where

open import Functoriality
open import GroupoidStructure
open import Homotopy
open import PathOperations
open import Types

private
  g = π₁ qi
  α = π₁ (π₂ qi)
  β = π₂ (π₂ qi)

split-path : {a a′ : A} → a ≡ a′ → f a ≡ f a′
split-path = ap f

merge-path : {a a′ : A} → f a ≡ f a′ → a ≡ a′
merge-path p = β _ ⁻¹ · ap g p · β _

F : (b b′ : B) (p : b ≡ b′) → Set _
F b b′ p =
    ap f (β (g b) ⁻¹ · ap g (ap (f ∘ g) p) · β (g b′))
  ≡ ap (f ∘ g) p

F-lemma : ∀ b → F b b refl
F-lemma b = ap (ap f)
    ( ap (λ y → β (g b) ⁻¹ · y)
       (id·p _)
    · p⁻¹·p (β (g b))
    )

ap-β-lem : ∀ a → ap (g ∘ f) (β a) ≡ β (g (f a))
ap-β-lem a
  = p·id _ ⁻¹
  · ap (λ y → ap (g ∘ f) (β a) · y)
    (p·p⁻¹ (β a) ⁻¹)
  · p·q·r (ap (g ∘ f) (β a)) (β a) (β a ⁻¹)
  · ap (λ y → y · β a ⁻¹)
    (naturality _ _ β (β a) ⁻¹)
  · ap (λ y → (β (g (f a)) · y) · β a ⁻¹)
    (ap-id _)
  · p·q·r (β (g (f a))) (β a) (β a ⁻¹) ⁻¹
  · ap (λ y → β (g (f a)) · y)
    (p·p⁻¹ (β a))
  · p·id _

add-right : ∀ {a} {A : Set a} {a₁ a₂ a₃ : B} (p q : a₁ ≡ a₂) (r : a₂ ≡ a₃) →
  (p ≡ q) ≡ (p · r ≡ q · r)
add-right {a₁ = a₁} p q r = J
  (λ a₂ _ r → (p q : a₁ ≡ a₂) → (p ≡ q) ≡ (p · r ≡ q · r))
  (λ _ p q →
    tr    (λ x → (p ≡ q) ≡ (p · refl ≡ x)) (p·id q ⁻¹)
      (tr (λ x → (p ≡ q) ≡ (x        ≡ q)) (p·id p ⁻¹) refl))
  _ _ r p q

add-left : ∀ {a} {A : Set a} {a₁ a₂ a₃ : B} (p q : a₂ ≡ a₃) (r : a₁ ≡ a₂) →
  (p ≡ q) ≡ (r · p ≡ r · q)
add-left {a₃ = a₃} p q r = J
  (λ _ a₂ r → (p q : a₂ ≡ a₃) → (p ≡ q) ≡ (r · p ≡ r · q))
  (λ _ p q →
    tr    (λ x → (p ≡ q) ≡ (refl · p ≡ x)) (id·p q ⁻¹)
      (tr (λ x → (p ≡ q) ≡ (x        ≡ q)) (id·p p ⁻¹) refl))
  _ _ r p q

F-tr : ∀ a a′ (q : f a ≡ f a′) →
  F (f a) (f a′) q ≡ (ap f (β a ⁻¹ · ap g q · β a′) ≡ q)
F-tr a a′ q =
 ( add-left  {A = A}
   (ap f (β a ⁻¹ · ap g q · β a′)) q (α (f a))
 · add-right {A = A}
   (α (f a) · ap f (β a ⁻¹ · ap g q · β a′)) (α (f a) · q) (α (f a′) ⁻¹)
 · ap (λ x → (α (f a) · ap f (β a ⁻¹ · ap g q · β a′)) · α (f a′) ⁻¹ ≡ x)
   ( ap (λ y → (α (f a) · y) · α (f a′) ⁻¹)
     (ap-id _ ⁻¹)
   · ap (λ y → y · α (f a′) ⁻¹)
     (naturality _ _ α q)
   · p·q·r (ap (f ∘ g) q) (α (f a′)) (α (f a′) ⁻¹) ⁻¹
   · ap (λ y → ap (f ∘ g) q · y)
     (p·p⁻¹ (α (f a′)))
   · p·id _
   )
 · ap (λ x → x ≡ ap (f ∘ g) q)
   ( ap (λ y → (α (f a) · y) · α (f a′) ⁻¹)
     (ap-id _ ⁻¹)
   · ap (λ y → y · α (f a′) ⁻¹)
     (naturality _ _ α (ap f (β a ⁻¹ · ap g q · β a′)))
   · p·q·r (ap (f ∘ g) (ap f (β a ⁻¹ · ap g q · β a′)))
     (α (f a′)) (α (f a′) ⁻¹) ⁻¹
   · ap (λ y → ap (f ∘ g) (ap f (β a ⁻¹ · ap g q · β a′)) · y)
     (p·p⁻¹ (α (f a′)))
   · p·id _
   · ap-∘ f g (ap f (β a ⁻¹ · ap g q · β a′))
   · ap (ap f)
     ( ap-∘ g f (β a ⁻¹ · ap g q · β a′) ⁻¹
     · ap· (g ∘ f) (β a ⁻¹) (ap g q · β a′)
     · ap (λ y → ap (g ∘ f) (β a ⁻¹) · y)
       (ap· (g ∘ f) (ap g q) (β a′))
     · ap (λ y → y · ap (g ∘ f) (ap g q) · ap (g ∘ f) (β a′))
       (ap⁻¹ (g ∘ f) (β a))
     · ap (λ y → y ⁻¹ · ap (g ∘ f) (ap g q) · ap (g ∘ f) (β a′))
       (ap-β-lem a)
     · ap (λ y → β (g (f a)) ⁻¹ · ap (g ∘ f) (ap g q) · y)
       (ap-β-lem a′)
     · ap (λ y → β (g (f a)) ⁻¹ · y · β (g (f a′)))
       ( ap-∘ g f (ap g q)
       · ap (ap g)
         (ap-∘ f g q ⁻¹)
       )
     )
   )
 ) ⁻¹

proof-F : {a a′ : A} → split-path ∘ merge-path {a} {a′} ∼ id
proof-F p = tr id (F-tr _ _ p) (J F F-lemma _ _ p)

-- Copied from HoTT book, theorem 2.11.1.
proof-direct : {a a′ : A} → split-path ∘ merge-path {a} {a′} ∼ id
proof-direct {a} {a′} p
  = ap (ap f)
    (p·q·r (β a ⁻¹) (ap g p) (β a′))
  · id·p _ ⁻¹
  · ap (λ y → y · ap f ((β a ⁻¹ · ap g p) · β a′))
    (p⁻¹·p (α (f a)) ⁻¹)
  · p·q·r (α (f a) ⁻¹) (α (f a)) (ap f ((β a ⁻¹ · ap g p) · β a′)) ⁻¹
  · ap (λ y → α (f a) ⁻¹ · α (f a) · y)
    (ap-id _ ⁻¹)
  · ap (λ y → α (f a) ⁻¹ · y)
    (naturality _ _ α (ap f ((β a ⁻¹ · ap g p) · β a′)))
  · ap (λ y → α (f a) ⁻¹ · y · α (f a′))
    ( ap-∘ f g (ap f ((β a ⁻¹ · ap g p) · β a′))
    · ap (ap f)
      ( ap-∘ g f ((β a ⁻¹ · ap g p) · β a′) ⁻¹
      · p·id _ ⁻¹
      · ap (λ y → ap (g ∘ f) ((β a ⁻¹ · ap g p) · β a′) · y)
        (p·p⁻¹ (β a′) ⁻¹)
      · p·q·r (ap (g ∘ f) ((β a ⁻¹ · ap g p) · β a′)) (β a′) (β a′ ⁻¹)
      · ap (λ y → y · β a′ ⁻¹)
        ( naturality _ _ β ((β a ⁻¹ · ap g p) · β a′) ⁻¹
        · ap (λ y → β a · y)
          (ap-id _)
        )
      · ap (λ y → y · β a′ ⁻¹)
        (p·q·r (β a) (β a ⁻¹ · ap g p) (β a′))
      · p·q·r (β a · β a ⁻¹ · ap g p) (β a′) (β a′ ⁻¹) ⁻¹
      · ap (λ y → (β a · β a ⁻¹ · ap g p) · y)
        (p·p⁻¹ (β a′))
      · p·id _
      · p·q·r (β a) (β a ⁻¹) (ap g p)
      · ap (λ y → y · ap g p)
        (p·p⁻¹ (β a))
      · id·p _
      )
    · ap-∘ f g p ⁻¹
    )
  · ap (λ y → α (f a) ⁻¹ · y)
    (naturality _ _ α p ⁻¹)
  · p·q·r (α (f a) ⁻¹) (α (f a)) (ap id p)
  · ap (λ y → y · ap id p)
    (p⁻¹·p (α (f a)))
  · ap-id _

split-merge-eq : {a a′ : A} → (a ≡ a′) ≃ (f a ≡ f a′)
split-merge-eq
  = split-path
  , (merge-path , proof-F)
  , (merge-path , J
      (λ _ _ p → merge-path (split-path p) ≡ p)
      (λ _ → p⁻¹·p (β _))
      _ _)


module Luau.Heap where

open import Agda.Builtin.Equality using (_≡_)
open import FFI.Data.Maybe using (Maybe; just)
open import FFI.Data.Vector using (Vector; length; snoc; empty)
open import Luau.Addr using (Addr)
open import Luau.Var using (Var)
open import Luau.Syntax using (Block; Expr; Annotated; FunDec; nil; addr; function_is_end)

data HeapValue (a : Annotated) : Set where
  function_is_end : FunDec a → Block a → HeapValue a

Heap : Annotated → Set
Heap a = Vector (HeapValue a)

data _≡_⊕_↦_ {a} : Heap a → Heap a → Addr → HeapValue a → Set where

  defn : ∀ {H val} →

    -----------------------------------
    (snoc H val) ≡ H ⊕ (length H) ↦ val

_[_] : ∀ {a} → Heap a → Addr → Maybe (HeapValue a)
_[_] = FFI.Data.Vector.lookup

∅ : ∀ {a} → Heap a
∅ = empty

data AllocResult a (H : Heap a) (V : HeapValue a) : Set where
  ok : ∀ b H′ → (H′ ≡ H ⊕ b ↦ V) → AllocResult a H V

alloc : ∀ {a} H V → AllocResult a H V
alloc H V = ok (length H) (snoc H V) defn

next : ∀ {a} → Heap a → Addr
next = length

allocated : ∀ {a} → Heap a → HeapValue a → Heap a
allocated = snoc

-- next-emp : (length ∅ ≡ 0)
next-emp = FFI.Data.Vector.length-empty

-- lookup-next : ∀ V H → (lookup (allocated H V) (next H) ≡ just V)
lookup-next = FFI.Data.Vector.lookup-snoc

-- lookup-next-emp : ∀ V → (lookup (allocated emp V) 0 ≡ just V)
lookup-next-emp = FFI.Data.Vector.lookup-snoc-empty


{- Terms of the language.
   Based on Pfenning and Davies' "Judgmental reconstruction of modal logic."
-}
module Syntax.Terms where

open import Syntax.Types
open import Syntax.Context

mutual
    -- Pure terms of the language, expressed as typing judgements
    infix 10 _⊢_
    data _⊢_ : Context -> Judgement -> Set where
        -- | Simply typed lambda calculus
        -- Variables
        var : ∀{Γ A}            ->                   A ∈ Γ
                                                    -------
                                ->                   Γ ⊢ A

        -- Lambda abstraction
        lam : ∀{Γ A B}          ->             Γ , A now ⊢ B now
                                              -------------------
                                ->               Γ ⊢ A => B now

        -- Application
        _$_ : ∀{Γ A B}          ->         Γ ⊢ A => B now  ->   Γ ⊢ A now
                                          -------------------------------
                                ->                  Γ ⊢ B now

        -- | Basic data types
        -- Unit                                  ---------------
        unit : ∀{Γ}             ->                Γ ⊢ Unit now

        -- Pair of two terms
        [_,,_] : ∀{Γ A B}       ->          Γ ⊢ A now   ->   Γ ⊢ B now
                                        ----------------------------
                                ->                 Γ ⊢ A & B now

        -- First projection
        fst : ∀{Γ A B}          ->                 Γ ⊢ A & B now
                                                  ---------------
                                ->                   Γ ⊢ A now

        -- Second projection
        snd : ∀{Γ A B}          ->                 Γ ⊢ A & B now
                                                  ---------------
                                ->                   Γ ⊢ B now

        -- Left injection
        inl : ∀{Γ A B}          ->                   Γ ⊢ A now
                                                  ---------------
                                ->                 Γ ⊢ A + B now

        -- Right injection
        inr : ∀{Γ A B}          ->                   Γ ⊢ B now
                                                  ---------------
                                ->                 Γ ⊢ A + B now

        -- Case split
        case_inl↦_||inr↦_ : ∀{Γ A B C}
                                ->                 Γ ⊢ A + B now
                                ->    Γ , A now ⊢ C now  ->   Γ , B now ⊢ C now
                                     -------------------------------------------
                                ->                   Γ ⊢ C now

        -- | Modal operators
        -- A stable type can be sampled now
        sample : ∀{A Γ}         ->                 Γ ⊢ A always
                                                  --------------
                                ->                   Γ ⊢ A now

        -- Types in stable contexts are always inhabited
        stable : ∀{Γ A}         ->                 Γ ˢ ⊢ A now
                                                  --------------
                                ->                 Γ ⊢ A always

        -- Signal constructor
        sig : ∀{Γ A}            ->                Γ ⊢ A always
                                               ------------------
                                ->              Γ ⊢ Signal A now

        -- Signal destructor
        letSig_In_ : ∀{Γ A B}   ->   Γ ⊢ Signal A now  ->   Γ , A always ⊢ B now
                                    ----------------------------------------
                                ->                 Γ ⊢ B now

        -- Event constructor
        event : ∀{Γ A}          ->                 Γ ⊨ A now
                                               ------------------
                                ->              Γ ⊢ Event A now

    -- Computational terms of the language
    infix 10 _⊨_
    data _⊨_ : Context -> Judgement -> Set where
        -- Pure term is a computational term
        pure : ∀{A Γ}           ->                   Γ ⊢ A
                                                    -------
                                ->                   Γ ⊨ A

        -- Computational signal destructor
        letSig_InC_ : ∀{Γ A B}  ->   Γ ⊢ Signal A now   ->   Γ , A always ⊨ B now
                                    ----------------------------------------------
                                ->                 Γ ⊨ B now

        -- Event destructor
        letEvt_In_ : ∀{Γ A B}   ->   Γ ⊢ Event A now  ->   Γ ˢ , A now  ⊨ B now
                                    --------------------------------------------
                                ->                 Γ ⊨ B now

        -- Select the event that happens first
        select_↦_||_↦_||both↦_ : ∀{Γ A B C}
            ->   Γ ⊢ Event A now  ->  Γ ˢ , A now , Event B now ⊨ C now   -- A happens first
            ->   Γ ⊢ Event B now  ->  Γ ˢ , Event A now , B now ⊨ C now   -- B happens first
            ->             Γ ˢ , A now , B now ⊨ C now                    -- A and B happen at the same time
                -------------------------------------------------
            ->                  Γ ⊨ C now


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Path where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Reflection.StrictEquiv

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ

-- Less polymorphic version of `cong`, to avoid some unresolved metas
cong′ : ∀ {B : Type ℓ'} (f : A → B) {x y : A} (p : x ≡ y)
      → Path B (f x) (f y)
cong′ f = cong f
{-# INLINE cong′ #-}

PathP≡Path : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) →
             PathP P p q ≡ Path (P i1) (transport (λ i → P i) p) q
PathP≡Path P p q i = PathP (λ j → P (i ∨ j)) (transport-filler (λ j → P j) p i) q

PathP≡Path⁻ : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) →
             PathP P p q ≡ Path (P i0) p (transport⁻ (λ i → P i) q)
PathP≡Path⁻ P p q i = PathP (λ j → P (~ i ∧ j)) p (transport⁻-filler (λ j → P j) q i)

PathP≃Path : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) →
             PathP P p q ≃ Path (P i1) (transport (λ i → P i) p) q
PathP≃Path P p q = transportEquiv (PathP≡Path P p q)

-- Alternative more unfolded proof
toPathP-isEquiv : ∀ (A : I → Type ℓ) {x y} → isEquiv (toPathP {A = A} {x} {y})
toPathP-isEquiv A {x} {y} = isoToIsEquiv (iso toPathP fromPathP to-from from-to)
 where
   to-from : ∀ (p : PathP A x y) → toPathP (fromPathP p) ≡ p
   to-from p h i = outS (hcomp-unique (λ { j (i = i0) → x ; j (i = i1) → fromPathP p j })
                                  (inS (transp (λ j → A (i ∧ j)) (~ i) x))
                                  \ h → inS (sq1 h i))
                        h
      where
        sq1 : (\ h → A [ x ≡ transp (\ j → A (h ∨ j)) h (p h) ]) [ (\ i → transp (λ j → A (i ∧ j)) (~ i) x) ≡ p ]
        sq1 = \ h i → comp (\ z → (hcomp (\ w →
                                                    \ { (z = i1) → A (i ∧ (w ∨ h))
                                                      ; (z = i0) → A (i ∧ h)
                                                      ; (i = i0) → A i0
                                                      ; (i = i1) → A (h ∨ (w ∧ z))
                                                      ; (h = i0) → A (i ∧ (w ∧ z))
                                                      ; (h = i1) → A i})
                                                   ((A (i ∧ h)))))
                                          (\ z → \ { (i = i0) → x
                                                   ; (i = i1) → transp (\ j → A (h ∨ (z ∧ j))) (h ∨ ~ z) (p h)
                                                   ; (h = i0) → transp (λ j → A ((i ∧ z) ∧ j)) (~ (i ∧ z)) x
                                                   ; (h = i1) → p i })
                                (p (i ∧ h))
   from-to : ∀ (q : transp (\ i → A i) i0 x ≡ y) → fromPathP (toPathP {A = A} q) ≡ q
   from-to q = (\ h i → outS (transp-hcomp i {A' = A i1} (\ j → inS (A (i ∨ j)))
                                           ((λ { j (i = i0) → x ; j (i = i1) → q j }))
                                           (inS ((transp (λ j → A (i ∧ j)) (~ i) x))))
                             h)
             ∙ (\ h i → outS (hcomp-unique {A = A i1} ((λ { j (i = i0) → transp (\ i → A i) i0 x ; j (i = i1) → q j }))
                                      (inS ((transp (λ j → A (i ∨ j)) i (transp (λ j → A (i ∧ j)) (~ i) x))))
                                      \ h → inS (sq2 h i))
                             h)
             ∙ sym (lUnit q)
     where
       sq2 : (\ h → transp (\ i → A i) i0 x ≡ q h) [ (\ i → transp (\ j → A (i ∨ j)) i (transp (\ j → A (i ∧ j)) (~ i) x)) ≡ refl ∙ q ]
       sq2 = \ h i → comp (\ z → hcomp (\ w → \ { (i = i1) → A i1
                                              ; (i = i0) → A (h ∨ (w ∧ z))
                                              ; (h = i0) → A (i ∨ (w ∧ z))
                                              ; (h = i1) → A i1
                                              ; (z = i0) → A (i ∨ h)
                                              ; (z = i1) → A ((i ∨ h) ∨ w) })
                                             (A (i ∨ h)))
                 (\ z → \ { (i = i0) → transp (λ j → A ((z ∨ h) ∧ j)) (~ z ∧ ~ h) x
                          ; (i = i1) → q (z ∧ h)
                          ; (h = i1) → compPath-filler refl q z i
                          ; (h = i0) → transp (\ j → A (i ∨ (z ∧ j))) (i ∨ ~ z) (transp (\ j → A (i ∧ j)) (~ i) x)
                          })
                          (transp (\ j → A ((i ∨ h) ∧ j)) (~ (i ∨ h)) x)

PathP≡compPath : ∀ {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : y ≡ z) (r : x ≡ z)
                 → (PathP (λ i → x ≡ q i) p r) ≡ (p ∙ q ≡ r)
PathP≡compPath p q r k = PathP (λ i → p i0 ≡ q (i ∨ k)) (λ j → compPath-filler p q k j) r

PathP≡doubleCompPathˡ : ∀ {A : Type ℓ} {w x y z : A} (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z)
                        → (PathP (λ i → p i ≡ s i) q r) ≡ (p ⁻¹ ∙∙ q ∙∙ s ≡ r)
PathP≡doubleCompPathˡ p q r s k = PathP (λ i → p (i ∨ k) ≡ s (i ∨ k))
                                        (λ j → doubleCompPath-filler (p ⁻¹) q s k j) r

PathP≡doubleCompPathʳ : ∀ {A : Type ℓ} {w x y z : A} (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z)
                        → (PathP (λ i → p i ≡ s i) q r) ≡ (q ≡ p ∙∙ r ∙∙ s ⁻¹)
PathP≡doubleCompPathʳ p q r s k  = PathP (λ i → p (i ∧ (~ k)) ≡ s (i ∧ (~ k)))
                                         q (λ j → doubleCompPath-filler p r (s ⁻¹) k j)

compPathl-cancel : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : x ≡ z) → p ∙ (sym p ∙ q) ≡ q
compPathl-cancel p q = p ∙ (sym p ∙ q) ≡⟨ assoc p (sym p) q ⟩
                       (p ∙ sym p) ∙ q ≡⟨ cong (_∙ q) (rCancel p) ⟩
                              refl ∙ q ≡⟨ sym (lUnit q) ⟩
                                     q ∎

compPathr-cancel : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : z ≡ y) (q : x ≡ y) → (q ∙ sym p) ∙ p ≡ q
compPathr-cancel {x = x} p q i j =
  hcomp-equivFiller (doubleComp-faces (λ _ → x) (sym p) j) (inS (q j)) (~ i)

compPathl-isEquiv : {x y z : A} (p : x ≡ y) → isEquiv (λ (q : y ≡ z) → p ∙ q)
compPathl-isEquiv p = isoToIsEquiv (iso (p ∙_) (sym p ∙_) (compPathl-cancel p) (compPathl-cancel (sym p)))

compPathlEquiv : {x y z : A} (p : x ≡ y) → (y ≡ z) ≃ (x ≡ z)
compPathlEquiv p = (p ∙_) , compPathl-isEquiv p

compPathr-isEquiv : {x y z : A} (p : y ≡ z) → isEquiv (λ (q : x ≡ y) → q ∙ p)
compPathr-isEquiv p = isoToIsEquiv (iso (_∙ p) (_∙ sym p) (compPathr-cancel p) (compPathr-cancel (sym p)))

compPathrEquiv : {x y z : A} (p : y ≡ z) → (x ≡ y) ≃ (x ≡ z)
compPathrEquiv p = (_∙ p) , compPathr-isEquiv p

-- Variations of isProp→isSet for PathP
isProp→SquareP : ∀ {B : I → I → Type ℓ} → ((i j : I) → isProp (B i j))
             → {a : B i0 i0} {b : B i0 i1} {c : B i1 i0} {d : B i1 i1}
             → (r : PathP (λ j → B j i0) a c) (s : PathP (λ j → B j i1) b d)
             → (t : PathP (λ j → B i0 j) a b) (u : PathP (λ j → B i1 j) c d)
             → SquareP B t u r s
isProp→SquareP {B = B} isPropB {a = a} r s t u i j =
  hcomp (λ { k (i = i0) → isPropB i0 j (base i0 j) (t j) k
           ; k (i = i1) → isPropB i1 j (base i1 j) (u j) k
           ; k (j = i0) → isPropB i i0 (base i i0) (r i) k
           ; k (j = i1) → isPropB i i1 (base i i1) (s i) k
        }) (base i j) where
    base : (i j : I) → B i j
    base i j = transport (λ k → B (i ∧ k) (j ∧ k)) a

isProp→isPropPathP : ∀ {ℓ} {B : I → Type ℓ} → ((i : I) → isProp (B i))
                   → (b0 : B i0) (b1 : B i1)
                   → isProp (PathP (λ i → B i) b0 b1)
isProp→isPropPathP {B = B} hB b0 b1 = isProp→SquareP (λ _ → hB) refl refl

isProp→isContrPathP : {A : I → Type ℓ} → (∀ i → isProp (A i))
                    → (x : A i0) (y : A i1)
                    → isContr (PathP A x y)
isProp→isContrPathP h x y = isProp→PathP h x y , isProp→isPropPathP h x y _

-- Flipping a square along its diagonal

flipSquare : {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁}
  {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁}
  {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁}
  → Square a₀₋ a₁₋ a₋₀ a₋₁ → Square a₋₀ a₋₁ a₀₋ a₁₋
flipSquare sq i j = sq j i

module _ {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁} {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁}
  {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁}
  where

  flipSquareEquiv : Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ Square a₋₀ a₋₁ a₀₋ a₁₋
  unquoteDef flipSquareEquiv = defStrictEquiv flipSquareEquiv flipSquare flipSquare

  flipSquarePath : Square a₀₋ a₁₋ a₋₀ a₋₁ ≡ Square a₋₀ a₋₁ a₀₋ a₁₋
  flipSquarePath = ua flipSquareEquiv

module _ {a₀₀ a₁₁ : A} {a₋ : a₀₀ ≡ a₁₁}
  {a₁₀ : A} {a₁₋ : a₁₀ ≡ a₁₁} {a₋₀ : a₀₀ ≡ a₁₀} where

  slideSquareFaces : (i j k : I) → Partial (i ∨ ~ i ∨ j ∨ ~ j) A
  slideSquareFaces i j k (i = i0) = a₋ (j ∧ ~ k)
  slideSquareFaces i j k (i = i1) = a₁₋ j
  slideSquareFaces i j k (j = i0) = a₋₀ i
  slideSquareFaces i j k (j = i1) = a₋ (i ∨ ~ k)

  slideSquare : Square a₋ a₁₋ a₋₀ refl → Square refl a₁₋ a₋₀ a₋
  slideSquare sq i j = hcomp (slideSquareFaces i j) (sq i j)

  slideSquareEquiv : (Square a₋ a₁₋ a₋₀ refl) ≃ (Square refl a₁₋ a₋₀ a₋)
  slideSquareEquiv = isoToEquiv (iso slideSquare slideSquareInv fillerTo fillerFrom) where
    slideSquareInv : Square refl a₁₋ a₋₀ a₋ → Square a₋ a₁₋ a₋₀ refl
    slideSquareInv sq i j = hcomp (λ k → slideSquareFaces i j (~ k)) (sq i j)
    fillerTo : ∀ p → slideSquare (slideSquareInv p) ≡ p
    fillerTo p k i j = hcomp-equivFiller (λ k → slideSquareFaces i j (~ k)) (inS (p i j)) (~ k)
    fillerFrom : ∀ p → slideSquareInv (slideSquare p) ≡ p
    fillerFrom p k i j = hcomp-equivFiller (slideSquareFaces i j) (inS (p i j)) (~ k)

-- The type of fillers of a square is equivalent to the double composition identites
Square≃doubleComp : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
                    (a₀₋ : a₀₀ ≡ a₀₁) (a₁₋ : a₁₀ ≡ a₁₁)
                    (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁)
                    → Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ (a₋₀ ⁻¹ ∙∙ a₀₋ ∙∙ a₋₁ ≡ a₁₋)
Square≃doubleComp a₀₋ a₁₋ a₋₀ a₋₁ = transportEquiv (PathP≡doubleCompPathˡ a₋₀ a₀₋ a₁₋ a₋₁)

-- sym induces an equivalence on identity types of paths
symIso : {a b : A} (p q : a ≡ b) → Iso (p ≡ q) (q ≡ p)
symIso p q = iso sym sym (λ _ → refl) λ _ → refl


------------------------------------------------------------------------
-- Well-typed substitutions
------------------------------------------------------------------------

module Data.Fin.Substitution.Typed where

open import Data.Fin using (Fin; zero; suc)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Unit using (⊤; tt)
open import Data.Vec as Vec using (Vec; []; _∷_; map)
open import Data.Vec.All as All
  using (All; All₂; []; _∷_; map₂)
open import Data.Vec.All.Properties
  using (gmap; gmap₂; gmap₂₁; gmap₂₂)
open import Data.Vec.Properties using (lookup-map)
open import Function as Fun using (_∘_; flip)
open import Relation.Binary.PropositionalEquality as PropEq hiding (trans)
open PropEq.≡-Reasoning

------------------------------------------------------------------------
-- Abstract typing contexts and well-typedness relations

-- Abstract typing contexts over T-types.
--
-- A typing context Ctx T n maps n free variables to T-types
-- containing up to n free variables each.
module Context (T : ℕ → Set) where

  infixr 5 _∷_

  -- Typing contexts.
  data Ctx : ℕ → Set where
    []  :                       Ctx 0
    _∷_ : ∀ {n} → T n → Ctx n → Ctx (1 + n)

  -- Operations on contexts that require weakening of types.
  record WeakenOps : Set where

    -- Weakening of types.
    field weaken : ∀ {n} → T n → T (1 + n)

    -- Convert a context to its vector representation.
    toVec : ∀ {n} → Ctx n → Vec (T n) n
    toVec []      = []
    toVec (a ∷ Γ) = weaken a ∷ map weaken (toVec Γ)

    -- Lookup the type of a variable in a context.
    lookup : ∀ {n} → Fin n → Ctx n → T n
    lookup x = Vec.lookup x ∘ toVec

open Context

-- Abstract typings.
--
-- An abtract typing _⊢_∈_ : Typing Tp₁ Tm Tp₂ is a ternary relation
-- which, in a given Tp₁-context, relates Tm-terms to their Tp₂-types.
Typing : (ℕ → Set) → (ℕ → Set) → (ℕ → Set) → Set₁
Typing Tp₁ Tm Tp₂ = ∀ {n} → Ctx Tp₁ n → Tm n → Tp₂ n → Set

-- Abstract well-formedness.
--
-- An abtract well-formedness relation _⊢_wf : Wf Tp is a binary
-- relation which, in a given Tp-context, asserts the well-formedness
-- of Tp-types.
Wf : (ℕ → Set) → Set₁
Wf Tp = ∀ {n} → Ctx Tp n → Tp n → Set

-- Well-formed contexts.
--
-- A well-formed typing context (Γ wf) is a context Γ in which every
-- participating T-type is well-formed.
module WellFormedContext {T} (_⊢_wf : Wf T) where
  infix  4 _wf
  infixr 5 _∷_

  -- Well-formed typing contexts.
  data _wf : ∀ {n} → Ctx T n → Set where
    []  :                                              [] wf
    _∷_ : ∀ {n a} {Γ : Ctx T n} → Γ ⊢ a wf → Γ wf → a ∷ Γ wf

  -- Inversions.

  wf-∷₁ : ∀ {n} {Γ : Ctx T n} {a} → a ∷ Γ wf → Γ ⊢ a wf
  wf-∷₁ (a-wf ∷ _) = a-wf

  wf-∷₂ : ∀ {n} {Γ : Ctx T n} {a} → a ∷ Γ wf → Γ wf
  wf-∷₂ (_ ∷ Γ-wf) = Γ-wf

  -- Operations on well-formed contexts that require weakening of
  -- well-formedness judgments.
  record WfWeakenOps (weakenOps : WeakenOps T) : Set₁ where
    private module W = WeakenOps weakenOps

    field
      -- Weakening of well-formedness judgments.
      weaken : ∀ {n} {Γ : Ctx T n} {a b} → Γ ⊢ a wf → Γ ⊢ b wf →
               (a ∷ Γ) ⊢ W.weaken b wf

    -- Convert a well-formed context to its All representation.
    toAll : ∀ {n} {Γ : Ctx T n} → Γ wf → All (λ a → Γ ⊢ a wf) (W.toVec Γ)
    toAll []         = []
    toAll (a-wf ∷ Γ) = weaken a-wf a-wf ∷ gmap (weaken  a-wf) (toAll Γ)

    -- Lookup the well-formedness proof of a variable in a context.
    lookup : ∀ {n} {Γ : Ctx T n} → (x : Fin n) → Γ wf → Γ ⊢ (W.lookup x Γ) wf
    lookup x = All.lookup x ∘ toAll

-- Trivial well-formedness.
--
-- This module provides a trivial well-formedness relation and the
-- corresponding trivially well-formed contexts.  This is useful when
-- implmenting typed substitutions on types that either lack or do not
-- necessitate a notion well-formedness.
module ⊤-WellFormed {T} (weakenOps : WeakenOps T) where

  infix  4 _⊢_wf

  -- Trivial well-formedness.
  _⊢_wf : Wf T
  _ ⊢ _ wf = ⊤

  open WellFormedContext _⊢_wf public

  -- Trivial well-formedness of contexts.
  ctx-wf : ∀ {n} (Γ : Ctx T n) → Γ wf
  ctx-wf []      = []
  ctx-wf (a ∷ Γ) = tt ∷ ctx-wf Γ

  module ⊤-WfWeakenOps  where

    wfWeakenOps : WfWeakenOps weakenOps
    wfWeakenOps = record { weaken = λ _ _ → tt }

    open WfWeakenOps public

------------------------------------------------------------------------
-- Abstract well-typed substitutions (i.e. substitution lemmas)

-- Abstract typed substitutions.
record TypedSub (Tp₁ Tp₂ Tm : ℕ → Set) : Set₁ where

  infix 4 _⊢_∈_ _⊢_wf

  field
    _⊢_∈_ : Typing Tp₂ Tm Tp₁   -- the associated typing
    _⊢_wf : Wf Tp₂              -- Tp₂-well-formedness

    -- Application of Tm-substitutions to (source) Tp₁-types
    application : Application Tp₁ Tm

    -- Operations on the contexts.
    weakenOps : WeakenOps Tp₁

  open Application       application       public using (_/_)
  open WeakenOps         weakenOps                using (toVec)
  open WellFormedContext _⊢_wf             public

  infix  4 _⇒_⊢_
  infixr 4 _,_

  -- Typed substitutions.
  --
  -- A typed substitution Γ ⇒ Δ ⊢ σ is a substitution σ which, when
  -- applied to something that is well-typed in a source context Γ,
  -- yields something well-typed in a well-formed target context Δ.
  data _⇒_⊢_ {m n} (Γ : Ctx Tp₁ m) (Δ : Ctx Tp₂ n) : Sub Tm m n → Set where
    _,_ : ∀ {σ} → All₂ (λ t a → Δ ⊢ t ∈ (a / σ)) σ (toVec Γ) → Δ wf → Γ ⇒ Δ ⊢ σ

  -- Project out the first component of a typed substitution.
  proj₁ : ∀ {m n} {Γ : Ctx Tp₁ m} {Δ : Ctx Tp₂ n} {σ : Sub Tm m n} →
          Γ ⇒ Δ ⊢ σ → All₂ (λ t a → Δ ⊢ t ∈ (a / σ)) σ (toVec Γ)
  proj₁ (σ-wt , _) = σ-wt

-- Abstract extensions of substitutions.
record ExtensionTyped {Tp₁ Tp₂ Tm} (extension : Extension Tm)
                      (typedSub : TypedSub Tp₁ Tp₂ Tm) : Set where

  open TypedSub typedSub
  private
    module E  = Extension extension
    module C  = WeakenOps weakenOps

  field

    -- Weakens well-typed Tm-terms.
    weaken : ∀ {n} {Δ : Ctx Tp₂ n} {t a b} → Δ ⊢ a wf → Δ ⊢ t ∈ b →
             a ∷ Δ ⊢ E.weaken t ∈ C.weaken b

    -- Weakening commutes with other substitutions.
    weaken-/ : ∀ {m n} {σ : Sub Tm m n} {t} a →
               C.weaken (a / σ) ≡ C.weaken a / (t E./∷ σ)

    -- Well-typedness implies well-formedness of contexts.
    wt-wf : ∀ {n} {Γ : Ctx Tp₂ n} {t a} → Γ ⊢ t ∈ a → Γ wf

  infixr 5 _/∷_

  -- Extension by a typed term.
  _/∷_ : ∀ {m n} {Γ : Ctx Tp₁ m} {Δ : Ctx Tp₂ n} {t a b σ} →
         b ∷ Δ ⊢ t ∈ C.weaken (a / σ) → Γ ⇒ Δ ⊢ σ →
         a ∷ Γ ⇒ b ∷ Δ ⊢ (t E./∷ σ)
  t∈a/σ /∷ (σ-wt , _) = σ-wt′ , wt-wf t∈a/σ
    where
      b∷Δ-wf = wt-wf t∈a/σ
      b-wf   = wf-∷₁ b∷Δ-wf
      t∈a/σ′ = subst (_⊢_∈_ _ _) (weaken-/ _) t∈a/σ
      σ-wt′  =
        t∈a/σ′ ∷ gmap₂ (subst (_⊢_∈_ _ _) (weaken-/ _) ∘ weaken b-wf) σ-wt

-- Abstract simple typed substitutions.
record SimpleTyped {Tp Tm} (simple : Simple Tm)
                   (typedSub : TypedSub Tp Tp Tm) : Set where

  open TypedSub typedSub
  private
    module S  = SimpleExt simple
    module L₀ = Lemmas₀   (record { simple = simple })
    module C  = WeakenOps weakenOps

  field
    extensionTyped : ExtensionTyped (record { weaken = S.weaken }) typedSub

    -- Takes variables to well-typed Tms.
    var : ∀ {n} {Γ : Ctx Tp n} (x : Fin n) → Γ wf → Γ ⊢ S.var x ∈ C.lookup x Γ

    -- Types are invariant under the identity substitution.
    id-vanishes : ∀ {n} (a : Tp n) → a / S.id ≡ a

    -- Relates weakening of types to weakening of Tms.
    /-wk : ∀ {n} {a : Tp n} → a / S.wk ≡ C.weaken a

    -- Single-variable substitution is a left-inverse of weakening.
    wk-sub-vanishes : ∀ {n t} (a : Tp n) → a / S.wk / S.sub t ≡ a

    -- Well-formedness of types implies well-formedness of contexts.
    wf-wf : ∀ {n} {Γ : Ctx Tp n} {a} → Γ ⊢ a wf → Γ wf

  open ExtensionTyped extensionTyped public

  infixl 10 _↑_

  -- Lifting.
  _↑_ : ∀ {m n} {Γ : Ctx Tp m} {Δ : Ctx Tp n} {σ} → Γ ⇒ Δ ⊢ σ →
        ∀ {a} → Δ ⊢ a / σ wf → a ∷ Γ ⇒ a / σ ∷ Δ ⊢ σ S.↑
  (σ-wt , Δ-wf) ↑ a/σ-wf = var zero (a/σ-wf ∷ Δ-wf) /∷ (σ-wt , Δ-wf)

  -- The identity substitution.
  id : ∀ {n} {Γ : Ctx Tp n} → Γ wf → Γ ⇒ Γ ⊢ S.id
  id             []            = [] , []
  id {Γ = a ∷ Γ} (a-wf ∷ Γ-wf) =
    subst₂ (λ Δ σ → a ∷ Γ ⇒ Δ ⊢ σ)
           (cong (flip _∷_ Γ) (id-vanishes a)) (L₀.id-↑⋆ 1)
           (id Γ-wf ↑ subst (_⊢_wf Γ) (sym (id-vanishes a)) a-wf)

  -- The first component of the identity substitution.
  private
    id₁ : ∀ {n} {Γ : Ctx Tp n} → Γ wf →
          All₂ (λ t a → Γ ⊢ t ∈ (a / S.id)) S.id (C.toVec Γ)
    id₁ = proj₁ ∘ id

  -- Weakening.
  wk : ∀ {n} {Γ : Ctx Tp n} {a} → Γ ⊢ a wf → Γ ⇒ a ∷ Γ ⊢ S.wk
  wk a-wf =
    gmap₂₁ (weaken′ a-wf ∘ subst (_⊢_∈_ _ _) (id-vanishes _)) (id₁ Γ-wf) ,
      a-wf ∷ Γ-wf
    where
      weaken′ : ∀ {n} {Γ : Ctx Tp n} {t a b} → Γ ⊢ a wf → Γ ⊢ t ∈ b →
                a ∷ Γ ⊢ S.weaken t ∈ b / S.wk
      weaken′ a-wf = subst (_⊢_∈_ _ _) (sym /-wk) ∘ weaken a-wf

      Γ-wf = wf-wf a-wf

  -- Some helper lemmas.
  private
    wk-sub-vanishes′ : ∀ {n a} {t : Tm n} → a ≡ C.weaken a / S.sub t
    wk-sub-vanishes′ {a = a} {t} = begin
      a                      ≡⟨ sym (wk-sub-vanishes a) ⟩
      a / S.wk / S.sub t     ≡⟨ cong (flip _/_ _) /-wk ⟩
      C.weaken a / S.sub t   ∎

    id-wk-sub-vanishes : ∀ {n a} {t : Tm n} →
                         a / S.id ≡ C.weaken a / S.sub t
    id-wk-sub-vanishes {a = a} {t} = begin
      a / S.id               ≡⟨ id-vanishes a ⟩
      a                      ≡⟨ wk-sub-vanishes′ ⟩
      C.weaken a / S.sub t   ∎

  -- A substitution which only replaces the first variable.
  sub : ∀ {n} {Γ : Ctx Tp n} {t a} → Γ ⊢ t ∈ a → a ∷ Γ ⇒ Γ ⊢ S.sub t
  sub t∈a =
    t∈a′ ∷ gmap₂₂ (subst (_⊢_∈_ _ _) id-wk-sub-vanishes) (id₁ Γ-wf) , Γ-wf
    where
      Γ-wf = wt-wf t∈a
      t∈a′ = subst (_⊢_∈_ _ _) wk-sub-vanishes′ t∈a

  -- A substitution which only changes the type of the first variable.
  tsub : ∀ {n} {Γ : Ctx Tp n} {a b} → b ∷ Γ ⊢ S.var zero ∈ C.weaken a →
         a ∷ Γ ⇒ b ∷ Γ ⊢ S.id
  tsub z∈a = z∈a′ /∷ id (wf-∷₂ (wt-wf z∈a))
    where
      z∈a′ = subst (_⊢_∈_ _ _) (cong C.weaken (sym (id-vanishes _))) z∈a

-- Abstract typed liftings from Tm₁ to Tm₂.
record LiftTyped {Tp Tm₁ Tm₂} (l : Lift Tm₁ Tm₂)
                 (typedSub : TypedSub Tp Tp Tm₁)
                 (_⊢₂_∈_   : Typing Tp Tm₂ Tp)   : Set where

  open TypedSub typedSub renaming (_⊢_∈_ to _⊢₁_∈_)
  private module L = Lift l

  -- The underlying well-typed simple Tm₁-substitutions.
  field simpleTyped : SimpleTyped L.simple typedSub

  open SimpleTyped simpleTyped public

  -- Lifts well-typed Tm₁-terms to well-typed Tm₂-terms.
  field lift : ∀ {n} {Γ : Ctx Tp n} {t a} → Γ ⊢₁ t ∈ a → Γ ⊢₂ (L.lift t) ∈ a

-- Abstract variable typings.
module VarTyping {Tp} (weakenOps : WeakenOps Tp) (_⊢_wf : Wf Tp) where
  open WeakenOps weakenOps
  open WellFormedContext _⊢_wf

  infix 4 _⊢Var_∈_

  -- Abstract reflexive variable typings.
  data _⊢Var_∈_ {n} (Γ : Ctx Tp n) : Fin n → Tp n → Set where
    var : ∀ x → Γ wf → Γ ⊢Var x ∈ lookup x Γ

-- Abstract typed variable substitutions (renamings).
record TypedVarSubst {Tp} (_⊢_wf : Wf Tp) : Set where
  field
    application : Application Tp Fin
    weakenOps   : WeakenOps Tp

  open WellFormedContext   _⊢_wf
  open VarTyping weakenOps _⊢_wf public

  typedSub : TypedSub Tp Tp Fin
  typedSub = record
    { _⊢_∈_       = _⊢Var_∈_
    ; _⊢_wf       = _⊢_wf
    ; application = application
    ; weakenOps   = weakenOps
    }

  open TypedSub typedSub public using () renaming (_⇒_⊢_ to _⇒_⊢Var_)

  open Application application       using (_/_)
  open Lemmas₄     VarLemmas.lemmas₄ using (id; wk; _⊙_)
  private module C = WeakenOps weakenOps

  field
    /-wk        : ∀ {n} {a : Tp n} → a / wk ≡ C.weaken a
    id-vanishes : ∀ {n} (a : Tp n) → a / id ≡ a
    /-⊙         : ∀ {m n k} {σ₁ : Sub Fin m n} {σ₂ : Sub Fin n k} a →
                  a / σ₁ ⊙ σ₂ ≡ a / σ₁ / σ₂
    wf-wf       : ∀ {n} {Γ : Ctx Tp n} {a} → Γ ⊢ a wf → Γ wf

  appLemmas : AppLemmas Tp Fin
  appLemmas = record
    { application = application
    ; lemmas₄     = VarLemmas.lemmas₄
    ; id-vanishes = id-vanishes
    ; /-⊙         = /-⊙
    }

  open ExtAppLemmas appLemmas using (wk-commutes; wk-sub-vanishes)
  open SimpleExt VarLemmas.simple using (extension; _/∷_)

  -- Extensions of renamings.
  extensionTyped : ExtensionTyped extension typedSub
  extensionTyped = record
    { weaken   = weaken
    ; weaken-/ = weaken-/
    ; wt-wf    = wt-wf
    }
    where
      weaken : ∀ {n} {Γ : Ctx Tp n} {x a b} → Γ ⊢ a wf → Γ ⊢Var x ∈ b →
               a ∷ Γ ⊢Var suc x ∈ C.weaken b
      weaken a-wf (var x Γ-wf) =
        subst (_⊢Var_∈_ _ _) (lookup-map x _ _)
              (var (suc x) (a-wf ∷ Γ-wf))

      weaken-/ : ∀ {m n} {σ : Sub Fin m n} {t} a →
                 C.weaken (a / σ) ≡ C.weaken a / (t /∷ σ)
      weaken-/ {σ = σ} {t} a = begin
        C.weaken (a / σ)        ≡⟨ sym /-wk ⟩
        a / σ / wk              ≡⟨ wk-commutes a ⟩
        a / wk / (t /∷ σ)       ≡⟨ cong₂ _/_ /-wk refl ⟩
        C.weaken a / (t /∷ σ)   ∎

      wt-wf : ∀ {n} {Γ : Ctx Tp n} {x a} → Γ ⊢Var x ∈ a → Γ wf
      wt-wf (var x Γ-wf) = Γ-wf

  -- Simple typed renamings.
  simpleTyped : SimpleTyped VarLemmas.simple typedSub
  simpleTyped = record
    { extensionTyped  = extensionTyped
    ; var             = var
    ; id-vanishes     = id-vanishes
    ; /-wk            = /-wk
    ; wk-sub-vanishes = wk-sub-vanishes
    ; wf-wf           = wf-wf
    }

  open SimpleTyped simpleTyped public
    hiding (extensionTyped; var; /-wk; id-vanishes; wk-sub-vanishes; wf-wf)


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference.Separator(x : X) where
  import OutsideIn.Constraints as C
  open C(x)
  open X(x)
  open import Data.List hiding (map)

  mutual
    data SeparatedConstraint (n : Set) : Shape → Set where
      SC : ∀ {s} → QConstraint n → Implications n s → SeparatedConstraint n s
    data Implications (n : Set) : Shape → Set where
      imp-ε : Implications n Nullary
      imp : ∀ {s} → Implication (λ n → SeparatedConstraint n s) n → Implications n (Unary s)
      _imp-∧_ : ∀ {s₁ s₂} →  Implications n s₁ → Implications n s₂ →  Implications n (Binary s₁ s₂)

  mutual
    data _simpl:_ {n : Set} : Constraint n Flat → QConstraint n → Set where
       Simpl-QC : ∀ {c} → QC c simpl: c
       Simpl-∧  : ∀ {a b}{a′ b′} → a simpl: a′ → b simpl: b′ → (a ∧′ b) simpl: (a′ ∧ b′)
       Simpl-Imp : ∀ {i} → Imp i simpl: ε
    data _separate:_,_ {n : Set} : Constraint n Flat → (r : Shape) → SeparatedConstraint n r → Set where
       Separate : ∀ {C}{Q}{r}{I} → C simpl: Q → C implic: r , I → C separate: r , SC Q I
    data _implic:_,_ {n : Set} : Constraint n Flat → (r : Shape) → Implications n r → Set where
       Implic-Qc : ∀ {c} → QC c implic: Nullary , imp-ε
       Implic-∧ : ∀{a b}{r₁ r₂}{a′}{b′} → a implic: r₁ , a′ → b implic: r₂ , b′ → (a ∧′ b) implic: Binary r₁ r₂ , (a′ imp-∧ b′)
       Implic-I : ∀{n}{Q}{C}{s}{v} → C separate: s , v → Imp (∃ n · Q ⊃ C) implic: Unary s , imp (∃ n · Q ⊃ v)

  simpl : ∀ {n} → (C : Constraint n Flat) → ∃ (λ Q → C simpl: Q)
  simpl (QC c) = _ , Simpl-QC
  simpl (a ∧′ b) with simpl a | simpl b
  ... | q₁ , p₁ | q₂ , p₂ = _ , Simpl-∧ p₁ p₂
  simpl (Imp _) = _ , Simpl-Imp

  separate : ∀ {n} → (C : Constraint n Flat) → ∃ (λ r → ∃ (λ S → C separate: r , S))
  implic : ∀ {n} → (C : Constraint n Flat) → ∃ (λ r → ∃ (λ I →  C implic: r , I ))
  separate c with implic c | simpl c
  ... | s , v , p | q , p′ = _ , _ , Separate p′ p
  implic (QC c) = _ , _ , Implic-Qc
  implic (a ∧′ b) with implic a | implic b
  ... | s , v , p | s′ , v′ , p′ = _ , _ , Implic-∧ p p′
  implic (Imp (∃ n · Q ⊃ C)) with separate C
  ... | s , v , p = _ , _ , Implic-I p

  -- Substitution for separated constraints
  substituteSep : ∀ {s}{a b} → (a → Type b) → SeparatedConstraint a s → SeparatedConstraint b s
  substituteImp : ∀ {s}{a b} → (a → Type b) → Implications a s → Implications b s
  substituteSep f (SC qc imps) = SC (qc-substitute f qc) (substituteImp f imps)
    where open Monad (type-is-monad)
          open Functor (type-is-functor)
  substituteImp f (imp-ε) = imp-ε
  substituteImp {Unary s} f (imp (∃ n · Q ⊃ C)) = imp (∃ n · constraint-types (join ∘ map f) Q
                                                           ⊃ substituteSep f′ C)
    where module PlusN-f = Functor (Monad.is-functor (PlusN-is-monad {n}))
          open Monad (type-is-monad)
          open Functor (type-is-functor)
          f′ = sequence-PlusN {n = n} ⦃ type-is-monad ⦄ ∘ PlusN-f.map f

  substituteImp f (a imp-∧ b) = substituteImp f a imp-∧ substituteImp f b


postulate
  A : Set₁

barb : Set₁
barb = {!(x y : A) → ?!}


{-# OPTIONS --show-irrelevant --subtyping #-}

module Issue2170-unify-subtyping where

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

record Squash (A : Set) : Set where
  constructor squash
  field .unsquash : A
open Squash

record UnSquash (A : Set) (s : A → Squash A) : Set where
  constructor inverse
  field
    inv : Squash A → A
    prf : {a : A} → inv (s a) ≡ a

test : {A : Set} → Squash (UnSquash A squash)
test = squash (inverse (λ p@(squash x) → _) refl)

-- `refl` is checked at type `_15 A (squash a) ≡ a`
-- Before, Agda solved this as `_15 := λ A p → unsquash a`, which
-- makes use of the irrelevant projection `unsquash`.
-- However, this is not allowed unless `--irrelevant-projections`
-- is enabled.