{-# OPTIONS --without-K #-}
module common-utilities where
open import common

lift-≟-1 : ∀ {ℓ ℓ′} {A : Set ℓ} {B : Set ℓ′} → (f : A → B) → {x : A} → {y : A} → Maybe (x ≡ y) → Maybe (f x ≡ f y)
lift-≟-1 f (just refl) = just refl
lift-≟-1 f nothing = nothing

lift-≟-1-refl : ∀ {ℓ ℓ′} {A : Set ℓ} {B : Set ℓ′} f {x} p → p ≡ just refl → lift-≟-1 {ℓ} {ℓ′} {A} {B} f {x} {x} p ≡ just refl
lift-≟-1-refl f ._ refl = refl

lift-≟-2-helper : ∀ {A : Set} {B : A → Set} {C : Set} {f : (x : A) → B x → C} {x : A} {y y' : B x} → Maybe (y ≡ y') → Maybe (f x y ≡ f x y')
lift-≟-2-helper (just refl) = just refl
lift-≟-2-helper nothing = nothing

lift-≟-2 : ∀ {A} {B : A → Set} {C} → (f : (x : A) → B x → C) → {x x' : A} → {y : B x} → {y' : B x'} → Maybe (x ≡ x') → ((p : x ≡ x') → Maybe (transport B p y ≡ y')) → Maybe (f x y ≡ f x' y')
lift-≟-2 {A} {B} {C} f {x} {.x} {y} {y'} (just refl) p = lift-≟-2-helper {A} {B} {C} {f} {x} {y} {y'} (p refl)
lift-≟-2 f nothing _ = nothing

lift-≟-2-helper-refl : ∀ {A B C f x y p} → p ≡ just refl → lift-≟-2-helper {A} {B} {C} {f} {x} {y} {y} p ≡ just refl
lift-≟-2-helper-refl refl = refl

lift-≟-2-refl : ∀ {A B C} f {x} {y} p q → p ≡ just refl → q refl ≡ just refl → lift-≟-2 {A} {B} {C} f {x} {x} {y} {y} p q ≡ just refl
lift-≟-2-refl {A} {B} {C} f {x} {y} ._ q refl q' = lift-≟-2-helper-refl {A} {B} {C} {f} {x} {y} {q refl} q'

lift-≟-3-helper : ∀ {A : Set} {B : A → Set} {C D} → {f : (x : A) → (y : B x) → C x y → D} → {x : A} → {y y' : B x} → {z : C x y} → {z' : C x y'} → Maybe (y ≡ y') → ((q : y ≡ y') → Maybe (transport2 C refl q z ≡ z')) → Maybe (f x y z ≡ f x y' z')
lift-≟-3-helper {A} {B} {C} {D} {f} {x} {y} {.y} {z} {z'} (just refl) q = lift-≟-2-helper {B x} {C x} {D} {f x} {y} {z} {z'} (q refl)
lift-≟-3-helper nothing q = nothing

lift-≟-3 : ∀ {A B C D} → (f : (x : A) → (y : B x) → C x y → D) → {x x' : A} → {y : B x} → {y' : B x'} → {z : C x y} → {z' : C x' y'} → Maybe (x ≡ x') → ((p : x ≡ x') → Maybe (transport B p y ≡ y')) → ((p : x ≡ x') → (q : transport B p y ≡ y') → Maybe (transport2 C p q z ≡ z')) → Maybe (f x y z ≡ f x' y' z')
lift-≟-3 {A} {B} {C} {D} f {x} {.x} {y} {y'} {z} {z'} (just refl) q r = lift-≟-3-helper {A} {B} {C} {D} {f} {x} {y} {y'} {z} {z'} (q refl) (r refl)
lift-≟-3 f nothing q r = nothing

lift-≟-3-helper-refl : ∀ {A B C D f x y z p q} → p ≡ just refl → q refl ≡ just refl → lift-≟-3-helper {A} {B} {C} {D} {f} {x} {y} {y} {z} {z} p q ≡ just refl
lift-≟-3-helper-refl {A} {B} {C} {D} {f} {x} {y} {z} {._} {q} refl q' = lift-≟-2-helper-refl {B x} {C x} {D} {f x} {y} {z} {q refl} q'

lift-≟-3-refl : ∀ {A B C D} f {x y z} p q r → p ≡ just refl → q refl ≡ just refl → r refl refl ≡ just refl → lift-≟-3 {A} {B} {C} {D} f {x} {x} {y} {y} {z} {z} p q r ≡ just refl
lift-≟-3-refl {A} {B} {C} {D} f {x} {y} {z} ._ q r refl q' r' = lift-≟-3-helper-refl {A} {B} {C} {D} {f} {x} {y} {z} {q refl} {r refl} q' r'

lift-≟-4-helper : ∀ {A : Set} {B : A → Set} {C : (x : A) → B x → Set} {D : (x : A) → (y : B x) → C x y → Set} {E} → {f : (x : A) → (y : B x) → (z : C x y) → (w : D x y z) → E} → {x : A} → {y y' : B x} → {z : C x y} → {z' : C x y'} → {w : D x y z} → {w' : D x y' z'} → Maybe (y ≡ y') → ((q : y ≡ y') → Maybe (transport2 C refl q z ≡ z')) → ((q : y ≡ y') → (r : transport2 C refl q z ≡ z') → Maybe (transport3 D refl q r w ≡ w')) → Maybe (f x y z w ≡ f x y' z' w')
lift-≟-4-helper {A} {B} {C} {D} {E} {f} {x} {y} {.y} {z} {z'} {w} {w'} (just refl) q r = lift-≟-3-helper {B x} {C x} {D x} {E} {f x} {y} {z} {z'} {w} {w'}
                                                                                (q refl) (r refl)
lift-≟-4-helper nothing q r = nothing

lift-≟-4 : ∀ {A B C D E} → (f : (x : A) → (y : B x) → (z : C x y) → (w : D x y z) → E) → {x x' : A} → {y : B x} → {y' : B x'} → {z : C x y} → {z' : C x' y'} → {w : D x y z} → {w' : D x' y' z'}
  → Maybe (x ≡ x')
  → ((p : x ≡ x') → Maybe (transport B p y ≡ y'))
  → ((p : x ≡ x') → (q : transport B p y ≡ y') → Maybe (transport2 C p q z ≡ z'))
  → ((p : x ≡ x') → (q : transport B p y ≡ y') → (r : transport2 C p q z ≡ z') → Maybe (transport3 D p q r w ≡ w'))
  → Maybe (f x y z w ≡ f x' y' z' w')
lift-≟-4 {A} {B} {C} {D} {E} f {x} {.x} {y} {y'} {z} {z'} {w} {w'} (just refl) q r s = lift-≟-4-helper {A} {B} {C} {D} {E} {f} {x} {y} {y'} {z} {z'} {w} {w'} (q refl) (r refl) (s refl)
lift-≟-4 f nothing q r s = nothing

lift-≟-5-helper : ∀ {A : Set} {B : A → Set} {C : (x : A) → B x → Set} {D : (x : A) → (y : B x) → C x y → Set} {E F} → {f : (x : A) → (y : B x) → (z : C x y) → (w : D x y z) → (v : E x y z w) → F} → {x : A} → {y y' : B x} → {z : C x y} → {z' : C x y'} → {w : D x y z} → {w' : D x y' z'} → {v : E x y z w} → {v' : E x y' z' w'} → Maybe (y ≡ y') → ((q : y ≡ y') → Maybe (transport2 C refl q z ≡ z')) → ((q : y ≡ y') → (r : transport2 C refl q z ≡ z') → Maybe (transport3 D refl q r w ≡ w')) → ((q : y ≡ y') → (r : transport2 C refl q z ≡ z') → (s : transport3 D refl q r w ≡ w') → Maybe (transport4 E refl q r s v ≡ v')) → Maybe (f x y z w v ≡ f x y' z' w' v')
lift-≟-5-helper {A} {B} {C} {D} {E} {F} {f} {x} {y} {.y} {z} {z'} {w} {w'} {v} {v'} (just refl) q r s
  = lift-≟-4-helper {B x} {C x} {D x} {E x} {F} {f x} {y} {z} {z'} {w}
      {w'} {v} {v'} (q refl) (r refl) (s refl)
lift-≟-5-helper nothing q r s = nothing

lift-≟-5 : ∀ {A B C D E F} → (f : (x : A) → (y : B x) → (z : C x y) → (w : D x y z) → (v : E x y z w) → F) → {x x' : A} → {y : B x} → {y' : B x'} → {z : C x y} → {z' : C x' y'} → {w : D x y z} → {w' : D x' y' z'} → {v : E x y z w} → {v' : E x' y' z' w'} → Maybe (x ≡ x') → ((p : x ≡ x') → Maybe (transport B p y ≡ y')) → ((p : x ≡ x') → (q : transport B p y ≡ y') → Maybe (transport2 C p q z ≡ z')) → ((p : x ≡ x') → (q : transport B p y ≡ y') → (r : transport2 C p q z ≡ z') → Maybe (transport3 D p q r w ≡ w')) → ((p : x ≡ x') → (q : transport B p y ≡ y') → (r : transport2 C p q z ≡ z') → (s : transport3 D p q r w ≡ w') → Maybe (transport4 E p q r s v ≡ v')) → Maybe (f x y z w v ≡ f x' y' z' w' v')
lift-≟-5 {A} {B} {C} {D} {E} {F} f {x} {.x} {y} {y'} {z} {z'} {w} {w'} {v} {v'} (just refl) q r s t = lift-≟-5-helper {A} {B} {C} {D} {E} {F} {f} {x} {y} {y'} {z} {z'} {w} {w'} {v} {v'} (q refl) (r refl) (s refl) (t refl)
lift-≟-5 f nothing q r s t = nothing

lift-≟-4-helper-refl : ∀ {A B C D E f x y z w p q r} → p ≡ just refl → q refl ≡ just refl → r refl refl ≡ just refl → lift-≟-4-helper {A} {B} {C} {D} {E} {f} {x} {y} {y} {z} {z} {w} {w} p q r ≡ just refl
lift-≟-4-helper-refl {A} {B} {C} {D} {E} {f} {x} {y} {z} {w} {._} {q} {r} refl q' r' = lift-≟-3-helper-refl {B x} {C x} {D x} {E} {f x} {y} {z} {w}
                                                                                {q refl} {r refl} q' r'

lift-≟-4-refl : ∀ {A B C D E} f {x y z w} p q r s → p ≡ just refl → q refl ≡ just refl → r refl refl ≡ just refl → s refl refl refl ≡ just refl → lift-≟-4 {A} {B} {C} {D} {E} f {x} {x} {y} {y} {z} {z} {w} {w} p q r s ≡ just refl
lift-≟-4-refl {A} {B} {C} {D} {E} f {x} {y} {z} {w} ._ q r s refl q' r' s' = lift-≟-4-helper-refl {A} {B} {C} {D} {E} {f} {x} {y} {z} {w} {q refl} {r refl} {s refl} q' r' s'

lift-≟-5-helper-refl : ∀ {A B C D E F f x y z w v p q r s} → p ≡ just refl → q refl ≡ just refl → r refl refl ≡ just refl → s refl refl refl ≡ just refl → lift-≟-5-helper {A} {B} {C} {D} {E} {F} {f} {x} {y} {y} {z} {z} {w} {w} {v} {v} p q r s ≡ just refl
lift-≟-5-helper-refl {A} {B} {C} {D} {E} {F} {f} {x} {y} {z} {w} {v} {._} {q} {r} {s} refl q' r' s'
  = lift-≟-4-helper-refl {B x} {C x} {D x} {E x} {F} {f x} {y} {z} {w}
      {v} {q refl} {r refl} {s refl} q' r' s'

lift-≟-5-refl : ∀ {A B C D E F} f {x y z w v} p q r s t → p ≡ just refl → q refl ≡ just refl → r refl refl ≡ just refl → s refl refl refl ≡ just refl → t refl refl refl refl ≡ just refl → lift-≟-5 {A} {B} {C} {D} {E} {F} f {x} {x} {y} {y} {z} {z} {w} {w} {v} {v} p q r s t ≡ just refl
lift-≟-5-refl {A} {B} {C} {D} {E} {F} f {x} {y} {z} {w} {v} ._ q r s t refl q' r' s' t' = lift-≟-5-helper-refl {A} {B} {C} {D} {E} {F} {f} {x} {y} {z} {w} {v} {q refl} {r refl} {s refl} {t refl} q' r' s' t'


------------------------------------------------------------------------
-- A map function for the substitutions
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Function.Map
  {i u e} {Uni : IndexedUniverse i u e} where

import Axiom.Extensionality.Propositional as E
import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Function.Basics
open import Function using (_$_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

private
 module Dummy
   {t₁} {T₁ : Term-like t₁}
   {t₂} {T₂ : Term-like t₂}
   where

  open Term-like T₁ using ()
                    renaming (_⊢_ to _⊢₁_; _≅-⊢_ to _≅-⊢₁_; [_] to [_]₁)
  open Term-like T₂ using () renaming (_≅-⊢_ to _≅-⊢₂_)

  -- Map.

  map : ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} →
        [ T₁ ⟶ T₂ ] ρ̂₂ → (ρ₁ : Sub T₁ ρ̂₁) → Sub T₂ (ρ̂₁ ∘̂ ρ̂₂)
  map f ρ₁ = f [∘] ρ₁

  abstract

    -- An unfolding lemma.

    map-▻ :
      E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t₂) →
      ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} {σ}
      (f : [ T₁ ⟶ T₂ ] ρ̂₂) (ρ : Sub T₁ ρ̂₁) t →
      map f (ρ ▻⇨[ σ ] t) ≅-⇨ map f ρ ▻⇨[ σ ] f · t
    map-▻ ext {Γ} {σ = σ} f ρ t = extensionality ext P.refl lemma
      where
      lemma : ∀ {τ} (x : Γ ▻ σ ∋ τ) →
              f · (x /∋ (ρ ▻⇨ t)) ≅-⊢₂ x /∋ (map f ρ ▻⇨ f · t)
      lemma zero    = P.refl
      lemma (suc x) = P.refl

  -- A congruence lemma.

  map-cong : ∀ {Γ₁ Δ₁ Ε₁} {ρ̂₁₁ : Γ₁ ⇨̂ Δ₁} {ρ̂₂₁ : Δ₁ ⇨̂ Ε₁}
               {f₁ : [ T₁ ⟶ T₂ ] ρ̂₂₁} {ρ₁ : Sub T₁ ρ̂₁₁}
               {Γ₂ Δ₂ Ε₂} {ρ̂₁₂ : Γ₂ ⇨̂ Δ₂} {ρ̂₂₂ : Δ₂ ⇨̂ Ε₂}
               {f₂ : [ T₁ ⟶ T₂ ] ρ̂₂₂} {ρ₂ : Sub T₁ ρ̂₁₂} →
             f₁ ≅-⟶ f₂ → ρ₁ ≅-⇨ ρ₂ → map f₁ ρ₁ ≅-⇨ map f₂ ρ₂
  map-cong {f₁ = _ , _} {ρ₁ = _ , _} {f₂ = ._ , _} {ρ₂ = ._ , _}
           [ P.refl ] [ P.refl ] = [ P.refl ]

  abstract

    -- Variants which only require that the functions are
    -- extensionally equal.

    map-cong-ext₁ : E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t₂) →
                    ∀ {Γ₁ Δ Ε₁} {ρ̂₁₁ : Γ₁ ⇨̂ Δ} {ρ̂₂₁ : Δ ⇨̂ Ε₁}
                      {f₁ : [ T₁ ⟶ T₂ ] ρ̂₂₁} {ρ₁ : Sub T₁ ρ̂₁₁}
                      {Γ₂   Ε₂} {ρ̂₁₂ : Γ₂ ⇨̂ Δ} {ρ̂₂₂ : Δ ⇨̂ Ε₂}
                      {f₂ : [ T₁ ⟶ T₂ ] ρ̂₂₂} {ρ₂ : Sub T₁ ρ̂₁₂} →
                    Ε₁ ≅-Ctxt Ε₂ →
                    (∀ {σ} (t : Δ ⊢₁ σ) → f₁ · t ≅-⊢₂ f₂ · t) →
                    ρ₁ ≅-⇨ ρ₂ → map f₁ ρ₁ ≅-⇨ map f₂ ρ₂
    map-cong-ext₁ ext {ρ₁ = ρ} {ρ₂ = ._ , _} Ε₁≅Ε₂ f₁≅f₂ [ P.refl ] =
      extensionality ext Ε₁≅Ε₂ (λ x → f₁≅f₂ (x /∋ ρ))

    map-cong-ext₂ : E.Extensionality (i ⊔ u ⊔ e) (i ⊔ u ⊔ e ⊔ t₂) →
                    ∀ {Γ₁ Δ₁ Ε₁} {ρ̂₁₁ : Γ₁ ⇨̂ Δ₁} {ρ̂₂₁ : Δ₁ ⇨̂ Ε₁}
                      {f₁ : [ T₁ ⟶ T₂ ] ρ̂₂₁} {ρ₁ : Sub T₁ ρ̂₁₁}
                      {Γ₂ Δ₂ Ε₂} {ρ̂₁₂ : Γ₂ ⇨̂ Δ₂} {ρ̂₂₂ : Δ₂ ⇨̂ Ε₂}
                      {f₂ : [ T₁ ⟶ T₂ ] ρ̂₂₂} {ρ₂ : Sub T₁ ρ̂₁₂} →
                    Δ₁ ≅-Ctxt Δ₂ → Ε₁ ≅-Ctxt Ε₂ →
                    (∀ {σ₁ σ₂} {t₁ : Δ₁ ⊢₁ σ₁} {t₂ : Δ₂ ⊢₁ σ₂} →
                       t₁ ≅-⊢₁ t₂ → f₁ · t₁ ≅-⊢₂ f₂ · t₂) →
                    ρ₁ ≅-⇨ ρ₂ → map f₁ ρ₁ ≅-⇨ map f₂ ρ₂
    map-cong-ext₂ ext P.refl Ε₁≅Ε₂ f₁≅f₂ ρ₁≅ρ₂ =
      map-cong-ext₁ ext Ε₁≅Ε₂ (λ t → f₁≅f₂ (P.refl {x = [ t ]₁})) ρ₁≅ρ₂

  -- Some sort of naturality statement for _/∋_. (Note that this lemma
  -- holds definitionally. This is not the case for the corresponding
  -- lemma in deBruijn.Substitution.Data.Map.)

  /∋-map : ∀ {Γ Δ Ε σ} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} →
           (x : Γ ∋ σ) (f : [ T₁ ⟶ T₂ ] ρ̂₂) (ρ : Sub T₁ ρ̂₁) →
           x /∋ map f ρ ≅-⊢₂ f · (x /∋ ρ)
  /∋-map x f ρ = P.refl

open Dummy public

-- Map is functorial.

map-[id] : ∀ {t} {T : Term-like t} {Γ Δ} {ρ̂ : Γ ⇨̂ Δ}
           (ρ : Sub T ρ̂) →
           map ([id] {T = T}) ρ ≅-⇨ ρ
map-[id] = [id]-[∘]

map-[∘] :
  ∀ {t₁} {T₁ : Term-like t₁}
    {t₂} {T₂ : Term-like t₂}
    {t₃} {T₃ : Term-like t₃}
    {Γ Δ Ε Ζ} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} {ρ̂₃ : Ε ⇨̂ Ζ}
  (f₂ : [ T₂ ⟶ T₃ ] ρ̂₃) (f₁ : [ T₁ ⟶ T₂ ] ρ̂₂)
  (ρ : Sub T₁ ρ̂₁) →
  map (f₂ [∘] f₁) ρ ≅-⇨ map f₂ (map f₁ ρ)
map-[∘] f₂ f₁ ρ = sym-⟶ $ [∘]-[∘] f₂ f₁ ρ


-- Basic intuitionistic logic of proofs, without ∨, ⊥, or +.
-- Gentzen-style formalisation of syntax with context pairs.
-- Normal forms and neutrals.

module BasicILP.Syntax.DyadicGentzenNormalForm where

open import BasicILP.Syntax.DyadicGentzen public

-- Derivations.

mutual
  -- Normal forms, or introductions.
  infix 3 _⊢ⁿᶠ_
  data _⊢ⁿᶠ_ : Cx² Ty Box → Ty → Set where
    neⁿᶠ   : ∀ {A Γ Δ}     → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ⁿᶠ A
    lamⁿᶠ  : ∀ {A B Γ Δ}   → Γ , A ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ▻ B

    boxⁿᶠ  : ∀ {Ψ Ω A Γ Δ} → (x : Ψ ⁏ Ω ⊢ A)
                           → Γ ⁏ Δ ⊢ⁿᶠ [ Ψ ⁏ Ω ⊢ x ] A

    pairⁿᶠ : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ∧ B
    unitⁿᶠ : ∀ {Γ Δ}       → Γ ⁏ Δ ⊢ⁿᶠ ⊤

  -- Neutrals, or eliminations.
  infix 3 _⊢ⁿᵉ_
  data _⊢ⁿᵉ_ : Cx² Ty Box → Ty → Set where
    varⁿᵉ   : ∀ {A Γ Δ}         → A ∈ Γ → Γ ⁏ Δ ⊢ⁿᵉ A
    appⁿᵉ   : ∀ {A B Γ Δ}       → Γ ⁏ Δ ⊢ⁿᵉ A ▻ B → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᵉ B

    mvarⁿᵉ  : ∀ {Ψ Ω A x Γ Δ}   → [ Ψ ⁏ Ω ⊢ x ] A ∈ Δ
                                → {{_ : Γ ⁏ Δ ⊢⋆ⁿᶠ Ψ}}
                                → {{_ : Γ ⁏ Δ ⊢⍟ⁿᶠ Ω}}
                                → Γ ⁏ Δ ⊢ⁿᵉ A

    unboxⁿᵉ : ∀ {Ψ Ω A C x Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ [ Ψ ⁏ Ω ⊢ x ] A
                                → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ⁿᶠ C
                                → Γ ⁏ Δ ⊢ⁿᵉ C

    fstⁿᵉ   : ∀ {A B Γ Δ}       → Γ ⁏ Δ ⊢ⁿᵉ A ∧ B → Γ ⁏ Δ ⊢ⁿᵉ A
    sndⁿᵉ   : ∀ {A B Γ Δ}       → Γ ⁏ Δ ⊢ⁿᵉ A ∧ B → Γ ⁏ Δ ⊢ⁿᵉ B

  infix 3 _⊢⋆ⁿᶠ_
  _⊢⋆ⁿᶠ_ : Cx² Ty Box → Cx Ty → Set
  Γ ⁏ Δ ⊢⋆ⁿᶠ ∅     = 𝟙
  Γ ⁏ Δ ⊢⋆ⁿᶠ Ξ , A = Γ ⁏ Δ ⊢⋆ⁿᶠ Ξ × Γ ⁏ Δ ⊢ⁿᶠ A

  infix 3 _⊢⍟ⁿᶠ_
  _⊢⍟ⁿᶠ_ : Cx² Ty Box → Cx Box → Set
  Γ ⁏ Δ ⊢⍟ⁿᶠ ∅                    = 𝟙
  Γ ⁏ Δ ⊢⍟ⁿᶠ Ξ , [ Ψ ⁏ Ω ⊢ x ] A = Γ ⁏ Δ ⊢⍟ⁿᶠ Ξ × Γ ⁏ Δ ⊢ⁿᶠ [ Ψ ⁏ Ω ⊢ x ] A

infix 3 _⊢⋆ⁿᵉ_
_⊢⋆ⁿᵉ_ : Cx² Ty Box → Cx Ty → Set
Γ ⁏ Δ ⊢⋆ⁿᵉ ∅     = 𝟙
Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ , A = Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ × Γ ⁏ Δ ⊢ⁿᵉ A

infix 3 _⊢⍟ⁿᵉ_
_⊢⍟ⁿᵉ_ : Cx² Ty Box → Cx Box → Set
Γ ⁏ Δ ⊢⍟ⁿᵉ ∅                    = 𝟙
Γ ⁏ Δ ⊢⍟ⁿᵉ Ξ , [ Ψ ⁏ Ω ⊢ x ] A = Γ ⁏ Δ ⊢⍟ⁿᵉ Ξ × Γ ⁏ Δ ⊢ⁿᵉ [ Ψ ⁏ Ω ⊢ x ] A

-- Translation to simple terms.

mutual
  nf→tm : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ A
  nf→tm (neⁿᶠ t)     = ne→tm t
  nf→tm (lamⁿᶠ t)    = lam (nf→tm t)
  nf→tm (boxⁿᶠ t)    = box t
  nf→tm (pairⁿᶠ t u) = pair (nf→tm t) (nf→tm u)
  nf→tm unitⁿᶠ       = unit

  ne→tm : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ A
  ne→tm (varⁿᵉ i)                = var i
  ne→tm (appⁿᵉ t u)              = app (ne→tm t) (nf→tm u)
  ne→tm (mvarⁿᵉ i {{ts}} {{us}}) = mvar i {{nf→tm⋆ ts}} {{nf→tm⍟ us}}
  ne→tm (unboxⁿᵉ t u)            = unbox (ne→tm t) (nf→tm u)
  ne→tm (fstⁿᵉ t)                = fst (ne→tm t)
  ne→tm (sndⁿᵉ t)                = snd (ne→tm t)

  nf→tm⋆ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⋆ⁿᶠ Ξ → Γ ⁏ Δ ⊢⋆ Ξ
  nf→tm⋆ {∅}     ∙        = ∙
  nf→tm⋆ {Ξ , A} (ts , t) = nf→tm⋆ ts , nf→tm t

  nf→tm⍟ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⍟ⁿᶠ Ξ → Γ ⁏ Δ ⊢⍟ Ξ
  nf→tm⍟ {∅}     ∙        = ∙
  nf→tm⍟ {Ξ , _} (ts , t) = nf→tm⍟ ts , nf→tm t

ne→tm⋆ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ → Γ ⁏ Δ ⊢⋆ Ξ
ne→tm⋆ {∅}     ∙        = ∙
ne→tm⋆ {Ξ , A} (ts , t) = ne→tm⋆ ts , ne→tm t

ne→tm⍟ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⍟ⁿᵉ Ξ → Γ ⁏ Δ ⊢⍟ Ξ
ne→tm⍟ {∅}     ∙        = ∙
ne→tm⍟ {Ξ , _} (ts , t) = ne→tm⍟ ts , ne→tm t

-- Monotonicity with respect to context inclusion.

mutual
  mono⊢ⁿᶠ : ∀ {A Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ⁿᶠ A → Γ′ ⁏ Δ ⊢ⁿᶠ A
  mono⊢ⁿᶠ η (neⁿᶠ t)     = neⁿᶠ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᶠ η (lamⁿᶠ t)    = lamⁿᶠ (mono⊢ⁿᶠ (keep η) t)
  mono⊢ⁿᶠ η (boxⁿᶠ t)    = boxⁿᶠ t
  mono⊢ⁿᶠ η (pairⁿᶠ t u) = pairⁿᶠ (mono⊢ⁿᶠ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᶠ η unitⁿᶠ       = unitⁿᶠ

  mono⊢ⁿᵉ : ∀ {A Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ⁿᵉ A → Γ′ ⁏ Δ ⊢ⁿᵉ A
  mono⊢ⁿᵉ η (varⁿᵉ i)                = varⁿᵉ (mono∈ η i)
  mono⊢ⁿᵉ η (appⁿᵉ t u)              = appⁿᵉ (mono⊢ⁿᵉ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᵉ η (mvarⁿᵉ i {{ts}} {{us}}) = mvarⁿᵉ i {{mono⊢⋆ⁿᶠ η ts}} {{mono⊢⍟ⁿᶠ η us}}
  mono⊢ⁿᵉ η (unboxⁿᵉ t u)            = unboxⁿᵉ (mono⊢ⁿᵉ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᵉ η (fstⁿᵉ t)                = fstⁿᵉ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᵉ η (sndⁿᵉ t)                = sndⁿᵉ (mono⊢ⁿᵉ η t)

  mono⊢⋆ⁿᶠ : ∀ {Ξ Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢⋆ⁿᶠ Ξ → Γ′ ⁏ Δ ⊢⋆ⁿᶠ Ξ
  mono⊢⋆ⁿᶠ {∅}     η ∙        = ∙
  mono⊢⋆ⁿᶠ {Ξ , A} η (ts , t) = mono⊢⋆ⁿᶠ η ts , mono⊢ⁿᶠ η t

  mono⊢⍟ⁿᶠ : ∀ {Ξ Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢⍟ⁿᶠ Ξ → Γ′ ⁏ Δ ⊢⍟ⁿᶠ Ξ
  mono⊢⍟ⁿᶠ {∅}     η ∙        = ∙
  mono⊢⍟ⁿᶠ {Ξ , _} η (ts , t) = mono⊢⍟ⁿᶠ η ts , mono⊢ⁿᶠ η t

mono⊢⋆ⁿᵉ : ∀ {Ξ Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ → Γ′ ⁏ Δ ⊢⋆ⁿᵉ Ξ
mono⊢⋆ⁿᵉ {∅}     η ∙        = ∙
mono⊢⋆ⁿᵉ {Ξ , A} η (ts , t) = mono⊢⋆ⁿᵉ η ts , mono⊢ⁿᵉ η t

mono⊢⍟ⁿᵉ : ∀ {Ξ Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢⍟ⁿᵉ Ξ → Γ′ ⁏ Δ ⊢⍟ⁿᵉ Ξ
mono⊢⍟ⁿᵉ {∅}     η ∙        = ∙
mono⊢⍟ⁿᵉ {Ξ , _} η (ts , t) = mono⊢⍟ⁿᵉ η ts , mono⊢ⁿᵉ η t

-- Monotonicity with respect to modal context inclusion.

mutual
  mmono⊢ⁿᶠ : ∀ {A Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ′ ⊢ⁿᶠ A
  mmono⊢ⁿᶠ θ (neⁿᶠ t)     = neⁿᶠ (mmono⊢ⁿᵉ θ t)
  mmono⊢ⁿᶠ θ (lamⁿᶠ t)    = lamⁿᶠ (mmono⊢ⁿᶠ θ t)
  mmono⊢ⁿᶠ θ (boxⁿᶠ t)    = boxⁿᶠ t
  mmono⊢ⁿᶠ θ (pairⁿᶠ t u) = pairⁿᶠ (mmono⊢ⁿᶠ θ t) (mmono⊢ⁿᶠ θ u)
  mmono⊢ⁿᶠ θ unitⁿᶠ       = unitⁿᶠ

  mmono⊢ⁿᵉ : ∀ {A Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ′ ⊢ⁿᵉ A
  mmono⊢ⁿᵉ θ (varⁿᵉ i)                = varⁿᵉ i
  mmono⊢ⁿᵉ θ (appⁿᵉ t u)              = appⁿᵉ (mmono⊢ⁿᵉ θ t) (mmono⊢ⁿᶠ θ u)
  mmono⊢ⁿᵉ θ (mvarⁿᵉ i {{ts}} {{us}}) = mvarⁿᵉ (mono∈ θ i) {{mmono⊢⋆ⁿᶠ θ ts}} {{mmono⊢⍟ⁿᶠ θ us}}
  mmono⊢ⁿᵉ θ (unboxⁿᵉ t u)            = unboxⁿᵉ (mmono⊢ⁿᵉ θ t) (mmono⊢ⁿᶠ (keep θ) u)
  mmono⊢ⁿᵉ θ (fstⁿᵉ t)                = fstⁿᵉ (mmono⊢ⁿᵉ θ t)
  mmono⊢ⁿᵉ θ (sndⁿᵉ t)                = sndⁿᵉ (mmono⊢ⁿᵉ θ t)

  mmono⊢⋆ⁿᶠ : ∀ {Ξ Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢⋆ⁿᶠ Ξ → Γ ⁏ Δ′ ⊢⋆ⁿᶠ Ξ
  mmono⊢⋆ⁿᶠ {∅}     θ ∙        = ∙
  mmono⊢⋆ⁿᶠ {Ξ , A} θ (ts , t) = mmono⊢⋆ⁿᶠ θ ts , mmono⊢ⁿᶠ θ t

  mmono⊢⍟ⁿᶠ : ∀ {Ξ Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢⍟ⁿᶠ Ξ → Γ ⁏ Δ′ ⊢⍟ⁿᶠ Ξ
  mmono⊢⍟ⁿᶠ {∅}     θ ∙        = ∙
  mmono⊢⍟ⁿᶠ {Ξ , _} θ (ts , t) = mmono⊢⍟ⁿᶠ θ ts , mmono⊢ⁿᶠ θ t

mmono⊢⋆ⁿᵉ : ∀ {Ξ Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ → Γ ⁏ Δ′ ⊢⋆ⁿᵉ Ξ
mmono⊢⋆ⁿᵉ {∅}     θ ∙        = ∙
mmono⊢⋆ⁿᵉ {Ξ , A} θ (ts , t) = mmono⊢⋆ⁿᵉ θ ts , mmono⊢ⁿᵉ θ t

mmono⊢⍟ⁿᵉ : ∀ {Ξ Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢⍟ⁿᵉ Ξ → Γ ⁏ Δ′ ⊢⍟ⁿᵉ Ξ
mmono⊢⍟ⁿᵉ {∅}     θ ∙        = ∙
mmono⊢⍟ⁿᵉ {Ξ , _} θ (ts , t) = mmono⊢⍟ⁿᵉ θ ts , mmono⊢ⁿᵉ θ t

-- Monotonicity using context pairs.

mono²⊢ⁿᶠ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ⁿᶠ A → Π′ ⊢ⁿᶠ A
mono²⊢ⁿᶠ (η , θ) = mono⊢ⁿᶠ η ∘ mmono⊢ⁿᶠ θ

mono²⊢ⁿᵉ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ⁿᵉ A → Π′ ⊢ⁿᵉ A
mono²⊢ⁿᵉ (η , θ) = mono⊢ⁿᵉ η ∘ mmono⊢ⁿᵉ θ

-- Generalised reflexivity.

refl⊢⋆ⁿᵉ : ∀ {Γ Ψ Δ} → {{_ : Ψ ⊆ Γ}} → Γ ⁏ Δ ⊢⋆ⁿᵉ Ψ
refl⊢⋆ⁿᵉ {∅}     {{done}}   = ∙
refl⊢⋆ⁿᵉ {Γ , A} {{skip η}} = mono⊢⋆ⁿᵉ weak⊆ (refl⊢⋆ⁿᵉ {{η}})
refl⊢⋆ⁿᵉ {Γ , A} {{keep η}} = mono⊢⋆ⁿᵉ weak⊆ (refl⊢⋆ⁿᵉ {{η}}) , varⁿᵉ top


------------------------------------------------------------------------
-- Two eliminators for Delay-monad.Alternative.Delay (A / R)
------------------------------------------------------------------------

-- This module is largely based on (but perhaps not quite identical
-- to) the development underlying Theorem 1 in "Quotienting the Delay
-- Monad by Weak Bisimilarity" by Chapman, Uustalu and Veltri.

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

module Delay-monad.Alternative.Eliminators where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (↑)

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms.Univalence equality-with-paths
import Equivalence equality-with-J as Eq
open import Equivalence-relation equality-with-J
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
open import Quotient equality-with-paths
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

open import Delay-monad.Alternative
open import Delay-monad.Alternative.Equivalence
open import Delay-monad.Alternative.Properties

------------------------------------------------------------------------
-- A map function

private

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

    -- A map function for Maybe.

    mapᴹ : (A → B) → Maybe A → Maybe B
    mapᴹ = ⊎-map id

    -- If mapᴹ f x does not have a value, then x does not have a
    -- value.

    mapᴹ-↑ : ∀ {f : A → B} x → mapᴹ f x ↑ → x ↑
    mapᴹ-↑ nothing  _  = refl
    mapᴹ-↑ (just _) ()

    -- The function mapᴹ f preserves LE.

    mapᴹ-LE : ∀ {f : A → B} {x y} →
              LE x y → LE (mapᴹ f x) (mapᴹ f y)
    mapᴹ-LE =
      ⊎-map (cong (mapᴹ _)) (Σ-map (cong (mapᴹ _)) (_∘ mapᴹ-↑ _))

    -- The function mapᴹ f ∘_ preserves Increasing.

    mapᴹ-Increasing : ∀ {f : A → B} {g} →
                      Increasing g → Increasing (mapᴹ f ∘ g)
    mapᴹ-Increasing = mapᴹ-LE ∘_

-- A map function for Delay.

map : ∀ {a b} {A : Type a} {B : Type b} →
      (A → B) → Delay A → Delay B
map f = Σ-map (mapᴹ f ∘_) mapᴹ-Increasing

------------------------------------------------------------------------
-- The first eliminator

private
  variable
    a r : Level
    A B : Type a
    R   : A → A → Type r
    f   : A → B

-- Some abstract redefinitions, intended to make the code type-check
-- faster.

private

  abstract

    ℕ→/-comm-to′ : (ℕ → A) / (ℕ →ᴾ R) → (ℕ → A / R)
    ℕ→/-comm-to′ = ℕ→/-comm-to

    ℕ→/-comm-to′-[] : ℕ→/-comm-to′ {R = R} [ f ] ≡ [_] ∘ f
    ℕ→/-comm-to′-[] = refl

  ℕ→/-comm′ :
    {A : Type a} {R : A → A → Type r} →
    Axiom-of-countable-choice (a ⊔ r) →
    Is-equivalence-relation R →
    (∀ {x y} → Is-proposition (R x y)) →
    (ℕ → A) / (ℕ →ᴾ R) ↔ (ℕ → A / R)
  ℕ→/-comm′ {A = A} {R} cc R-equiv R-prop = record
    { surjection = record
      { logical-equivalence = record
        { to   = ℕ→/-comm-to′
        ; from = from
        }
      ; right-inverse-of = to∘from
      }
    ; left-inverse-of = from∘to
    }
    where
    iso = ℕ→/-comm cc prop-ext R-equiv R-prop

    abstract

      from : (ℕ → A / R) → (ℕ → A) / (ℕ →ᴾ R)
      from = _↔_.from iso

      to∘from : ∀ f → ℕ→/-comm-to′ (from f) ≡ f
      to∘from = _↔_.right-inverse-of iso

      from∘to : ∀ f → from (ℕ→/-comm-to′ f) ≡ f
      from∘to = _↔_.left-inverse-of iso

  abstract

    Maybe/-comm′ : Maybe A / Maybeᴾ R ↔ Maybe (A / R)
    Maybe/-comm′ = Maybe/-comm

    Maybe/-comm′-[] :
      _↔_.to Maybe/-comm′ ∘ [_] ≡ ⊎-map id ([_] {R = R})
    Maybe/-comm′-[] = Maybe/-comm-[]

-- There is a function from (ℕ → Maybe A) / (ℕ →ᴾ Maybeᴾ R) to
-- Delay (A / R).

→Maybe/→ : (ℕ → Maybe A) / (ℕ →ᴾ Maybeᴾ R) → Delay (A / R)
→Maybe/→ f =
  _↠_.to →↠Delay-function (_↔_.to Maybe/-comm′ ∘ ℕ→/-comm-to′ f)

-- A "computation" rule for →Maybe/→.

→Maybe/→-[] :
  →Maybe/→ [ f ] ≡
  _↠_.to →↠Delay-function (_↔_.to (Maybe/-comm′ {R = R}) ∘ [_] ∘ f)
→Maybe/→-[] =
  cong (λ g → _↠_.to →↠Delay-function (_↔_.to Maybe/-comm′ ∘ g))
    ℕ→/-comm-to′-[]

-- The definitions below make use of some assumptions: countable
-- choice and a propositional equivalence relation R.

module _
  {a r} {A : Type a} {R : A → A → Type r}
  (cc : Axiom-of-countable-choice (a ⊔ r))
  (R-equiv : Is-equivalence-relation R)
  (R-prop : ∀ {x y} → Is-proposition (R x y))
  where

  private

    -- An abbreviation.

    ℕ→/-comm″ =
      ℕ→/-comm′ cc
        (Maybeᴾ-preserves-Is-equivalence-relation R-equiv)
        (λ {x} → Maybeᴾ-preserves-Is-proposition R-prop {x = x})

  -- →Maybe/→ has a right inverse.

  →Maybe/↠ :
    (ℕ → Maybe A) / (ℕ →ᴾ Maybeᴾ R) ↠ Delay (A / R)
  →Maybe/↠ =
    (ℕ → Maybe A) / (ℕ →ᴾ Maybeᴾ R)  ↔⟨ ℕ→/-comm″ ⟩
    (ℕ → Maybe A / Maybeᴾ R)         ↔⟨ ∀-cong ext (λ _ → Maybe/-comm′) ⟩
    (ℕ → Maybe (A / R))              ↝⟨ →↠Delay-function ⟩□
    Delay (A / R)                    □

  private

    to-→Maybe/↠ : _↠_.to →Maybe/↠ ≡ →Maybe/→
    to-→Maybe/↠ = refl

  -- On part of the domain of →Maybe/→ the right inverse is also a
  -- left inverse.

  →Maybe/↠-partial-left-inverse :
    (x : Delay A) →
    _↠_.from →Maybe/↠ (→Maybe/→ [ proj₁ x ]) ≡ [ proj₁ x ]
  →Maybe/↠-partial-left-inverse (f , inc) =
    _↠_.from →Maybe/↠ (→Maybe/→ [ f ])                                 ≡⟨ cong (_↠_.from →Maybe/↠) →Maybe/→-[] ⟩

    _↔_.from ℕ→/-comm″ (λ n →
      _↔_.from Maybe/-comm′ $
      _↠_.from →↠Delay-function
        (_↠_.to →↠Delay-function (_↔_.to Maybe/-comm′ ∘ [_] ∘ f))
        n)                                                             ≡⟨ cong (λ g → _↔_.from ℕ→/-comm″ λ n →
                                                                                _↔_.from Maybe/-comm′ (_↠_.from →↠Delay-function
                                                                                (_↠_.to →↠Delay-function (g ∘ f))
                                                                                n)) $
                                                                            Maybe/-comm′-[] ⟩
    _↔_.from ℕ→/-comm″ (λ n →
      _↔_.from Maybe/-comm′ $
      _↠_.from →↠Delay-function
        (_↠_.to →↠Delay-function (mapᴹ [_] ∘ f))
        n)                                                             ≡⟨⟩

    _↔_.from ℕ→/-comm″ (λ n →
      _↔_.from Maybe/-comm′ $
      _↠_.from →↠Delay-function
        (_↠_.to →↠Delay-function
           (_↠_.from →↠Delay-function (map [_] (f , inc))))
        n)                                                             ≡⟨ cong (λ x → _↔_.from ℕ→/-comm″ λ n →
                                                                                _↔_.from Maybe/-comm′ (_↠_.from →↠Delay-function x n)) $
                                                                            _↠_.right-inverse-of →↠Delay-function (map [_] (f , inc)) ⟩
    _↔_.from ℕ→/-comm″ (λ n →
      _↔_.from Maybe/-comm′ $
      _↠_.from →↠Delay-function (map [_] (f , inc)) n)                 ≡⟨⟩

    _↔_.from ℕ→/-comm″ (λ n → _↔_.from Maybe/-comm′ $ mapᴹ [_] (f n))  ≡⟨ cong (λ g → _↔_.from ℕ→/-comm″ λ n → _↔_.from Maybe/-comm′ (g (f n))) $
                                                                            sym Maybe/-comm′-[] ⟩
    _↔_.from ℕ→/-comm″ (λ n →
      _↔_.from Maybe/-comm′ (_↔_.to Maybe/-comm′ [ f n ]))             ≡⟨ cong (_↔_.from ℕ→/-comm″) (⟨ext⟩ λ n →
                                                                            _↔_.left-inverse-of Maybe/-comm′ [ f n ]) ⟩

    _↔_.from ℕ→/-comm″ (λ n → [ f n ])                                 ≡⟨ cong (_↔_.from ℕ→/-comm″) $ sym ℕ→/-comm-to′-[] ⟩

    _↔_.from ℕ→/-comm″ (ℕ→/-comm-to′ [ f ])                            ≡⟨ _↔_.left-inverse-of ℕ→/-comm″ [ f ] ⟩∎

    [ f ]                                                              ∎

  -- A quotient-like eliminator for Delay (A / R).

  Delay/-elim₁ :
    ∀ {p} (P : Delay (A / R) → Type p)
    (p-[] : (f : ℕ → Maybe A) → P (→Maybe/→ [ f ])) →
    (∀ {f g} (r : (ℕ →ᴾ Maybeᴾ R) f g) →
     subst P (cong →Maybe/→
                   ([]-respects-relation {x = f} {y = g} r))
             (p-[] f) ≡
     p-[] g) →
    (∀ x → Is-set (P x)) →
    ∀ x → P x
  Delay/-elim₁ = ↠-eliminator →Maybe/↠

  -- Simplification lemma for Delay/-elim₁.

  Delay/-elim₁-[] :
    ∀ {p} (P : Delay (A / R) → Type p)
    (p-[] : (f : ℕ → Maybe A) → P (→Maybe/→ [ f ]))
    (ok :
       ∀ {f g} (r : (ℕ →ᴾ Maybeᴾ R) f g) →
       subst P (cong →Maybe/→
                     ([]-respects-relation {x = f} {y = g} r))
               (p-[] f) ≡
       p-[] g)
    (P-set : ∀ x → Is-set (P x)) (x : Delay A) →
    Delay/-elim₁ P p-[] ok P-set (→Maybe/→ [ proj₁ x ]) ≡
    p-[] (proj₁ x)
  Delay/-elim₁-[] P p-[] ok P-set x =
    ↠-eliminator-[] →Maybe/↠ P p-[] ok P-set
      (_↠_.from →↠Delay-function x)
      (→Maybe/↠-partial-left-inverse x)

------------------------------------------------------------------------
-- The second eliminator

-- Pointwise lifting of binary relations to the delay monad.

Delayᴾ :
  ∀ {a r} {A : Type a} →
  (A → A → Type r) →
  Delay A → Delay A → Type r
Delayᴾ R = (ℕ →ᴾ Maybeᴾ R) on proj₁

module _
  {a r} {A : Type a} {R : A → A → Type r}
  where

  -- The function map ([_] {R = R}) respects Delayᴾ R.

  map-[]-cong :
    ∀ x y → Delayᴾ R x y → map ([_] {R = R}) x ≡ map [_] y
  map-[]-cong x y r =
    _↔_.to (equality-characterisation /-is-set)
      (⟨ext⟩ λ n → lemma (proj₁ x n) (proj₁ y n) (r n))
    where
    lemma : ∀ x y → Maybeᴾ R x y →
            mapᴹ [_] x ≡ mapᴹ [_] y
    lemma nothing  nothing  = const refl
    lemma (just x) (just y) = cong inj₂ ∘ []-respects-relation
    lemma nothing  (just y) ()
    lemma (just x) nothing  ()

  -- The function
  -- _↠_.from →↠Delay-function ∘ _↠_.to →↠Delay-function respects
  -- ℕ →ᴾ Maybeᴾ R.

  from-to-→↠Delay-function-cong :
    let open _↠_ →↠Delay-function in
    (f g : ℕ → Maybe A) →
    (ℕ →ᴾ Maybeᴾ R) f g →
    (ℕ →ᴾ Maybeᴾ R) (from (to f)) (from (to g))
  from-to-→↠Delay-function-cong f g r =
    helper f g r (f 0) (g 0) (r 0)
    where
    helper :
      ∀ f g → (ℕ →ᴾ Maybeᴾ R) f g →
      ∀ x y → Maybeᴾ R x y →
      (ℕ →ᴾ Maybeᴾ R)
        (proj₁ (Delay⇔Delay.from (Delay⇔Delay.To.to′ f x)))
        (proj₁ (Delay⇔Delay.from (Delay⇔Delay.To.to′ g y)))
    helper f g rs (just x) (just y) r n       = r
    helper f g rs nothing  nothing  r zero    = r
    helper f g rs nothing  nothing  r (suc n) =
      helper (f ∘ suc) (g ∘ suc) (rs ∘ suc) (f 1) (g 1) (rs 1) n

    helper _ _ _ (just _) nothing  ()
    helper _ _ _ nothing  (just _) ()

  -- A simplification lemma for →Maybe/→.

  →Maybe/→-[]′ :
    (f : ℕ → Maybe A) →
    →Maybe/→ [ f ] ≡
    map ([_] {R = R}) (_↠_.to →↠Delay-function f)
  →Maybe/→-[]′ f = _↔_.to (equality-characterisation /-is-set)
    (proj₁ (→Maybe/→ [ f ])                                           ≡⟨ cong proj₁ →Maybe/→-[] ⟩
     proj₁ (_↠_.to →↠Delay-function (_↔_.to Maybe/-comm′ ∘ [_] ∘ f))  ≡⟨ cong (λ g → proj₁ (_↠_.to →↠Delay-function (g ∘ f))) $ Maybe/-comm′-[] ⟩
     proj₁ (_↠_.to →↠Delay-function (mapᴹ [_] ∘ f))                   ≡⟨ ⟨ext⟩ (helper f (f 0)) ⟩
     mapᴹ [_] ∘ proj₁ (_↠_.to →↠Delay-function f)                     ≡⟨⟩
     proj₁ (map [_] (_↠_.to →↠Delay-function f))                      ∎)
    where
    helper :
       ∀ f x n →
       proj₁ (Delay⇔Delay.from
                (Delay⇔Delay.To.to′ (mapᴹ [_] ∘ f) (mapᴹ [_] x))) n ≡
       mapᴹ [_] (proj₁ (Delay⇔Delay.from (Delay⇔Delay.To.to′ f x)) n)
    helper f (just x) n       = refl
    helper f nothing  zero    = refl
    helper f nothing  (suc n) = helper (f ∘ suc) (f 1) n

-- The definitions below make use of some assumptions: countable
-- choice and a propositional equivalence relation R.

module _
  {a p r} {A : Type a} {R : A → A → Type r}
  (cc : Axiom-of-countable-choice (a ⊔ r))
  (R-equiv : Is-equivalence-relation R)
  (R-prop : ∀ {x y} → Is-proposition (R x y))
  (P : Delay (A / R) → Type p)
  (p-[] : (x : Delay A) → P (map [_] x))
  (ok : ∀ {x y} (r : Delayᴾ R x y) →
        subst P (map-[]-cong x y r) (p-[] x) ≡ p-[] y)
  (P-set : ∀ x → Is-set (P x))
  where

  private

    lemma₁ = sym ∘ →Maybe/→-[]′ {R = R}

    lemma₂ :
      ∀ {f g} r →
      subst P
        (cong →Maybe/→ ([]-respects-relation {x = f} {y = g} r))
        (subst P (lemma₁ f) (p-[] (_↠_.to →↠Delay-function f))) ≡
      subst P (lemma₁ g) (p-[] (_↠_.to →↠Delay-function g))
    lemma₂ {f} {g} r =
      let p  = p-[] (_↠_.to →↠Delay-function f)
          r′ = cong →Maybe/→ ([]-respects-relation {x = f} {y = g} r)
          r″ = trans (trans (lemma₁ f) r′) (sym (lemma₁ g))
      in
      subst P r′ (subst P (lemma₁ f) p)                               ≡⟨ subst-subst P (lemma₁ f) r′ p ⟩

      subst P (trans (lemma₁ f) r′) p                                 ≡⟨ cong (λ eq → subst P eq p) $
                                                                           sym $ trans-[trans-sym]- _ (lemma₁ g) ⟩
      subst P (trans r″ (lemma₁ g)) p                                 ≡⟨ sym $ subst-subst P
                                                                                (trans (trans (lemma₁ f) r′) (sym (lemma₁ g)))
                                                                                (lemma₁ g)
                                                                                p ⟩
      subst P (lemma₁ g) (subst P r″ p)                               ≡⟨ cong (λ eq → subst P (lemma₁ g) (subst P eq p)) $
                                                                           Delay-closure 0 /-is-set
                                                                             r″
                                                                             (map-[]-cong (_↠_.to →↠Delay-function f)
                                                                                (_↠_.to →↠Delay-function g)
                                                                                (from-to-→↠Delay-function-cong f g r)) ⟩
      subst P (lemma₁ g)
        (subst P (map-[]-cong (_↠_.to →↠Delay-function f)
                              (_↠_.to →↠Delay-function g)
                              (from-to-→↠Delay-function-cong f g r))
                 p)                                                   ≡⟨ cong (subst P (lemma₁ g)) (ok _) ⟩∎

      subst P (lemma₁ g) (p-[] (_↠_.to →↠Delay-function g))           ∎

  -- A second quotient-like eliminator for Delay (A / R).
  --
  -- This eliminator corresponds to Theorem 1 in "Quotienting the
  -- Delay Monad by Weak Bisimilarity" by Chapman, Uustalu and
  -- Veltri.

  Delay/-elim₂ : ∀ x → P x
  Delay/-elim₂ =
    Delay/-elim₁ cc R-equiv R-prop P
    (λ f → subst P (lemma₁ f) (p-[] (_↠_.to →↠Delay-function f)))
    lemma₂ P-set

  -- Simplification lemma for Delay/-elim₂.

  Delay/-elim₂-[] : ∀ x → Delay/-elim₂ (map [_] x) ≡ p-[] x
  Delay/-elim₂-[] x =
    Delay/-elim₁ cc R-equiv R-prop P
      (λ f → subst P (lemma₁ f) (p-[] (_↠_.to →↠Delay-function f)))
      lemma₂ P-set (map [_] x)                                           ≡⟨ sym $ dcong
                                                                                (Delay/-elim₁ cc R-equiv R-prop P
                                                                                (λ f → subst P (lemma₁ f)
                                                                                (p-[] (_↠_.to →↠Delay-function f)))
                                                                                lemma₂ P-set)
                                                                                lemma₃ ⟩
    subst P lemma₃
      (Delay/-elim₁ cc R-equiv R-prop P
         (λ f → subst P (lemma₁ f) (p-[] (_↠_.to →↠Delay-function f)))
         lemma₂ P-set (→Maybe/→ [ proj₁ x ]))                            ≡⟨ cong (subst P lemma₃) $
                                                                              Delay/-elim₁-[] cc R-equiv R-prop P _ lemma₂ P-set x ⟩
    subst P lemma₃
      (subst P (lemma₁ (proj₁ x))
         (p-[] (_↠_.to →↠Delay-function (proj₁ x))))                     ≡⟨ subst-subst P (lemma₁ (proj₁ x)) lemma₃ _ ⟩

    subst P (trans (lemma₁ (proj₁ x)) lemma₃)
      (p-[] (_↠_.to →↠Delay-function (proj₁ x)))                         ≡⟨ cong (λ p → subst P p (p-[] (_↠_.to →↠Delay-function (proj₁ x)))) $
                                                                              trans--[trans-sym]
                                                                                (lemma₁ (proj₁ x))
                                                                                (cong (map [_]) $ _↠_.right-inverse-of →↠Delay-function x) ⟩
    subst P (cong (map [_]) $ _↠_.right-inverse-of →↠Delay-function x)
      (p-[] (_↠_.to →↠Delay-function (proj₁ x)))                         ≡⟨ sym $ subst-∘ P (map [_]) (_↠_.right-inverse-of →↠Delay-function x) ⟩

    subst (P ∘ map [_]) (_↠_.right-inverse-of →↠Delay-function x)
      (p-[] (_↠_.to →↠Delay-function (proj₁ x)))                         ≡⟨ dcong p-[] (_↠_.right-inverse-of →↠Delay-function x) ⟩∎

    p-[] x                                                               ∎
    where
    lemma₃ =
      →Maybe/→ [ proj₁ x ]                         ≡⟨ sym $ lemma₁ (proj₁ x) ⟩
      map [_] (_↠_.to →↠Delay-function (proj₁ x))  ≡⟨ cong (map [_]) $ _↠_.right-inverse-of →↠Delay-function x ⟩∎
      map [_] x                                    ∎


module _ where

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

infix 0 case_of_
case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

blockOnFresh : TC ⊤
blockOnFresh =
  checkType unknown unknown >>= λ
  { (meta m _) → blockOnMeta m
  ; _ → typeError (strErr "impossible" ∷ []) }

macro
  weirdButShouldWork : Tactic
  weirdButShouldWork hole =
    inferType hole >>= λ goal →
    case goal of λ
    { (meta _ _) → blockOnFresh
    ; _ → unify hole (lit (nat 42))
    }

-- When the goal is a meta the tactic will block on a different, fresh, meta.
-- That's silly, but should still work. Once the goal is resolved the tactic
-- doesn't block any more so everything should be fine.
thing  : _
solves : Nat
thing  = weirdButShouldWork
solves = thing

check : thing ≡ 42
check = refl


------------------------------------------------------------------------
-- The double-negation monad
------------------------------------------------------------------------

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

open import Equality

module Double-negation
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection eq using (_↔_)
open Derived-definitions-and-properties eq
open import Equivalence eq hiding (id; _∘_)
open import Excluded-middle eq
open import H-level eq
open import H-level.Closure eq
open import Monad eq

-- The double-negation monad, defined using a wrapper type to make
-- instance resolution easier.

infix 3 ¬¬_

record ¬¬_ {a} (A : Type a) : Type a where
  constructor wrap
  field
    run : ¬ ¬ A

open ¬¬_ public

-- An extra universe-polymorphic variant of map.

map′ :
  ∀ {a b} {@0 A : Type a} {@0 B : Type b} →
  (A → B) → ¬¬ A → ¬¬ B
run (map′ f ¬¬a) = λ ¬b → run ¬¬a (λ a → ¬b (f a))

-- Instances.

instance

  double-negation-monad : ∀ {ℓ} → Raw-monad (λ (A : Type ℓ) → ¬¬ A)
  run (Raw-monad.return double-negation-monad x)   = _$ x
  run (Raw-monad._>>=_  double-negation-monad x f) =
    join (map′ (run ∘ f) x)
    where
    join : ∀ {a} {A : Type a} → ¬¬ ¬ A → ¬ A
    join ¬¬¬a = λ a → run ¬¬¬a (λ ¬a → ¬a a)

private

  proof-irrelevant : ∀ {a} {A : Type a} {x y : ¬¬ A} →
                     Extensionality a lzero → x ≡ y
  proof-irrelevant ext =
    cong wrap $ apply-ext ext λ _ → ⊥-propositional _ _

monad : ∀ {ℓ} →
        Extensionality ℓ lzero →
        Monad (λ (A : Type ℓ) → ¬¬ A)
Monad.raw-monad      (monad _)         = double-negation-monad
Monad.left-identity  (monad ext) _ _   = proof-irrelevant ext
Monad.right-identity (monad ext) _     = proof-irrelevant ext
Monad.associativity  (monad ext) _ _ _ = proof-irrelevant ext

-- The following variant of excluded middle is provable.

excluded-middle : ∀ {a} {@0 A : Type a} → ¬¬ Dec A
run excluded-middle ¬[a⊎¬a] = ¬[a⊎¬a] (no λ a → ¬[a⊎¬a] (yes a))

-- The following variant of Peirce's law is provable.

call/cc : ∀ {a w} {@0 A : Type a} {Whatever : Type w} →
          ((A → Whatever) → ¬¬ A) → ¬¬ A
run (call/cc hyp) ¬a = run (hyp (λ a → ⊥-elim (¬a a))) ¬a

-- If one can prove that the empty type is inhabited in the
-- double-negation monad, then the empty type is inhabited.

¬¬¬⊥ : ∀ {ℓ} → ¬ (¬¬ (⊥ {ℓ = ℓ}))
¬¬¬⊥ ¬¬⊥ = run ¬¬⊥ ⊥-elim

-- If the double-negation of a negation can be proved, then the
-- negation itself can be proved.

¬¬¬→¬ : ∀ {a} {A : Type a} → ¬¬ ¬ A → ¬ A
¬¬¬→¬ ¬¬¬a = λ a → ¬¬¬⊥ (¬¬¬a >>= λ ¬a → ⊥-elim (¬a a))

------------------------------------------------------------------------
-- Excluded middle and double-negation elimination

-- Double-negation elimination (roughly as stated in the HoTT book).

Double-negation-elimination : (ℓ : Level) → Type (lsuc ℓ)
Double-negation-elimination p =
  {P : Type p} → Is-proposition P → ¬¬ P → P

-- Double-negation elimination is propositional (assuming
-- extensionality).

Double-negation-elimination-propositional :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) ℓ →
  Is-proposition (Double-negation-elimination ℓ)
Double-negation-elimination-propositional ext =
  implicit-Π-closure ext 1 λ _ →
  Π-closure (lower-extensionality _ lzero ext) 1 λ P-prop →
  Π-closure (lower-extensionality _ lzero ext) 1 λ _ →
  P-prop

-- Excluded middle implies double-negation elimination.

Excluded-middle→Double-negation-elimination :
  ∀ {ℓ} → Excluded-middle ℓ → Double-negation-elimination ℓ
Excluded-middle→Double-negation-elimination em P-prop ¬¬p =
  [ id , ⊥-elim ∘ run ¬¬p ] (em P-prop)

-- Excluded middle is pointwise equivalent to double-negation
-- elimination (assuming extensionality).

Excluded-middle≃Double-negation-elimination :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) (lsuc ℓ) →
  Excluded-middle ℓ ≃ Double-negation-elimination ℓ
Excluded-middle≃Double-negation-elimination ext =
  _↔_.to (⇔↔≃ ext
              (Excluded-middle-propositional
                 (lower-extensionality lzero _ ext))
              (Double-negation-elimination-propositional
                 (lower-extensionality lzero _ ext)))
    (record
       { to   = Excluded-middle→Double-negation-elimination
       ; from = λ dne P-prop →
                  dne (Dec-closure-propositional
                         (lower-extensionality _ _ ext) P-prop)
                      excluded-middle
       })


module Tactic.Nat.Simpl.Lemmas where

open import Prelude
open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Container.Bag
open import Tactic.Nat.Auto
open import Prelude.Nat.Properties
open import Container.List.Properties
open import Tactic.Nat.Auto.Lemmas

product1-sound : ∀ xs → product1 xs ≡ productR xs
product1-sound [] = refl
product1-sound (x ∷ xs)
  rewrite sym (cong (λ x → foldl _*_ x xs) (mul-one-r x))
        | foldl-assoc _*_ mul-assoc x 1 xs
        | foldl-foldr _*_ 1 mul-assoc add-zero-r mul-one-r xs
        = refl

map-eq : ∀ {c b} {A : Set c} {B : Set b} (f g : A → B) →
           (∀ x → f x ≡ g x) → ∀ xs → map f xs ≡ map g xs
map-eq f g f=g [] = refl
map-eq f g f=g (x ∷ xs) rewrite f=g x | map-eq f g f=g xs = refl

fst-*** : ∀ {a b} {A₁ A₂ : Set a} {B₁ B₂ : Set b}
            (f : A₁ → B₁) (g : A₂ → B₂) (p : A₁ × A₂) →
            fst ((f *** g) p) ≡ f (fst p)
fst-*** f g (x , y) = refl

snd-*** : ∀ {a b} {A₁ A₂ : Set a} {B₁ B₂ : Set b}
            (f : A₁ → B₁) (g : A₂ → B₂) (p : A₁ × A₂) →
            snd ((f *** g) p) ≡ g (snd p)
snd-*** f g (x , y) = refl

eta : ∀ {a b} {A : Set a} {B : Set b} (p : A × B) → p ≡ (fst p , snd p)
eta (x , y) = refl

private
  shuffle₁ : (a b c : Nat) → a + (b + c) ≡ b + (a + c)
  shuffle₁ a b c = auto

module _ {Atom : Set} {{_ : Ord Atom}} where

  NFEqS : NF Atom × NF Atom → Env Atom → Set
  NFEqS (nf₁ , nf₂) ρ = ⟦ nf₁ ⟧ns ρ ≡ ⟦ nf₂ ⟧ns ρ

  NFEq : NF Atom × NF Atom → Env Atom → Set
  NFEq (nf₁ , nf₂) ρ = ⟦ nf₁ ⟧n ρ ≡ ⟦ nf₂ ⟧n ρ

  ts-sound : ∀ x (ρ : Env Atom) → ⟦ x ⟧ts ρ ≡ ⟦ x ⟧t ρ
  ts-sound (0 , x) ρ = mul-zero-r (product1 (map ρ x))
  ts-sound (1 , x) ρ = product1-sound (map ρ x) ⟨≡⟩ʳ add-zero-r _
  ts-sound (suc (suc i) , x) ρ
    rewrite sym (product1-sound (map ρ x))
          = auto

  private
    et : Env Atom → Nat × Tm Atom → Nat
    et  = flip ⟦_⟧t

    ets : Env Atom → Nat × Tm Atom → Nat
    ets = flip ⟦_⟧ts

    plus-nf : Nat → Env Atom → NF Atom → Nat
    plus-nf = λ a ρ xs → a + ⟦ xs ⟧n ρ

  ns-sound : ∀ nf (ρ : Env Atom) → ⟦ nf ⟧ns ρ ≡ ⟦ nf ⟧n ρ
  ns-sound [] ρ = refl
  ns-sound (x ∷ nf) ρ
    rewrite sym (foldl-map-fusion _+_ (ets ρ) (ets ρ x) nf)
          | ts-sound x ρ
          | map-eq (ets ρ) (et ρ) (flip ts-sound ρ) nf
          | sym (foldl-foldr _+_ 0 add-assoc (λ _ → refl) add-zero-r (map (et ρ) nf))
          | sym (foldl-assoc _+_ add-assoc (et ρ x) 0 (map (et ρ) nf))
          | add-zero-r (et ρ x)
          = refl

  private
    lem-sound : ∀ a b ρ f g (xs : NF Atom × NF Atom) →
            a + ⟦ fst ((f *** g) xs) ⟧n ρ ≡ b + ⟦ snd ((f *** g) xs) ⟧n ρ →
            a + ⟦ f (fst xs) ⟧n ρ         ≡ b + ⟦ g (snd xs) ⟧n ρ
    lem-sound a b ρ f g xs H =
      cong (plus-nf a ρ) (fst-*** f g xs)
      ʳ⟨≡⟩ H
       ⟨≡⟩ cong (plus-nf b ρ) (snd-*** f g xs)

  cancel-sound′ : ∀ a b nf₁ nf₂ (ρ : Env Atom) →
                    a + ⟦ fst (cancel nf₁ nf₂) ⟧n ρ ≡ b + ⟦ snd (cancel nf₁ nf₂) ⟧n ρ →
                    a + ⟦ nf₁ ⟧n ρ ≡ b + ⟦ nf₂ ⟧n ρ
  cancel-sound′ a b [] []        ρ H = H
  cancel-sound′ a b [] (x ∷ nf₂) ρ H = H
  cancel-sound′ a b (x ∷ nf₁) [] ρ H = H
  cancel-sound′ a b ((i , x) ∷ nf₁) ((j , y) ∷ nf₂) ρ H
    with compare x y
  ... | less _ = add-assoc a _ _ ⟨≡⟩ cancel-sound′ (a + et ρ (i , x)) b nf₁ ((j , y) ∷ nf₂) ρ
                   (add-assoc a _ _ ʳ⟨≡⟩ lem-sound a b ρ (_∷_ (i , x)) id (cancel nf₁ ((j , y) ∷ nf₂)) H)
  ... | greater _ =
          cancel-sound′ a (b + et ρ (j , y)) ((i , x) ∷ nf₁) nf₂ ρ
            (lem-sound a b ρ id (_∷_ (j , y)) (cancel ((i , x) ∷ nf₁) nf₂) H ⟨≡⟩ add-assoc b _ _)
          ⟨≡⟩ʳ add-assoc b _ _
  cancel-sound′ a b ((i , x) ∷ nf₁) ((j , .x) ∷ nf₂) ρ H | equal refl
    with compare i j
  cancel-sound′ a b ((i , x) ∷ nf₁) ((.(suc k + i) , .x) ∷ nf₂) ρ H | equal refl | less (diff! k) =
    shuffle₁ a (et ρ (i , x)) _
    ⟨≡⟩ cong (et ρ (i , x) +_) (cancel-sound′ a (b + et ρ (suc k , x)) nf₁ nf₂ ρ
          (lem-sound a b ρ id (_∷_ (suc k , x)) (cancel nf₁ nf₂) H ⟨≡⟩ add-assoc b _ _))
    ⟨≡⟩ auto
  cancel-sound′ a b ((.(suc k + j) , x) ∷ nf₁) ((j , .x) ∷ nf₂) ρ H | equal refl | greater (diff! k) =
    sym (shuffle₁ b (et ρ (j , x)) _
         ⟨≡⟩ cong (et ρ (j , x) +_) (sym (cancel-sound′ (a + et ρ (suc k , x)) b nf₁ nf₂ ρ
               (add-assoc a _ _ ʳ⟨≡⟩ lem-sound a b ρ (_∷_ (suc k , x)) id (cancel nf₁ nf₂) H)))
         ⟨≡⟩ auto)
  cancel-sound′ a b ((i , x) ∷ nf₁) ((.i , .x) ∷ nf₂) ρ H | equal refl | equal refl =
    shuffle₁ a (et ρ (i , x)) _
    ⟨≡⟩ cong (et ρ (i , x) +_) (cancel-sound′ a b nf₁ nf₂ ρ H)
    ⟨≡⟩ shuffle₁ (et ρ (i , x)) b _

  cancel-sound-s′ : ∀ a b nf₁ nf₂ (ρ : Env Atom) →
                         a + ⟦ fst (cancel nf₁ nf₂) ⟧ns ρ ≡ b + ⟦ snd (cancel nf₁ nf₂) ⟧ns ρ →
                         a + ⟦ nf₁ ⟧ns ρ ≡ b + ⟦ nf₂ ⟧ns ρ
  cancel-sound-s′ a b nf₁ nf₂ ρ eq =
    (a +_) $≡ ns-sound nf₁ ρ ⟨≡⟩
    cancel-sound′ a b nf₁ nf₂ ρ
      ((a +_) $≡ ns-sound (fst (cancel nf₁ nf₂)) ρ ʳ⟨≡⟩
       eq ⟨≡⟩ (b +_) $≡ ns-sound (snd (cancel nf₁ nf₂)) ρ) ⟨≡⟩ʳ
    (b +_) $≡ ns-sound nf₂ ρ

  cancel-sound : ∀ nf₁ nf₂ ρ → NFEqS (cancel nf₁ nf₂) ρ → NFEq (nf₁ , nf₂) ρ
  cancel-sound nf₁ nf₂ ρ H rewrite cong (λ p → NFEqS p ρ) (eta (cancel nf₁ nf₂)) =
    (cancel-sound′ 0 0 nf₁ nf₂ ρ
      (ns-sound (fst (cancel nf₁ nf₂)) ρ
         ʳ⟨≡⟩ H ⟨≡⟩
       ns-sound (snd (cancel nf₁ nf₂)) ρ))

  private
    prod : Env Atom → List Atom → Nat
    prod ρ x = productR (map ρ x)

  private
    lem-complete : ∀ a b ρ f g (xs : NF Atom × NF Atom) →
            a + ⟦ f (fst xs) ⟧n ρ         ≡ b + ⟦ g (snd xs) ⟧n ρ →
            a + ⟦ fst ((f *** g) xs) ⟧n ρ ≡ b + ⟦ snd ((f *** g) xs) ⟧n ρ
    lem-complete a b ρ f g xs H =
      cong (plus-nf a ρ) (fst-*** f g xs)
       ⟨≡⟩  H
       ⟨≡⟩ʳ cong (plus-nf b ρ) (snd-*** f g xs)

  cancel-complete′ : ∀ a b nf₁ nf₂ (ρ : Env Atom) →
                       a + ⟦ nf₁ ⟧n ρ ≡ b + ⟦ nf₂ ⟧n ρ →
                       a + ⟦ fst (cancel nf₁ nf₂) ⟧n ρ ≡ b + ⟦ snd (cancel nf₁ nf₂) ⟧n ρ
  cancel-complete′ a b [] [] ρ H = H
  cancel-complete′ a b [] (x ∷ nf₂) ρ H = H
  cancel-complete′ a b (x ∷ nf₁) [] ρ H = H
  cancel-complete′ a b ((i , x) ∷ nf₁) ((j , y) ∷ nf₂) ρ H with compare x y
  ... | less lt =
    lem-complete a b ρ (_∷_ (i , x)) id (cancel nf₁ ((j , y) ∷ nf₂))
      (add-assoc a _ _
       ⟨≡⟩ cancel-complete′ (a + et ρ (i , x)) b nf₁ ((j , y) ∷ nf₂) ρ
             (add-assoc a _ _ ʳ⟨≡⟩ H))
  ... | greater _ =
    lem-complete a b ρ id (_∷_ (j , y)) (cancel ((i , x) ∷ nf₁) nf₂)
      (cancel-complete′ a (b + et ρ (j , y)) ((i , x) ∷ nf₁) nf₂ ρ
        (H ⟨≡⟩ add-assoc b _ _)
       ⟨≡⟩ʳ add-assoc b _ _)
  cancel-complete′ a b ((i , x) ∷ nf₁) ((j , .x) ∷ nf₂) ρ H | equal refl with compare i j
  cancel-complete′ a b ((i , x) ∷ nf₁) ((.(suc (k + i)) , .x) ∷ nf₂) ρ H | equal refl | less (diff! k) =
    lem-complete a b ρ id (_∷_ (suc k , x)) (cancel nf₁ nf₂)
      (cancel-complete′ a (b + suc k * prod ρ x) nf₁ nf₂ ρ
        (add-inj₂ (i * prod ρ x) _ _
          (shuffle₁ (i * prod ρ x) a _
            ⟨≡⟩ H ⟨≡⟩ auto))
      ⟨≡⟩ʳ add-assoc b _ _)
  cancel-complete′ a b ((.(suc (k + j)) , x) ∷ nf₁) ((j , .x) ∷ nf₂) ρ H | equal refl | greater (diff! k) =
    lem-complete a b ρ (_∷_ (suc k , x)) id (cancel nf₁ nf₂)
      (add-assoc a _ _ ⟨≡⟩
       cancel-complete′ (a + suc k * prod ρ x) b nf₁ nf₂ ρ
         (add-inj₂ (j * prod ρ x) _ _
           (sym (shuffle₁ (j * prod ρ x) b _ ⟨≡⟩ʳ
                 auto ʳ⟨≡⟩ H))))
  cancel-complete′ a b ((i , x) ∷ nf₁) ((.i , .x) ∷ nf₂) ρ H | equal refl | equal refl =
    cancel-complete′ a b nf₁ nf₂ ρ
      (add-inj₂ (i * prod ρ x) _ _
        (shuffle₁ a (i * prod ρ x) _ ʳ⟨≡⟩ H ⟨≡⟩ shuffle₁ b (i * prod ρ x) _))

  cancel-complete-s′ : ∀ a b nf₁ nf₂ (ρ : Env Atom) →
                         a + ⟦ nf₁ ⟧ns ρ ≡ b + ⟦ nf₂ ⟧ns ρ →
                         a + ⟦ fst (cancel nf₁ nf₂) ⟧ns ρ ≡ b + ⟦ snd (cancel nf₁ nf₂) ⟧ns ρ
  cancel-complete-s′ a b nf₁ nf₂ ρ eq =
    (a +_) $≡ ns-sound (fst (cancel nf₁ nf₂)) ρ ⟨≡⟩
    cancel-complete′ a b nf₁ nf₂ ρ
      ((a +_) $≡ ns-sound nf₁ ρ ʳ⟨≡⟩
       eq ⟨≡⟩ (b +_) $≡ ns-sound nf₂ ρ) ⟨≡⟩ʳ
    (b +_) $≡ ns-sound (snd (cancel nf₁ nf₂)) ρ

  cancel-complete : ∀ nf₁ nf₂ ρ → NFEq (nf₁ , nf₂) ρ → NFEqS (cancel nf₁ nf₂) ρ
  cancel-complete nf₁ nf₂ ρ H rewrite cong (λ p → NFEqS p ρ) (eta (cancel nf₁ nf₂)) =
         ns-sound (fst (cancel nf₁ nf₂)) ρ
    ⟨≡⟩  cancel-complete′ 0 0 nf₁ nf₂ ρ H
    ⟨≡⟩ʳ ns-sound (snd (cancel nf₁ nf₂)) ρ


open import Silica
open import HeapProperties
import Context

open TypeEnvContext

open import Data.Nat
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Empty
import Relation.Binary.PropositionalEquality as Eq

data Preservation : Expr → Set where
  pres : ∀ {e e' : Expr}
       → ∀ {T T' : Type}
       → ∀ {Δ Δ'' Δ''' : StaticEnv}
       → ∀ {Σ Σ' : RuntimeEnv }
       → Δ ⊢ e ⦂ T ⊣ Δ''
       → Σ & Δ ok
       -- TODO: hdref(e)
       → Σ , e ⟶ Σ' , e'
       → (Δ' : StaticEnv)
       → (Δ' ⊢ e' ⦂ T' ⊣ Δ''')
       → (Σ' & Δ' ok)  --
       → (Δ''' <* Δ'')
       -----------------
       → Preservation e

splitIdempotent : ∀ {Γ T₁ T₂ T₃}
                    → Γ ⊢ T₁ ⇛ T₂ / T₃
                    → Γ ⊢ T₂ ⇛ T₂ / T₃
splitIdempotent {Γ} {.(base Void)} {.(base Void)} {.(base Void)} voidSplit = voidSplit
splitIdempotent {Γ} {.(base Boolean)} {.(base Boolean)} {.(base Boolean)} booleanSplit = booleanSplit
splitIdempotent {Γ} {.(contractType _)} {.(contractType _)} {.(contractType _)} (unownedSplit namesEq1 namesEq2 permsEq permUnowned) =
  unownedSplit refl (Eq.trans (Eq.sym namesEq1) namesEq2) refl permUnowned
splitIdempotent {Γ} {.(contractType _)} {.(contractType _)} {.(contractType _)} (shared-shared-shared x) =
  shared-shared-shared x
splitIdempotent {Γ} {.(contractType (tc _ Owned))} {.(contractType (tc _ Shared))} {.(contractType (tc _ Shared))} (owned-shared x) =
  shared-shared-shared refl
splitIdempotent {Γ} {.(contractType (record { contractName = _ ; perm = S _ }))}
                    {.(contractType (record { contractName = _ ; perm = Shared }))}
                    {.(contractType (record { contractName = _ ; perm = Shared }))}
                    (states-shared x) =
                    shared-shared-shared refl

preservation : ∀ {e e' : Expr}
               → {Γ : ContractEnv.ctx}
               → ∀ {T : Type}
               → ∀ {Δ Δ'' : StaticEnv}
               → ∀ {Σ Σ' : RuntimeEnv}
               → Δ ⊢ e ⦂ T ⊣ Δ''
               → Σ & Δ ok
               → Σ , e ⟶ Σ' , e'
               -----------------------
               → Preservation e

-- Proof proceeds by induction on the dynamic semantics.

preservation ty@(locTy {Γ} {Δ₀} l voidSplit) consis st@(SElookup {l = l} {v = voidVal} _ lookupL) =
  let
    Δ = (Δ₀ ,ₗ l ⦂ base Void)
    Δ' = Δ
    e'TypingJudgment = voidTy {Γ} {Δ = Δ'}
  in
    pres ty consis st Δ' e'TypingJudgment consis <*-refl
preservation ty@(locTy {Γ} {Δ₀} l booleanSplit) consis st@(SElookup {l = l} {v = boolVal b} _ lookupL) =
 let
    Δ = (Δ₀ ,ₗ l ⦂ base Boolean)
    Δ' = Δ
    e'TypingJudgment = boolTy {Γ} {Δ = Δ'} b
  in
    pres {Δ = Δ} ty consis st Δ' e'TypingJudgment consis <*-refl
-- The code duplication below is very sad, but I haven't figured out a way that doesn't require refactoring the split judgment to be two-level.
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(unownedSplit _ _ _ _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
  let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected

preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(shared-shared-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(owned-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected
preservation ty@(locTy {Γ} {Δ₀} {T₁ = contractType t₁} {T₂ = contractType t₂} {T₃ = contractType t₃} l spl@(states-shared _))
                       consis@(ok Δ voidLookup boolLookup objLookup refConsistencyFunc)
                       st@(SElookup {Σ} {l = l} {v = objVal o} _ lookupL) =
   let
    spl' = splitIdempotent spl
    e'TypingJudgment = objTy {Γ} {Δ = Δ''} {T₁ = contractType t₂} {T₂ = contractType t₂} {T₃ = contractType t₃} o spl'

    consis' = ok {Σ} Δ' voidLookup' boolLookup' objLookup' refConsistency'
  in
    pres {_} {_} {_} {_} {Δ = Δ} {Δ'' = Δ''} {_} {_} {_} ty consis st Δ' e'TypingJudgment consis' <*-o-extension
  where
    splT = splitType spl
    Δ'' = Δ₀ ,ₗ l ⦂ (SplitType.t₃ splT) -- This is the result of checking e.
    Δ' = Δ'' ,ₒ o ⦂ (SplitType.t₂ splT) -- This is the typing context in which we need to typecheck e'.
    --Δ = Δ₀ ,ₗ l ⦂ (SplitType.t₁ splT)
    -- Show that if you look up l in the new context, you get the same type as before.
    voidLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Void
                  → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ voidVal)))
    voidLookup' l' l'InΔ' with l' Data.Nat.≟ l
    voidLookup' l' (Context.S l'NeqL l'VoidType) | yes eq = ⊥-elim (l'NeqL eq)
    voidLookup' l' l'InΔ' | no nEq = voidLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    boolLookup' : (∀ (l' : IndirectRef)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ base Boolean
                  → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ boolVal b)))
    boolLookup' l' l'InΔ' with l' Data.Nat.≟ l
    boolLookup' l' (Context.S l'NeqL l'BoolType) | yes eq = ⊥-elim (l'NeqL eq)
    boolLookup' l' l'InΔ' | no nEq = boolLookup l' (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    objLookup' : (l' : IndirectRef) → (T : Tc)
                  → ((StaticEnv.locEnv Δ') ∋ l' ⦂ (contractType T)
                  → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l' ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))))
    objLookup' l' _ l'InΔ' with l' Data.Nat.≟ l
    objLookup' l' _ (Context.S l'NeqL l'ObjType) | yes eq = ⊥-elim (l'NeqL eq)
    objLookup' l' t l'InΔ'@(Z {a = contractType t₃}) | yes eq = objLookup l' t₁ Z
    objLookup' l' t l'InΔ' | no nEq = objLookup l' t (S nEq (irrelevantReductionsOK l'InΔ' nEq))

    lookupUnique : objVal o ≡ objVal ( proj₁ (objLookup l t₁ Z))
    lookupUnique = IndirectRefContext.contextLookupUnique {RuntimeEnv.ρ Σ} lookupL (proj₁ (proj₂ (objLookup l t₁ Z)))
    oLookupUnique = objValInjectiveContrapositive lookupUnique

    -- Show that all location-based aliases from the previous environment are compatible with the new alias.
    -- Note that Σ is unchanged, so we use Σ instead of defining a separate Σ'.
    refConsistency' : (o' : ObjectRef) → o' ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ' o'
    refConsistency' o' o'Inμ =
      let
        origRefConsistency = refConsistencyFunc o' o'Inμ
        origConnected =  referencesConsistentImpliesConnectivity origRefConsistency
        newConnected = splitReplacementOK {Γ} {Σ} {Δ₀} {o} {o'} {l} {t₁} {t₂} {SplitType.t₁ splT} {SplitType.t₂ splT} {SplitType.t₃ splT}
                                          refl refl consis oLookupUnique (proj₁ origConnected) (proj₂ origConnected) spl
      in
        referencesConsistent {_} {_} {o'} newConnected

preservation {T = contractType t₂}
  (locTy {Γ} {Δ₀} {contractType t₁} {.(contractType t₂)} {contractType t₃} l spl)
  (ok .(Δ₀ ,ₗ l ⦂ contractType t₁) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {l = l} {boolVal b} _ lookupL) =
    -- The context says the location refers to a contract, but also a boolean value?? Inconsistent.
      ⊥-elim (lookupNeq lookupUnique)
    where
      objLookupResult = objLookup l t₁ Z
      o = proj₁ objLookupResult
      lHasObjType = proj₁ (proj₂ objLookupResult)
      lookupUnique = IndirectRefContext.contextLookupUnique lHasObjType lookupL
      lookupNeq : (objVal o) ≢ boolVal b
      lookupNeq ()

preservation {T = contractType t₂}
  (locTy {Γ} {Δ₀} {contractType t₁} {.(contractType t₂)} {contractType t₃} l spl)
  (ok .(Δ₀ ,ₗ l ⦂ contractType t₁) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {l = l} {voidVal} _ lookupL) =
    -- The context says the location refers to a contract, but also a boolean value?? Inconsistent.
      ⊥-elim (lookupNeq lookupUnique)
    where
      objLookupResult = objLookup l t₁ Z
      o = proj₁ objLookupResult
      lHasObjType = proj₁ (proj₂ objLookupResult)
      lookupUnique = IndirectRefContext.contextLookupUnique lHasObjType lookupL
      lookupNeq : (objVal o) ≢ voidVal
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Void)} l voidSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Void) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {boolVal b} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = voidLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique lLookupResult lookupL
      lookupNeq : voidVal ≢ boolVal b
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Void)} l voidSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Void) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {objVal o} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = voidLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique lLookupResult lookupL
      lookupNeq : voidVal ≢ objVal o
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Boolean)} l booleanSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Boolean) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {voidVal} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = boolLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique (proj₂ lLookupResult) lookupL
      lookupNeq : boolVal (proj₁ lLookupResult) ≢ voidVal
      lookupNeq ()

preservation
  (locTy {Γ} {Δ₀} {.(base Boolean)} l booleanSplit)
  (ok .(Δ₀ ,ₗ l ⦂ base Boolean) voidLookup boolLookup objLookup refConsistencyFunc)
  (SElookup {Σ} {Δ} {T = T} {l = l} {objVal o} lookupLType lookupL) =
            ⊥-elim (lookupNeq lookupUnique)
    where
      lLookupResult = boolLookup l Z
      lookupUnique = IndirectRefContext.contextLookupUnique (proj₂ lLookupResult) lookupL
      lookupNeq : boolVal (proj₁ lLookupResult) ≢ objVal o
      lookupNeq ()

preservation {Γ = Γ} {Δ = Δ} {Δ'' = Δ''} ty@(assertTyₓ _ _) consis st@(SEassertₓ x s) =
  pres ty consis st Δ (voidTy {Γ = Γ} {Δ = Δ}) consis <*-refl
preservation {Γ = Γ} {Δ = Δ} {Δ'' = Δ''} ty@(assertTyₗ _ _) consis st@(SEassertₗ x s) =
  pres ty consis st Δ (voidTy {Γ = Γ} {Δ = Δ}) consis <*-refl

preservation  {Γ = Γ} {Δ = Δ} {Δ'' = Δ''}
  ty@(newTy {C = C} {st = st} stOK ty₁ ty₂ CInΓ refl)
  consis
  step@(SEnew {Σ} {o = o} oFresh refl refl) =
    pres ty consis step Δ' newTypeJudgment {!!} {!!}
    where
      T = contractType (tc C (S [ st ]) )
      Δ' = Δ ,ₒ o ⦂ T
      spl = unownedSplit {Γ} refl refl refl refl
      newTypeJudgment = objTy o spl


module _ where

open import Agda.Builtin.Nat

postulate
  T : Set

  C₁ : Set
  instance I₁ : C₁

  C₂ : Nat → Set
  instance I₂ : ∀ {n} → C₂ n

it : {A : Set} {{_ : A}} → A
it {{x}} = x

postulate
  f₁ : {{_ : Nat → C₁}} → T
  f₂ : {{_ : ∀ n → C₂ n}} → T

works₁ : T
works₁ = f₁         -- f₁ {{λ _ → I₁}}

fails₁ : T
fails₁ = f₁ {{it}}  -- internal error

works₂ : T
works₂ = f₂         -- f₂ {{λ n → I₂ {n}}}

fails₂ : T
fails₂ = f₂ {{it}}  -- internal error


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Fst {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as Wk hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Introductions.Pi

open import Tools.Product
import Tools.PropositionalEquality as PE

fst-subst* : ∀ {Γ F G t t′} → Γ ⊢ F → Γ ∙ F ⊢ G
             → Γ ⊢ t ⇒* t′ ∷ Σ F ▹ G → Γ ⊢ fst t ⇒* fst t′ ∷ F
fst-subst* ⊢F ⊢G (id x) = id (fstⱼ ⊢F ⊢G x)
fst-subst* ⊢F ⊢G (x ⇨ t⇒t′) = fst-subst ⊢F ⊢G x ⇨ fst-subst* ⊢F ⊢G t⇒t′

-- Reducibility of fst with a specific typing derivation
fst′ : ∀ {F G t Γ l l′}
       ([F] : Γ ⊩⟨ l′ ⟩ F)
       ([ΣFG] : Γ ⊩⟨ l ⟩B⟨ BΣ ⟩ Σ F ▹ G)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ Σ F ▹ G / B-intr BΣ [ΣFG])
       → Γ ⊩⟨ l′ ⟩ fst t ∷ F / [F]
fst′ {F = F} {t = t} {Γ = Γ} [F] (noemb (Bᵣ F' G' D ⊢F ⊢G A≡A [F'] [G'] G-ext))
     (Σₜ p d pProd p≅p [fstp] [sndp]) with
       B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let [fstp] : Γ ⊩⟨ _ ⟩ fst p ∷ F / [F]
      [fstp] = irrelevanceTerm′ (wk-id F)
                                ([F'] id (wf ⊢F)) [F]
                                [fstp]
  in  proj₁ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d))
                           [F] [fstp])
fst′ {t = t} {Γ = Γ} {l = l} [F] (emb 0<1 x) [t] = fst′ [F] x [t]

-- Reducibility of fst with a general typing derivation
fst″ : ∀ {F G t Γ l l′}
       ([F] : Γ ⊩⟨ l′ ⟩ F)
       ([ΣFG] : Γ ⊩⟨ l ⟩ Σ F ▹ G)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ Σ F ▹ G / [ΣFG])
       → Γ ⊩⟨ l′ ⟩ fst t ∷ F / [F]
fst″ {t = t} {Γ = Γ} {l = l} [F] [ΣFG] [t] =
  let [t]′ = irrelevanceTerm [ΣFG] (B-intr BΣ (Σ-elim [ΣFG])) [t]
  in  fst′ [F] (Σ-elim [ΣFG]) [t]′

fst-cong′ : ∀ {F G t t′ Γ l l′}
            ([F] : Γ ⊩⟨ l′ ⟩ F)
            ([ΣFG] : Γ ⊩⟨ l ⟩B⟨ BΣ ⟩ Σ F ▹ G)
            ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / B-intr BΣ [ΣFG])
            → Γ ⊩⟨ l′ ⟩ fst t ≡ fst t′ ∷ F / [F]
fst-cong′ {F = F} {G = G} {Γ = Γ} [F]
          [ΣFG]@(noemb (Bᵣ F' G' D ⊢F ⊢G A≡A [F'] [G'] G-ext))
          [t≡t′]@(Σₜ₌ p p′ d d′ pProd pProd′ p≅p′ [t] [t′] [fstp] [fstp′] [fst≡] [snd≡]) with
            B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let ⊢Γ = wf ⊢F
      [fstp]₁ = irrelevanceTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fstp]
      [fstp′]₁ = irrelevanceTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fstp′]
      [fst≡]₁ = irrelevanceEqTerm′ (wk-id F) ([F'] id ⊢Γ) [F] [fst≡]
      [fstt≡fstp] = proj₂ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d)) [F] [fstp]₁)
      [fstt′≡fstp′] = proj₂ (redSubst*Term (fst-subst* ⊢F ⊢G (redₜ d′)) [F] [fstp′]₁)
  in  transEqTerm [F] [fstt≡fstp] (transEqTerm [F] [fst≡]₁ (symEqTerm [F] [fstt′≡fstp′]))
fst-cong′ [F] (emb 0<1 x) = fst-cong′ [F] x

-- Reducibility of congruence of fst
fst-cong″ : ∀ {F G t t′ Γ l l′}
            ([F] : Γ ⊩⟨ l′ ⟩ F)
            ([ΣFG] : Γ ⊩⟨ l ⟩ Σ F ▹ G)
            ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / [ΣFG])
            → Γ ⊩⟨ l′ ⟩ fst t ≡ fst t′ ∷ F / [F]
fst-cong″ {F} {G} [F] [ΣFG] [t≡t′] =
  let [t≡t′] = irrelevanceEqTerm [ΣFG] (B-intr BΣ (Σ-elim [ΣFG])) [t≡t′]
  in  fst-cong′ [F] (Σ-elim [ΣFG]) [t≡t′]

fst-congᵛ : ∀ {F G t t′ Γ l}
            ([Γ] : ⊩ᵛ Γ)
            ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
            ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
            ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
            ([t′] : Γ ⊩ᵛ⟨ l ⟩ t′ ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
            ([t≡t′] : Γ ⊩ᵛ⟨ l ⟩ t ≡ t′ ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
          → Γ ⊩ᵛ⟨ l ⟩ fst t ≡ fst t′ ∷ F / [Γ] / [F]
fst-congᵛ {F} {G} [Γ] [F] [G] [t] [t′] [t≡t′] ⊢Δ [σ] =
  let [ΣFG] = Σᵛ {F} {G} [Γ] [F] [G]
      ⊩σF = proj₁ ([F] ⊢Δ [σ])
      ⊩σΣFG = proj₁ ([ΣFG] ⊢Δ [σ])
      ⊩σt≡t′ = [t≡t′] ⊢Δ [σ]
  in  fst-cong″ ⊩σF ⊩σΣFG ⊩σt≡t′

-- Validity of first projection
fstᵛ : ∀ {F G t Γ l}
       ([Γ] : ⊩ᵛ Γ)
       ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
       ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
       ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G])
       → Γ ⊩ᵛ⟨ l ⟩ fst t ∷ F / [Γ] / [F]
fstᵛ {F} {G} {t} {Γ} {l} [Γ] [F] [G] [t] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [ΣFG] = Σᵛ {F} {G} [Γ] [F] [G]
      σfst : ∀ {Δ σ} (⊢Δ : ⊢ Δ) ([σ] : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ)
           → Δ ⊩⟨ l ⟩ subst σ (fst t) ∷ subst σ F / proj₁ ([F] ⊢Δ [σ])
      σfst {Δ} {σ} ⊢Δ [σ] =
        let ⊩σF = proj₁ ([F] ⊢Δ [σ])
            ⊩σΣFG = proj₁ ([ΣFG] ⊢Δ [σ])
            ⊩σt = proj₁ ([t] ⊢Δ [σ])
        in  fst″ ⊩σF ⊩σΣFG ⊩σt

  in  σfst ⊢Δ [σ] ,
      (λ {σ′} [σ′] [σ≡σ′] →
        let [σF] = proj₁ ([F] ⊢Δ [σ])
            [σΣFG] = proj₁ ([ΣFG] ⊢Δ [σ])
            [σt≡σ′t] = proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′]
        in  fst-cong″ [σF] [σΣFG] [σt≡σ′t])


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference.Solver(x : X) where
  import OutsideIn.Inference.Separator as S
  import OutsideIn.Expressions as E
  import OutsideIn.Constraints as C
  open import Data.Bool renaming (_∧_ to _and_)
  open E(x)
  open S(x)
  open X(x)
  open C(x)

  private module PlusN-m {n} = Monad (PlusN-is-monad {n})
          module QC-f = Functor (qconstraint-is-functor)
          module Ax-f = Functor (axiomscheme-is-functor)
          module Type-f = Functor (type-is-functor)
          module Type-m = Monad (type-is-monad)

  mutual
    data _,_solvI►_ {x : Set}⦃ eq : Eq x ⦄(Q : AxiomScheme x)(Qg : QConstraint x) : {s : Shape} → Implications x s → Set where
      I-ε : Q , Qg solvI► imp-ε
      I-∧ : ∀ {r₁ r₂}{a : Implications x r₁}{b : Implications x r₂}
          → Q , Qg solvI► a → Q , Qg solvI► b → Q , Qg solvI► (a imp-∧ b)
      I-i : ∀ {r}{n}{Qv}{C : SeparatedConstraint _ r}{n′}{θ}
          → ( let peq = (PlusN-eq {n} eq) in  Q , Qg ∧ Qv , n solv► C ↝ n′ , ε , θ)
          → Q , Qg solvI► imp (∃ n · Qv ⊃ C)

    data _,_,_solv►_↝_,_,_ {x : Set}⦃ eq : Eq x ⦄(Q : AxiomScheme x)(Qg : QConstraint x)(n : ℕ) : {s : Shape} →
                        (SeparatedConstraint (x ⨁ n) s) → (m : ℕ) → (Qr : QConstraint (x ⨁ m)) → (θ : x ⨁ n → Type (x ⨁ m)) → Set where
      SOLVE : ∀ {s}{simpl}{imps : Implications _ s}{m}{Qr}{θ}
            → simplifier eq n Q Qg simpl ≡ m , Qr , solved Qr θ
            → let peq = (PlusN-eq {m} eq) in (Ax-f.map (PlusN-m.unit {m}) Q) , (Qr ∧ QC-f.map (PlusN-m.unit {m}) Qg) solvI► substituteImp θ imps
            → Q , Qg , n solv► SC simpl imps ↝ m , Qr , θ

  solveImps : {x : Set}{s : Shape} → (eq : Eq x) → (Q : AxiomScheme x) → (Qg : QConstraint x) → (C : Implications x s)
            → Ⓢ (Q , Qg solvI► C)
  solver′ : {x : Set}{s : Shape} → (eq : Eq x)
          → (n : ℕ) → (Q : AxiomScheme x) → (Qg : QConstraint x) →  (C : SeparatedConstraint (x ⨁ n) s)
          → Ⓢ (∃ (λ m → ∃ (λ θ →  Q , Qg , n solv► C ↝ m , ε , θ)))
  solver′  eq n axioms given (SC simpl imps) with simplifier eq n axioms given simpl | inspect (simplifier eq n axioms given) simpl
  ... | m , ε? , solved .ε? θ | iC prf with is-ε ε?
  solver′  eq n axioms given (SC simpl imps)
      | m , .ε , solved .ε θ | iC prf | yes refl = solveImps (PlusN-eq {m} eq)
                                                             (Ax-f.map (PlusN-m.unit {m}) axioms)
                                                             ( ε ∧ QC-f.map (PlusN-m.unit {m}) given)
                                                             (substituteImp θ imps)
                                               >>= λ impP →  suc (m , θ , SOLVE prf impP)
       where open Monad(Ⓢ-is-monad)
  ...                        | no isntε = zero
  solveImps eq Q Qg imp-ε = suc I-ε
  solveImps eq Q Qg (a imp-∧ b) = solveImps eq Q Qg a
                       >>= λ a′ → solveImps eq Q Qg b
                       >>= λ b′ → suc (I-∧ a′ b′)
       where open Monad(Ⓢ-is-monad)
  solveImps eq Q Qg (imp (∃ n · Qv ⊃ C)) = solver′ eq n Q (Qg ∧ Qv) C >>= λ { (m , θ , prf) → suc (I-i prf) }
       where open Monad(Ⓢ-is-monad)

  solver : {x : Set}{s : Shape} → (eq : Eq x)
         → (n : ℕ) → (Q : AxiomScheme x) → (Qg : QConstraint x) →  (C : SeparatedConstraint (x ⨁ n) s)
         → Ⓢ (∃ (λ m → ∃ (λ Qr → ∃ (λ θ →  Q , Qg , n solv► C ↝ m , Qr , θ))))
  solver eq n Q Qg (SC simpl imps) with simplifier eq n Q Qg simpl | inspect (simplifier eq n Q Qg) simpl
  ... | m , Qr , solved .Qr θ | iC prf = solveImps (PlusN-eq {m} eq)
                                                   (Ax-f.map (PlusN-m.unit {m}) Q)
                                                   (Qr ∧ QC-f.map (PlusN-m.unit {m}) Qg)
                                                   (substituteImp θ imps)
                                     >>= λ prf′ → suc (m , Qr , θ , SOLVE prf prf′)
       where open Monad(Ⓢ-is-monad)


{-# OPTIONS --safe --no-qualified-instances #-}
module CF.Transform.Compile.Expressions where

open import Function using (_∘_)
open import Level
open import Data.Unit
open import Data.Bool
open import Data.Product as P
open import Data.List as L hiding (null; [_])
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Unary.All
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Unary hiding (_∈_)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad
open import Relation.Ternary.Construct.Bag.Properties

private
  module Src where
    open import CF.Syntax.DeBruijn public
    open import CF.Types public
    open import CF.Contexts.Lexical using (module DeBruijn) public; open DeBruijn public

  module Tgt where
    open import JVM.Types public
    open import JVM.Model StackTy public
    open import JVM.Syntax.Values public
    open import JVM.Syntax.Instructions public

open Src
open Tgt

open import JVM.Compiler
open import CF.Transform.Compile.ToJVM

-- Compilation of CF expressions
compileₑₛ : ∀ {as ψ Γ} → Exps as Γ → ε[ Compiler ⟦ Γ ⟧ ψ (⟦ as ⟧ ++ ψ) Emp ]

compileₑ  : ∀ {a ψ Γ}  → Exp a Γ   → ε[ Compiler ⟦ Γ ⟧ ψ (⟦ a ⟧ ∷ ψ) Emp ]

compileₑ (unit) = do
  code (push (bool true))

compileₑ (num x) = do
  code (push (num x))

compileₑ (bool b) = do
  code (push (bool b))

compileₑ (var' x) = do
  code (load ⟦ x ⟧)

compileₑ (bop f e₁ e₂) = do
  compileₑ e₁
  compileₑ e₂
  compile-bop f

  where

    -- a < b compiles to (assume a and b on stack):
    --
    --     if_icmplt l⁻
    --     iconst_1
    --     goto e⁻
    -- l⁺: iconst_0
    -- e⁺: nop
    --
    -- Other comparisons go similar
    compile-comp : ∀ {Γ as} → Comparator as → ε[ Compiler Γ (as ++ ψ) (boolean ∷ ψ) Emp ]
    compile-comp cmp = do
      ↓ lfalse⁻ ∙⟨ σ ⟩ lfalse⁺ ← ✴-swap ⟨$⟩ freshLabel
      lfalse⁺                  ← ✴-id⁻ˡ ⟨$⟩ (code (if cmp lfalse⁻) ⟨ Up _  # σ ⟩& lfalse⁺)
      lfalse⁺                  ← ✴-id⁻ˡ ⟨$⟩ (code (push (bool false)) ⟨ Up _  # ∙-idˡ ⟩& lfalse⁺)
      ↓ lend⁻ ∙⟨ σ ⟩ labels    ← (✴-rotateₗ ∘ ✴-assocᵣ) ⟨$⟩ (freshLabel ⟨ Up _  # ∙-idˡ ⟩& lfalse⁺)
      lfalse⁺ ∙⟨ σ ⟩ lend⁺     ← ✴-id⁻ˡ ⟨$⟩ (code (goto lend⁻) ⟨ _ ✴ _ # σ ⟩& labels)
      lend⁺                    ← ✴-id⁻ˡ ⟨$⟩ (attach lfalse⁺ ⟨ Up _ # σ ⟩& lend⁺)
      code (push (bool true))
      attach lend⁺

    -- Compile comparisons and other binary operations
    compile-bop : ∀ {Γ a b c} → BinOp a b c → ε[ Compiler Γ (⟦ b ⟧ ∷ ⟦ a ⟧ ∷ ψ) (⟦ c ⟧ ∷ ψ) Emp ]
    compile-bop add = code (bop add)
    compile-bop sub = code (bop sub)
    compile-bop mul = code (bop mul)
    compile-bop div = code (bop div)
    compile-bop xor = code (bop xor)
    compile-bop eq  = compile-comp icmpeq
    compile-bop ne  = compile-comp icmpne
    compile-bop lt  = compile-comp icmplt
    compile-bop ge  = compile-comp icmpge
    compile-bop gt  = compile-comp icmpgt
    compile-bop le  = compile-comp icmplt

compileₑ (ifthenelse c e₁ e₂) = do
  -- condition
  compileₑ c
  lthen+ ∙⟨ σ ⟩ ↓ lthen-  ← freshLabel
  lthen+                  ← ✴-id⁻ˡ ⟨$⟩ (code (if ne lthen-) ⟨ Up _  # ∙-comm σ     ⟩& lthen+)

  -- else
  compileₑ e₂
  ↓ lend- ∙⟨ σ ⟩ labels   ← (✴-rotateₗ ∘ ✴-assocᵣ) ⟨$⟩ (freshLabel ⟨ Up _  # ∙-idˡ        ⟩& lthen+)

  -- then
  lthen+ ∙⟨ σ ⟩ lend+     ← ✴-id⁻ˡ ⟨$⟩ (code (goto lend-) ⟨ _ ✴ _ # σ ⟩& labels)
  lend+                   ← ✴-id⁻ˡ ⟨$⟩ (attach lthen+ ⟨ Up _  # σ ⟩& lend+)
  compileₑ e₁

  -- label the end
  attach lend+

compileₑₛ [] = return refl
compileₑₛ (e ∷ es) = do
  compileₑₛ es
  compileₑ e