module Injections where

open import Data.Product
open import Relation.Nullary
open import Data.Empty
open import Data.Sum

open import Support.Equality
open ≡-Reasoning

open import Vars public
open import Injections.Type public

invert : ∀ {A : Set} {xs ys : List A} (i : Inj xs ys) → ∀ {t} (y : ys ∋ t) → Dec (∃ \ x → i $ x ≡ y)
invert []              y = no (λ { (() , _)})
invert ( z ∷ i [ pf ]) y with z ≅∋? y
invert (.y ∷ i [ pf ]) y | yes refl` = yes (zero , refl)
invert ( z ∷ i [ pf ]) y | no  z≢y   with invert i y
invert ( z ∷ i [ pf ]) y | no  z≢y   | yes (x , i$x≡y) = yes (suc x , i$x≡y)
invert ( z ∷ i [ pf ]) y | no  z≢y   | no  ¬[i⁻¹y]     = no  (neither z≢y ¬[i⁻¹y])
  where
    neither : ∀ {t} {y : _ ∋ t} → ¬ z ≅∋ y → ¬ (∃ \ x → i $ x ≡ y) → ¬ Σ (_ ∷ _ ∋ _) (λ x → (z ∷ i [ pf ]) $ x ≡ y)
    neither ¬1 ¬2 (zero  , p) = ¬1 (refl , ≡-to-≅ p)
    neither ¬1 ¬2 (suc x , p) = ¬2 (x , p)

abstract
  _∘i_ : ∀ {A : Set}{xs ys zs : List A} → Inj ys zs → Inj xs ys → Inj xs zs
  f ∘i g = quo (λ x x₁ → f $ (g $ x₁)) {λ x x₁ → injective g _ _ (injective f _ _ x₁)}

mutual
  id-i : ∀ {A : Set}{xs : List A} → Inj xs xs
  id-i = quo (\ _ x → x) {\ _ e → e}

  Inj-thin : ∀ {A : Set}{x : A}{xs ys} → (v : ys ∋ x) -> Inj xs (ys - v) → Inj xs ys
  Inj-thin v f = quo (λ x x₁ → thin v x (f $ x₁)) {λ x x₁ → injective f _ _ (thin-inj v x₁)}

abstract
  id-i$ : ∀ {A : Set}{xs : List A} -> ∀ {x}(v : xs ∋ x) -> id-i $ v ≡ v
  id-i$ v = iso2 _ _ v

  right-id : ∀ {A : Set}{xs ys : List A} → (i : Inj xs ys) → i ∘i id-i ≡ i
  right-id i = begin quo (λ x z → i $ (id-i $ z)) ≡⟨ quo-ext (λ x v → cong (_$_ i) (iso2 _ _ v)) ⟩
                     quo (λ x → _$_ i)            ≡⟨ iso1 i (λ x eq → injective i _ _ eq) ⟩
                     i                            ∎

  left-id : ∀ {A : Set}{xs ys : List A} → (i : Inj xs ys) → id-i ∘i i ≡ i
  left-id i = begin quo (λ x z → id-i $ (i $ z)) ≡⟨ quo-ext (λ x v → (iso2 _ _ (i $ v))) ⟩
                    quo (λ x → _$_ i)            ≡⟨ iso1 i (λ x eq → injective i _ _ eq) ⟩
                    i                            ∎

  apply-∘ : ∀ {A : Set}{xs ys zs : List A} → (j : Inj ys zs) → (i : Inj xs ys) → ∀ {x} {v : x ∈ xs} → (j ∘i i) $ v ≡ j $ (i $ v)
  apply-∘ j i {x}{v} = iso2 _ _ v

  assoc-∘i : ∀ {A : Set}{xs ys ws zs : List A} {f : Inj ws zs}{g : Inj _ ws}{h : Inj xs ys} → f ∘i (g ∘i h) ≡ (f ∘i g) ∘i h
  assoc-∘i {f = f}{g = g}{h = h} = quo-ext λ x v →
      begin f $ (quo (λ x₁ x₂ → g $ (h $ x₂)) $ v) ≡⟨ cong (_$_ f) (iso2 _ _ v) ⟩
            f $ (g $ (h $ v))                      ≡⟨ sym (iso2 _ _ (h $ v)) ⟩
            quo (λ x₁ x₂ → f $ (g $ x₂)) $ (h $ v) ∎

  cong-$ : ∀ {A : Set}{xs ys : List A} {f g : _} {inj1 inj2} → quo {_} {xs} {ys} f {inj1} ≡ quo g {inj2} → ∀ {s} (x : xs ∋ s) → f s x ≡ g s x
  cong-$ {A} {xs} {ys} {f} {g} eq x = begin f _ x     ≡⟨ sym (iso2 f _ x) ⟩
                                            quo f $ x ≡⟨ cong (λ f₁ → f₁ $ x) eq ⟩
                                            quo g $ x ≡⟨ iso2 g _ x ⟩
                                            g _ x     ∎

  ∘i-inj : ∀ {A : Set}{xs ys zs : List A} → (i : Inj ys zs) (j1 j2 : Inj xs ys) → (i ∘i j1) ≡ (i ∘i j2) → j1 ≡ j2
  ∘i-inj i j1 j2 eq = begin j1                 ≡⟨ sym (iso1 j1 (λ x x₁ → injective j1 _ _ x₁)) ⟩
                            quo (λ x → _$_ j1) ≡⟨ quo-ext (λ x v → injective i _ _ (cong-$ eq v)) ⟩
                            quo (λ x → _$_ j2) ≡⟨ iso1 j2 (λ x x₁ → injective j2 _ _ x₁) ⟩
                            j2                 ∎

  Inj-thin-$ : ∀ {A : Set}{x : A}{xs ys} → (v : ys ∋ x) -> (f : Inj xs (ys - v)) -> ∀ {y}(u : xs ∋ y) -> Inj-thin v f $ u ≡ thin v _ (f $ u)
  Inj-thin-$ v f u = iso2 _ _ u

  Inj-thin-inj : ∀ {A : Set}{x : A}{xs ys} → (v : ys ∋ x) -> (f g : Inj xs (ys - v)) -> Inj-thin v f ≡ Inj-thin v g -> f ≡ g
  Inj-thin-inj v f g eq = ext-$ f g (λ x v₁ → thin-inj v (cong-$ {inj1 = λ x₁ x₂ → injective f _ _ (thin-inj v x₂)} {inj2 = λ x₁ x₂ → injective g _ _ (thin-inj v x₂)} eq v₁)) -- XXX regression

  Inj-thin-∘i : ∀ {A : Set}{x : A}{zs xs ys} → (v : ys ∋ x) -> (f : Inj xs (ys - v)) (m : Inj zs xs) -> Inj-thin v f ∘i m ≡ Inj-thin v (f ∘i m)
  Inj-thin-∘i v f m = quo-ext (λ x v₁ → trans (iso2 _ _ (m $ v₁)) (cong (thin v x) (sym (iso2 _ _ v₁))))

  v∉Inj-thinv : ∀ {A : Set}{x : A}{xs ys} → (v : ys ∋ x) -> (f : Inj xs (ys - v)) -> v ∉ Inj-thin v f
  v∉Inj-thinv v f = ∉Im$-∉ (λ x x₁ → thin v _ (f $ x₁)) v (λ b → x∉thinx v (f $ b))

test : ∀ {A : Set} {xs ys} → (f : ∀ (x : A) → x ∈ xs → x ∈ ys){inj1 inj2 : ∀ x → {i j : x ∈ xs} → f x i ≡ f x j → i ≡ j} → quo f {inj1} ≡ quo f {inj2}
test f = refl

weak : ∀ {A : Set}{x : A}{xs ys} → Inj xs ys → Inj xs (x ∷ ys)
weak f = Inj-thin zero f

apply-weakid : ∀ {A : Set}{xs : List A}{x y}(i : xs ∋ x) -> weak {x = y} id-i $ i ≡ suc i
apply-weakid i = begin
   quo (λ x v → thin zero x (id-i $ v)) $ i ≡⟨ iso2 _ _ i ⟩
   suc (id-i $ i)                           ≡⟨ cong suc (id-i$ i) ⟩
   suc i                                    ∎

_∷[]_ : ∀ {A : Set}{x : A}{xs ys} → (v : ys ∋ x) -> Inj xs (ys - v) → Inj (x ∷ xs) ys
v ∷[] f = v ∷ Inj-thin v f [ v∉Inj-thinv v f ]

cons : ∀ {A : Set}{x : A}{xs ys} → Inj xs ys → Inj (x ∷ xs) (x ∷ ys)
cons z = zero ∷[] z

abstract

  cons-id : ∀ {A : Set}{x : A}{xs} -> cons id-i ≡ id-i {_} {x ∷ xs}
  cons-id = cong-∷[] refl (quo-ext (λ x v → cong suc (id-i$ v)))

  cons-∘i : ∀ {A : Set}{xs ys zs : List A}{x} → (j : Inj ys zs) → (i : Inj xs ys) → cons {A} {x} (j ∘i i) ≡ cons j ∘i cons i
  cons-∘i j i = cong-∷[] refl (begin
    quo (λ x z → suc (proj₁ (quo' (λ v v₁ → j $ (i $ v₁))) $ z))
      ≡⟨ quo-ext {injg = λ x x₁ → injective i _ _ (injective (weak j) _ _ x₁)} (λ x v →
          begin suc (proj₁ (quo' (λ v₁ v₂ → j $ (i $ v₂))) $ v) ≡⟨ cong suc (iso2 _ _ v) ⟩
                suc (j $ (i $ v))                               ≡⟨ sym (iso2 _ _ (i $ v)) ⟩
                quo (λ x₁ x₂ → suc (j $ x₂)) $ (i $ v)          ∎) ⟩
    quo (λ x v → cons j $ suc (i $ v))                       ≡⟨ sym (quo-ext (λ x₁ v → cong (_$_ (cons j)) (iso2 (λ _ x → suc (i $ x)) _ v))) ⟩
    quo (λ x v → cons j $ (quo (λ z x₁ → suc (i $ x₁)) $ v)) ∎)

∘-ext : ∀ {A : Set}{xs ys zs ws : List A} {f : Inj ys zs}{g : Inj xs ys}{f1 : Inj ws zs}{g1 : Inj xs ws} -> f ∘i g ≡ f1 ∘i g1
        -> (∀ x (v : xs ∋ x) -> f $ (g $ v) ≡ f1 $ (g1 $ v))
∘-ext eq = (\ x v -> trans (sym (apply-∘ _ _)) (trans (cong (\ f -> f $ v) eq) ((apply-∘ _ _))))

ext-∘ : ∀ {A : Set}{xs ys zs ws : List A} {f : Inj ys zs}{g : Inj xs ys}{f1 : Inj ws zs}{g1 : Inj xs ws} ->
  (∀ x (v : xs ∋ x) -> f $ (g $ v) ≡ f1 $ (g1 $ v)) -> f ∘i g ≡ f1 ∘i g1
ext-∘ eq = ext-$ _ _ (\ x v -> trans (apply-∘ _ _) (trans (eq x v) (sym (apply-∘ _ _))))

-- Transforming pointwise representations of universal morphisms into Inj ones.
Equ-universal-quote : ∀ {A : Set} {xs ys : List A} → (i j : Inj xs ys) → ∀ {E} → (e : Inj E xs) ->
               (∀ a (y : xs ∋ a) -> i $ y ≡ j $ y -> ∃ \ z -> y ≡ e $ z) ->
                {as : List A} (h : Inj as xs) → i ∘i h ≡ j ∘i h → Σ (Inj as E) (λ z → e ∘i z ≡ h )
Equ-universal-quote {A} {xs} {ys} i j {E} e c {as} h eq =
  quo u {λ x {v} {w} eq1 → injective h v w (begin h $ v     ≡⟨ proj₂ (f x v) ⟩
                                                  e $ u x v ≡⟨ cong (_$_ e) eq1 ⟩
                                                  e $ u x w ≡⟨ sym (proj₂ (f x w)) ⟩
                                                  h $ w     ∎)}
  , ext-$ (e ∘i quo u) h (λ x v → begin
          (e ∘i quo u) $ v ≡⟨ apply-∘ _ _ ⟩
          e $ (quo u $ v)  ≡⟨ cong (_$_ e) (iso2 _ _ v) ⟩
          e $ u x v        ≡⟨ sym (proj₂ (f x v)) ⟩
          h $ v            ∎)
  where
   f : ∀ a (y : as ∋ a) -> ∃ \ z -> h $ y ≡ e $ z
   f a y = c a (h $ y) (∘-ext eq a y)
   u = (λ x v → proj₁ (f x v))

Pull-universal-quote : ∀ {A : Set} {X Y Z : List A} → (i : Inj X Z)(j : Inj Y Z) -> ∀ {P} -> (p₁ : Inj P X) (p₂ : Inj P Y)
                 -> (∀ (a : A) (y : Y ∋ a)(x : X ∋ a) -> i $ x ≡ j $ y -> (∃ \ z -> p₁ $ z ≡ x × p₂ $ z ≡ y))
                 -> ∀ {Q} -> (q₁ : Inj Q X) (q₂ : Inj Q Y) -> i ∘i q₁ ≡ j ∘i q₂ -> ∃ \ u -> q₁ ≡ p₁ ∘i u × q₂ ≡ p₂ ∘i u
Pull-universal-quote i j p₁ p₂ uni {Q} q₁ q₂ commutes =
     quo u {λ x {v} {w} eq → injective q₁ v w (begin q₁ $ v      ≡⟨ sym (proj₁ (proj₂ (f x v))) ⟩
                                                     p₁ $ u x v  ≡⟨ cong (_$_ p₁) eq ⟩
                                                     p₁ $ u x w  ≡⟨ proj₁ (proj₂ (f x w)) ⟩
                                                     q₁ $ w      ∎)}
     , ext-$ q₁ (p₁ ∘i quo u) (λ x v → begin
             q₁ $ v            ≡⟨ sym (proj₁ (proj₂ (f x v))) ⟩
             p₁ $ u x v        ≡⟨ cong (_$_ p₁) (sym (iso2 _ _ v)) ⟩
             p₁ $ (quo u $ v)  ≡⟨ sym (apply-∘ _ _) ⟩
             (p₁ ∘i quo u) $ v ∎)
     , ext-$ q₂ (p₂ ∘i quo u) (λ x v → begin
             q₂ $ v            ≡⟨ sym (proj₂ (proj₂ (f x v))) ⟩
             p₂ $ u x v        ≡⟨ cong (_$_ p₂) (sym (iso2 _ _ v)) ⟩
             p₂ $ (quo u $ v)  ≡⟨ sym (apply-∘ _ _) ⟩
             (p₂ ∘i quo u) $ v ∎)
  where
    f : ∀ a (v : Q ∋ a) -> (∃ \ z -> p₁ $ z ≡ q₁ $ v × p₂ $ z ≡ q₂ $ v)
    f a v = uni a (q₂ $ v) (q₁ $ v) (∘-ext commutes a v)
    u : ∀ a (v : Q ∋ a) -> _
    u a v = proj₁ (f a v)


module Celeste where

open import Data.Nat using (ℕ; _⊔_; zero)
open import Data.String using (String)
open import Data.Vec using (Vec)
open import Data.Unsigned using (Unsigned)
open import Data.Signed using (Signed)
open import Data.Float using (Float)

private
  variable
    word-size : ℕ

mutual
  data Type : ℕ → Set where
    string : Type zero
    int8 : Type zero
    uint8 : Type zero
    int16 : Type zero
    uint16 : Type zero
    int32 : Type zero
    uint32 : Type zero
    int64 : Type zero
    uint64 : Type zero
    int128 : Type zero
    uint128 : Type zero
    int-word : Type zero
    uint-word : Type zero
    float32 : Type zero
    float64 : Type zero
    _×_ : {m n : ℕ} → Type m → Type n → Type (m ⊔ n)
    _⟶_ : {m n : ℕ} → Type m → Type n → Type (m ⊔ n)

  data Expr : {n : ℕ} → Type n → Set where
    str-lit : String → Expr string
    int8-lit : Signed 8 → Expr int8
    uint8-lit : Unsigned 8 → Expr uint8
    int16-lit : Signed 16 → Expr int16
    uint16-lit : Unsigned 16 → Expr uint16
    int32-lit : Signed 32 → Expr int32
    uint32-lit : Unsigned 32 → Expr uint32
    int64-lit : Signed 64 → Expr int64
    uint64-lit : Unsigned 64 → Expr uint64
    int128-lit : Signed 128 → Expr int128
    uint128-lit : Unsigned 128 → Expr uint128
    int-word-lit : Signed word-size → Expr int-word
    uint-word-lit : Unsigned word-size → Expr uint-word
    float32-lit : Float → Expr float32
    float64-lit : Float → Expr float64


{-# 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'


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

module Instance where

open import Level

it : ∀ {a} {A : Type a} → ⦃ _ : A ⦄ → A
it ⦃ x ⦄ = x


-- Andreas, 2015-07-13  Better parse errors for illegal type signatures

A | B : Set


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
-- This module proves the two "VotesOnce" proof obligations for our fake handler

open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS

import      LibraBFT.Concrete.Properties.VotesOnce as VO
open import LibraBFT.Impl.Base.Types

open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Consensus.RoundManager.Properties
open import LibraBFT.Impl.Handle
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Util.Util
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open        EpochConfig
open import LibraBFT.Yasm.Types
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})
open        WithSPS impl-sps-avp
open        Structural impl-sps-avp

-- In this module, we prove the two implementation obligations for the VotesOnce rule.  Note
-- that it is not yet 100% clear that the obligations are the best definitions to use.  See comments
-- in Concrete.VotesOnce.  We will want to prove these obligations for the fake/simple
-- implementation (or some variant on it) and streamline the proof before we proceed to tackle more
-- ambitious properties.

module LibraBFT.Impl.Properties.VotesOnce where

  -- This is the information we can establish about the state after the first time a signature is
  -- sent, and that we can carry forward to subsequent states, so we can use it to prove
  -- VO.ImplObligation₁.
  LvrProp : CarrierProp
  LvrProp v rm = (  v ^∙ vEpoch ≢ (₋rmEC rm) ^∙ rmEpoch
                 ⊎ (v ^∙ vEpoch ≡ (₋rmEC rm) ^∙ rmEpoch × v ^∙ vRound ≤ (₋rmEC rm) ^∙ rmLastVotedRound))

  LvrCarrier = PropCarrier LvrProp

  firstSendEstablishes : Vote → PK → (origSt : SystemState) → SystemStateRel Step
  firstSendEstablishes _ _ _ (step-peer (step-cheat _)) = Lift (ℓ+1 ℓ-RoundManager) ⊥
  firstSendEstablishes   v' pk origSt sysStep@(step-peer {pid'} {pre = pre} pstep@(step-honest _)) =
                         ( ReachableSystemState pre
                         × ¬ MsgWithSig∈ pk (signature v' unit) (msgPool pre)
                         × LvrCarrier pk (₋vSignature v') (StepPeer-post pstep)
                         )
  open PeerCanSignForPK

  isValidNewPart⇒fSE : ∀ {pk v'}{pre : SystemState} {post : SystemState} {theStep : Step pre post}
                     → Meta-Honest-PK pk
                     → (ivnp : IsValidNewPart (₋vSignature v') pk theStep)
                     → firstSendEstablishes v' pk pre theStep
  isValidNewPart⇒fSE {pre = pre} {theStep = step-peer {pid = β} {outs = outs} pstep} hpk (_ , ¬init , ¬sentb4 , mws , _)
     with Any-++⁻ (actionsToSentMessages β outs) (msg∈pool mws)
     -- TODO-1 : Much of this proof is not specific to the particular property being proved, and could be
     -- refactored into Yasm.Properties.  See proof of unwind and refactor to avoid redundancy?
  ...| inj₂ furtherBack = ⊥-elim (¬sentb4 (MsgWithSig∈-transp mws furtherBack))
  ...| inj₁ thisStep
     with pstep
  ...| step-cheat isCheat
     with thisStep
  ...| here refl
     with isCheat (msg⊆ mws) (msgSigned mws) (transp-¬∈GenInfo₁ ¬init mws)
  ...| inj₁ dis = ⊥-elim (hpk dis)
  ...| inj₂ sentb4 rewrite msgSameSig mws = ⊥-elim (¬sentb4 sentb4)

  isValidNewPart⇒fSE {pk}{v'}{pre}{theStep = step-peer {β} {postst} {outs} {.pre} pstep} hpk (r , ¬init , ¬sentb4 , mws , refl , zefl , vpk)
     | inj₁ thisStep
     | step-honest {.β} hstep
     with senderMsgPair∈⇒send∈ outs thisStep
  ...| nm∈outs , refl
     with hstep
  ...| step-msg {_ , P m} m∈pool ini
     with impl-sps-avp {m = msgWhole mws} r hpk hstep nm∈outs (msg⊆ mws) (msgSigned mws) (transp-¬∈GenInfo₁ ¬init mws )
  ...| inj₂ sentb4 rewrite msgSameSig mws = ⊥-elim (¬sentb4 sentb4)
  ...| inj₁ (vpk' , _)
     with noEpochIdChangeYet {ppre = peerStates pre β} r refl hstep ini
  ...| eids≡
     with newVoteSameEpochGreaterRound r hstep (¬subst ¬init (msgSameSig mws)) hpk (msg⊆ mws) nm∈outs (msgSigned mws)
                                               (¬subst ¬sentb4 (msgSameSig mws))
  ...| refl , refl , newlvr
     with StepPeer-post-lemma pstep
  ...| post≡ = r , ¬sentb4 , mkCarrier (step-s r (step-peer (step-honest hstep)))
                                       mws
                                       (override-target-≡ {a = β})
                                       vpk'
                                       (inj₂ ( trans eids≡ (auxEid post≡)
                                             , ≤-reflexive (trans newlvr (auxLvr post≡))))
                                       where auxEid = cong (_^∙ rmEpoch ∘ ₋rmEC)
                                             auxLvr = cong (_^∙ rmLastVotedRound ∘ ₋rmEC)

  ImplPreservesLvr : PeerStepPreserves LvrProp
  -- We don't have a real model for the initial peer state, so we can't prove this case yet.
  -- Eventually, we'll prove something like a peer doesn't initialize to an epoch for which
  -- it has already sent votes.
  ImplPreservesLvr r prop (step-init uni) = ⊥-elim (uninitd≢initd (trans (sym uni) (carrInitd prop)))
  ImplPreservesLvr {pre = pre} r prop (step-msg {m} m∈pool inited)
     with carrProp prop
  ...| preprop
     with noEpochIdChangeYet r refl (step-msg m∈pool inited) (carrInitd prop)
  ...| eids≡
     with preprop
  ...| inj₁ diffEpoch = inj₁ λ x → diffEpoch (trans x (sym eids≡))
  ...| inj₂ (sameEpoch , rnd≤ppre)
     with (msgPart (carrSent prop)) ^∙ vEpoch ≟ (₋rmEC (peerStates pre (msgSender (carrSent prop)))) ^∙ rmEpoch
  ...| no neq = ⊥-elim (neq sameEpoch)
  ...| yes refl
     with lastVoteRound-mono r refl (step-msg m∈pool inited) (carrInitd prop)
  ...| es≡⇒lvr≤
     = inj₂ (eids≡ , ≤-trans rnd≤ppre (es≡⇒lvr≤ eids≡))

  LvrCarrier-transp* : ∀ {pk sig} {start : SystemState}{final : SystemState}
                     → LvrCarrier pk sig start
                     → (step* : Step* start final)
                     → LvrCarrier pk sig final
  LvrCarrier-transp* lvrc step-0 = lvrc
  LvrCarrier-transp* lvrc (step-s s* s) = Carrier-transp LvrProp ImplPreservesLvr s (LvrCarrier-transp* lvrc s*)

  fSE⇒rnd≤lvr : ∀ {v' pk}
              → {final : SystemState}
              → Meta-Honest-PK pk
              → ∀ {pre : SystemState}{post : SystemState}{theStep : Step pre post}
              → firstSendEstablishes v' pk post theStep
              → Step* post final
              → LvrCarrier pk (signature v' unit) final
  fSE⇒rnd≤lvr hpk {theStep = step-peer (step-honest _)} (_ , _ , lvrc) step* = LvrCarrier-transp* lvrc step*

  vo₁ : VO.ImplObligation₁
  -- Initialization doesn't send any messages at all so far; Agda figures that out so no proof
  -- required here.  In future it may send messages, but any verifiable Signatures for honest PKs
  -- they contain will be from GenesisInfo.
  vo₁ {pid} {pk = pk} {pre = pre} r sm@(step-msg {(_ , nm)} m∈pool pidini)
      {m = m} {v'} hpk v⊂m m∈outs sig ¬init ¬sentb4 vpb v'⊂m' m'∈pool sig' ¬init' refl rnds≡
     with msgsToSendWereSent {pid} {nm} m∈outs
  ...| _ , vm , _ , refl , _
     with newVoteSameEpochGreaterRound r (step-msg m∈pool pidini) ¬init hpk v⊂m m∈outs sig ¬sentb4
  ...| eIds≡' , suclvr≡v'rnd , _
     -- Use unwind to find the step that first sent the signature for v', then Any-Step-elim to
     -- prove that going from the poststate of that step to pre results in a state in which the
     -- round of v' is at most the last voted round recorded in the peerState of the peer that
     -- sent v'
     with Any-Step-elim {Q = LvrCarrier pk (₋vSignature v') pre}
                        (fSE⇒rnd≤lvr {v'} hpk)
                        (Any-Step-map (λ _ ivnp → isValidNewPart⇒fSE {v' = v'} hpk ivnp)
                                      (unwind r hpk v'⊂m' m'∈pool sig' ¬init'))
  ...| mkCarrier r' mws ini vpf' preprop
     -- The fake/trivial handler always sends a vote for its current epoch, but for a
     -- round greater than its last voted round
     with sameSig⇒sameVoteData (msgSigned mws) sig' (msgSameSig mws)
  ...| inj₁ hb = ⊥-elim (PerState.meta-sha256-cr pre r hb)
  ...| inj₂ refl
     with msgSender mws ≟NodeId pid
  ...| no neq =
     -- We know that *after* the step, pid can sign v (vpb is about the post-state).  For v', we
     -- know it about state "pre"; we transport this to the post-state using
     -- PeerCanSignForPK-Stable.  Because EpochConfigs known in a system state are consistent with
     -- each other (i.e., trivially, for now because only the initial EpochConfig is known), we can
     -- use PK-inj to contradict the assumption that v and v' were sent by different peers (neq).
     let theStep = step-peer (step-honest sm)
         vpf''   = PeerCanSignForPK-stable r theStep vpf'
         𝓔s≡     = availEpochsConsistent {pid} {msgSender mws} (step-s r theStep) vpb vpf''
     in  ⊥-elim (neq (trans (trans (sym (nid≡ vpf''))
                                   (PK-inj-same-ECs (sym 𝓔s≡)
                                                    (trans (pk≡ vpf'') (sym (pk≡ vpb)))))
                            (nid≡ vpb)))

  vo₁ {pid} {pk = pk} {pre = pre} r sm@(step-msg m∈pool ps≡)
      {v' = v'} hpk v⊂m m∈outs sig ¬init ¬sentb4 vpb v'⊂m' m'∈pool sig' _ refl rnds≡
     | _ , vm , _ , refl , _
     | eIds≡' , suclvr≡v'rnd , _
     | mkCarrier r' mws ini vpf' preprop
     | inj₂ refl
     | yes refl
     with preprop
  ...| inj₁ diffEpoch = ⊥-elim (diffEpoch eIds≡')
  ...| inj₂ (sameEpoch , v'rnd≤lvr)
                    -- So we have proved both that the round of v' is ≤ the lastVotedRound of
                    -- the peer's state and that the round of v' is one greater than that value,
                    -- which leads to a contradiction
                    = ⊥-elim (1+n≰n (≤-trans (≤-reflexive suclvr≡v'rnd)
                                             (≤-trans (≤-reflexive rnds≡) v'rnd≤lvr)))

  -- TODO-1: This proof should be refactored to reduce redundant reasoning about the two votes.  The
  -- newVoteSameEpochGreaterRound property uses similar reasoning.

  vo₂ : VO.ImplObligation₂
  vo₂ {pid = pid} {pk = pk} {pre = pre} r (step-msg {_ , nm} m∈pool pinit) {v = v} {m}
      hpk v⊂m m∈outs sig ¬init vnew vpk v'⊂m' m'∈outs sig' ¬init' v'new vpk' es≡ rnds≡
     with msgsToSendWereSent {pid} {nm} m∈outs
  ...| _ , vm , pm , refl , refl
    with proposalHandlerSentVote {pid} {0} {pm} {vm} {peerStates pre pid} m∈outs
  ...| _ , v∈outs
    with v⊂m
       -- Rebuilding keeps the same signature, and the SyncInfo included with the
       -- VoteMsg sent comprises QCs from the peer's state.  Votes represented in
       -- those QCS have signatures that have been sent before, contradicting the
       -- assumption that v's signature has not been sent before.
  ...| vote∈qc {vs = vs} {qc} vs∈qc v≈rbld (inV qc∈m)
                  rewrite cong ₋vSignature v≈rbld
                        | procPMCerts≡ {0} {pm} {peerStates pre pid} {vm} v∈outs
                        | SendVote-inj-v (Any-singleton⁻ v∈outs)
     with qcVotesSentB4 r pinit
                        (VoteMsgQCsFromRoundManager r (step-msg m∈pool pinit) hpk v⊂m m∈outs qc∈m) vs∈qc ¬init
  ...| mws = ⊥-elim (vnew mws)

  vo₂ {pid = pid} {pk = pk} {pre = pre} r (step-msg {_ , nm} m∈pool pinit) {v = v} {m} {v'} {m'}
      hpk v⊂m m∈outs sig ¬init vnew vpk v'⊂m' m'∈outs sig' ¬init' v'new vpk' es≡ rnds≡
     | _ , vm , pm , refl , refl
     | _ , v∈outs
     | vote∈vm
     with msgsToSendWereSent {pid} {nm} {m'} {st = peerStates pre pid} m'∈outs
  ...| _ , vm' , pm , refl , refl
    with proposalHandlerSentVote {pid} {0} {pm} {vm'} {peerStates pre pid} m'∈outs
  ...| _ , v'∈outs
       rewrite cong ₋vmVote (SendVote-inj-v (trans (Any-singleton⁻ v∈outs) (sym (Any-singleton⁻ v'∈outs))))
    with v'⊂m'
  ...| vote∈vm = refl
  ...| vote∈qc {vs = vs} {qc} vs∈qc v≈rbld (inV qc∈m)
                  rewrite cong ₋vSignature v≈rbld
                        | procPMCerts≡ {0} {pm} {peerStates pre pid} {vm} v∈outs
                        | SendVote-inj-v (Any-singleton⁻ v∈outs)
                        | cong ₋vmVote (SendVote-inj-v (trans (Any-singleton⁻ v∈outs) (sym (Any-singleton⁻ v'∈outs))))
    with qcVotesSentB4 r pinit
                       (VoteMsgQCsFromRoundManager r (step-msg m∈pool pinit) hpk v'⊂m' m'∈outs qc∈m) vs∈qc ¬init'
  ...| mws = ⊥-elim (v'new mws)


-- This bug was reported by Christian Sattler. (I modified his example
-- slightly.)

-- {-# OPTIONS -v tc.meta.assign:49 #-}

module Issue903 where

record T : Set where
  constructor tt

postulate
  Id : (A : Set) → A → Set
  e  : (B : Set) (f : T → B) → Id B (f tt) → Id (T → B) f
  k  : (P : Set → Set) (u : P T) → Id (P T) u → T
  h  : Id T tt

q : T
q = k {!!} {!!} (e {!!} _ {!h!})

-- WAS: If one tries to give h:
--
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/MetaVars.hs:654


module Issue4260.M where

postulate
  F : Set → Set

syntax F X = G X


module UnSized.Parrot where

open import Data.Product
open import Data.String.Base

open import UnSizedIO.IOObject

open import UnSizedIO.Base hiding (main)
open import UnSizedIO.Console hiding (main)

open import NativeIO

open import UnSized.SimpleCell hiding (program; main)

--ParrotC : Set
--ParrotC = ConsoleObject (cellI String)

-- but reusing cellC from SimpleCell, as interface is ident!

-- class Parrot implements Cell {
--   Cell cell;
--   Parrot (Cell c) { cell = c; }
--   public String get() {
--     return "(" + cell.get() + ") is what parrot got";
--   }
--   public void put (String s) {
--     cell.put("parrot puts (" + s + ")");
--   }
-- }

-- parrotP is constructor for the consoleObject for interface (cellI String)
{-# NON_TERMINATING #-}
parrotP : (c : CellC) → CellC
(method (parrotP c) get) =
  exec1 (putStrLn "printing works")  >>
  method c get >>= λ { (s , c') →
  return ("(" ++ s ++ ") is what parrot got" , parrotP c')  }
(method (parrotP c) (put s)) =
  method c (put ("parrot puts (" ++ s ++ ")"))

--   public static void main (String[] args) {
--     Parrot c = new Parrot(new SimpleCell("Start"));
--     System.out.println(c.get());
--     c.put(args[1]);
--     System.out.println(c.get());
--   }
-- }

program : String → IOConsole Unit
program arg =
  let c₀ = parrotP (cellP "Start") in
  method c₀ get       >>= λ{ (s , c₁) →
  exec1 (putStrLn s)         >>
  method c₁ (put arg) >>= λ{ (_ , c₂) →
  method c₂ get       >>= λ{ (s' , c₃) →
  exec1 (putStrLn s')        }}}

main : NativeIO Unit
main = translateIOConsole (program "hello")


------------------------------------------------------------------------
-- 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₁ ρ


{-# OPTIONS --postfix-projections #-}

module StateSized.cellStateDependent where

open import Data.Product
open import Data.String.Base

{-
open import SizedIO.Object
open import SizedIO.ConsoleObject
-}

open import SizedIO.Console hiding (main)

open import SizedIO.Base

open import NativeIO

open import StateSizedIO.Object
open import StateSizedIO.IOObject

open import Size
open import StateSizedIO.cellStateDependent

{- I moved most into src/StateSizedIO/cellStateDependent.agda

now the code doesn't work
-}

-- Program is another program
program : IOConsole ∞ Unit
program =
  let c₀ = cellPempty ∞  in
  exec getLine            λ str →
  method c₀ (put str)    >>= λ{ (_ , c₁) →        -- empty
  method c₁ get          >>= λ{ (str₁ , c₂) →     -- full
  exec (putStrLn ("we got " ++ str₁))    λ _ →
  exec (putStrLn ("Second Round"))    λ _ →
  exec getLine            λ str₂ →
  method c₂ (put str₂)    >>= λ{ (_ , c₃) →
  method c₃ get          >>= λ{ (str₃ , c₄) →
  exec (putStrLn ("we got " ++ str₃)  ) λ _ →
  return unit
  }}}}

main : NativeIO Unit
main = translateIOConsole program

-- cellP is constructor for the consoleObject for interface (cellI String)
{-
cellPˢ : ∀{i} → CellCˢ i
force (method cellPˢ (put x)) = {!!}
-}

{-
cellP : ∀{i} (s : String) → CellC i
force (method (cellP s) get) =
  exec' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  return (s , cellP s)
force (method (cellP s) (put x)) =
  exec' (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  return (_ , (cellP x))
-}

{-
-- cellI is the interface of the object of a simple cell
cellI : (A : Set) → Interfaceˢ
Method  (cellI A)    =  CellMethodˢ A
Result  (cellI A) m  =  CellResultˢ m

-- cellC is the type of consoleObjects with interface (cellI String)
CellC : (i : Size) → Set
CellC i = ConsoleObject i (cellI String)
-}
{-
-- cellO is a program for a simple cell which
-- when get is called writes "getting s" for the string s of the object
-- and when putting s writes "putting s" for the string

-- cellP is constructor for the consoleObject for interface (cellI String)
cellP : ∀{i} (s : String) → CellC i
force (method (cellP s) get) =
  exec' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  return (s , cellP s)
force (method (cellP s) (put x)) =
  exec' (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  return (_ , (cellP x))

-- Program is another program
program : String → IOConsole ∞ Unit
program arg =
  let c₀ = cellP "Start" in
  method c₀ get       >>= λ{ (s , c₁) →
  exec1 (putStrLn s)         >>
  method c₁ (put arg) >>= λ{ (_ , c₂) →
  method c₂ get       >>= λ{ (s' , c₃) →
  exec1 (putStrLn s')        }}}

main : NativeIO Unit
main = translateIOConsole (program "hello")
-}


-- 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


-- Check that FOREIGN code can have nested pragmas.
module _ where

open import Common.Prelude

{-# FOREIGN GHC

{-# NOINLINE plusOne #-}
plusOne :: Integer -> Integer
plusOne n = n + 1

{-# INLINE plusTwo #-}
plusTwo :: Integer -> Integer
plusTwo = plusOne . plusOne

#-}

postulate
  plusOne : Nat → Nat

{-# COMPILE GHC plusOne = plusOne #-}


------------------------------------------------------------------------
-- 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


----------------------------------------------------------------------------------
-- Types for parse trees
----------------------------------------------------------------------------------

module cedille-types where

open import lib
-- open import parse-tree
open import general-util

{-# FOREIGN GHC import qualified CedilleTypes #-}

mutual
  posinfo = string
  var = string
  num = string
  erased? = 𝔹
  minus? = 𝔹
  imports = 𝕃 imprt
  ex-imports = 𝕃 ex-imprt
  params = 𝕃 param
  ex-params = 𝕃 ex-param
  ex-cmds = 𝕃 ex-cmd
  ex-ctrs = 𝕃 ex-ctr
  ctrs = 𝕃 ctr
  args = 𝕃 arg
  ex-args = 𝕃 ex-arg
  opacity = 𝔹
  cases = 𝕃 case
  ex-cases = 𝕃 ex-case
  left-right = maybe 𝔹
  rho-hnf = 𝔹
  opt-public = 𝔹
  is-mu = maybe term ⊎ var
  iota-num = 𝔹
  case-args = 𝕃 case-arg
  tmtp = term ⊎ type
  tpkd = type ⊎ kind
  arg = term ⊎ tmtp

  pattern Tkt T = inj₁ T
  pattern Tkk k = inj₂ k
  pattern Ttm t = inj₁ t
  pattern Ttp T = inj₂ T
  pattern Arg t = inj₁ t
  pattern ArgE tT = inj₂ tT
  pattern ArgTp T = ArgE (Ttp T)
  pattern ArgEr t = ArgE (Ttm t)
  pattern ι1 = ff
  pattern ι2 = tt
  pattern NotErased = ff
  pattern Erased = tt
  pattern opacity-open = tt
  pattern opacity-closed = ff
  pattern EpsHanf = tt
  pattern EpsHnf = ff
  pattern EpsLeft = just ff
  pattern EpsRight = just tt
  pattern EpsBoth = nothing
  pattern Public = tt
  pattern Private = ff

  ctr = var × type
  pattern Ctr x T = x , T

  data param : Set where
    Param : erased? → var → tpkd → param
  pattern ParamTp x k = Param _  x (Tkk k)
  pattern ParamTm x T = Param ff x (Tkt T)
  pattern ParamEr x T = Param tt x (Tkt T)

  data term : Set where
    App : term → term → term
    AppE : term → tmtp → term
    Beta : term → term → term
    Delta : (do-bohm? : maybe (term × term)) → (Tᵣ : type) → (contra : term) → term
    Hole : posinfo → term
    IotaPair : term → term → var → type → term
    IotaProj : term → iota-num → term
    Lam : erased? → var → maybe tpkd → term → term
    LetTm : erased? → var → maybe type → term → term → term
    LetTp : var → kind → type → term → term
    Phi : term → term → term → term
    Rho : term → var → type → term → term
    Sigma : term → term
    Mu : is-mu → term → maybe type → datatype-info → cases → term
    Var : var → term
  pattern AppTp t T = AppE t (Ttp T)
  pattern AppEr t t' = AppE t (Ttm t')

  data case : Set where
    Case : var → case-args → term → 𝕃 tmtp → case

  data type : Set where
    TpAbs : erased? → var → tpkd → type → type
    TpIota : var → type → type → type
    TpApp : type → tmtp → type
    TpEq : term → term → type
    TpHole : posinfo → type
    TpLam : var → tpkd → type → type
    TpVar : var → type
  pattern TpAppTp T T' = TpApp T (Ttp T')
  pattern TpAppTm T t = TpApp T (Ttm t)

  data kind : Set where
    KdStar : kind
    KdHole : posinfo → kind
    KdAbs : var → tpkd → kind → kind

  data case-arg : Set where
    CaseArg : erased? → var → maybe tpkd → case-arg

  data ex-file : Set where
    ExModule : ex-imports → posinfo → posinfo → var → ex-params → ex-cmds → posinfo → ex-file

  cmds = 𝕃 cmd

  data file : Set where
    Module : var → params → cmds → file

  indx : Set
  indx = var × tpkd
  pattern Index x tk = x , tk
  indices = 𝕃 indx

  record encoding-defs : Set where
    constructor mk-enc-defs
    inductive
    field
      ecs : cmds -- encoding
      gcs : cmds -- generated
      Cast : type
      cast-in : term
      cast-out : term
      cast-is : term
      Functor : type
      functor-in : term
      functor-out : term
      Fix : type
      fix-in : term
      fix-out : term
      lambek1 : term
      lambek2 : term
      fix-ind : term

  record encoded-defs : Set where
    constructor mk-encd-defs
    field
      Is/D : var
      is/D : var
      to/D : var
      TypeF/D : var
      IndF/D : var
      fmap/D :  var

  record datatype-info : Set where
    constructor mk-data-info
    inductive
    field
      name : var
      original : var
      asₚ : args
      asᵢ : 𝕃 tmtp
      ps : params
      kᵢ : kind
      k : kind
      cs : ctrs
      csₚₛ : ctrs
      eds : encoding-defs
      gds : encoded-defs

  data cmd : Set where
    CmdDefTerm : var → term → cmd
    CmdDefType : var → kind → type → cmd
    CmdDefKind : var → params → kind → cmd
    CmdDefData : encoding-defs → var → params → kind → ctrs → cmd
    CmdImport : imprt → cmd

  data imprt : Set where
    Import : opt-public → filepath → var → maybe var → args → imprt

  data ex-cmd : Set where
    ExCmdKind : posinfo → var → ex-params → ex-kd → posinfo → ex-cmd
    ExCmdDef : opacity → ex-def → posinfo → ex-cmd
    ExCmdData : def-datatype → posinfo → ex-cmd
    ExCmdImport : ex-imprt → ex-cmd

  data def-datatype : Set where
    DefDatatype : posinfo → posinfo → var → ex-params → ex-kd → ex-ctrs → def-datatype

  data import-as : Set where
    ImportAs : posinfo → var → import-as

  data ex-imprt : Set where
    ExImport : posinfo → opt-public → posinfo → filepath → maybe import-as → ex-args → posinfo → ex-imprt

  data ex-param : Set where
    ExParam : posinfo → erased? → posinfo → var → ex-tk → posinfo → ex-param

  data ex-ctr : Set where
    ExCtr : posinfo → var → ex-tp → ex-ctr

  data ex-arg : Set where
    ExTmArg : erased? → ex-tm → ex-arg
    ExTpArg : ex-tp → ex-arg

  data lterm : Set where
    Lterm : erased? → ex-tm → lterm

  data theta : Set where
    Abstract : theta
    AbstractEq : theta
    AbstractVars : 𝕃 var → theta

  data ex-def : Set where
    ExDefTerm : posinfo → var → maybe ex-tp → ex-tm → ex-def
    ExDefType : posinfo → var → ex-kd → ex-tp → ex-def

  data ex-guide : Set where
    ExGuide : posinfo → var → ex-tp → ex-guide

  data ex-case : Set where
    ExCase : posinfo → var → ex-case-args → ex-tm → ex-case

  ex-case-args = 𝕃 ex-case-arg

  data ex-case-arg-sym : Set where
    ExCaseArgTm : ex-case-arg-sym
    ExCaseArgEr : ex-case-arg-sym
    ExCaseArgTp : ex-case-arg-sym

  data ex-case-arg : Set where
    ExCaseArg : ex-case-arg-sym → posinfo → var → ex-case-arg

  data ex-tk : Set where
    ExTkt : ex-tp → ex-tk
    ExTkk : ex-kd → ex-tk

  data ex-tp : Set where
    ExTpAbs : posinfo → erased? → posinfo → var → ex-tk → ex-tp → ex-tp
    ExTpIota : posinfo → posinfo → var → ex-tp → ex-tp → ex-tp
    ExTpNoSpans : ex-tp → posinfo → ex-tp
    ExTpLet : posinfo → ex-def → ex-tp → ex-tp
    ExTpApp : ex-tp → ex-tp → ex-tp
    ExTpAppt : ex-tp → ex-tm → ex-tp
    ExTpArrow : ex-tp → erased? → ex-tp → ex-tp
    ExTpEq : posinfo → ex-tm → ex-tm → posinfo → ex-tp
    ExTpHole : posinfo → ex-tp
    ExTpLam : posinfo → posinfo → var → ex-tk → ex-tp → ex-tp
    ExTpParens : posinfo → ex-tp → posinfo → ex-tp
    ExTpVar : posinfo → var → ex-tp

  data pos-tm : Set where
    PosTm : ex-tm → posinfo → pos-tm

  data ex-is-mu : Set where
    ExIsMu : posinfo → var → ex-is-mu
    ExIsMu' : maybe ex-tm → ex-is-mu

  data ex-tm : Set where
    ExApp : ex-tm → erased? → ex-tm → ex-tm
    ExAppTp : ex-tm → ex-tp → ex-tm
    ExBeta : posinfo → maybe pos-tm → maybe pos-tm → ex-tm
    ExChi : posinfo → maybe ex-tp → ex-tm → ex-tm
    ExDelta : posinfo → maybe ex-tp → ex-tm → ex-tm
    ExEpsilon : posinfo → left-right → minus? → ex-tm → ex-tm
    ExHole : posinfo → ex-tm
    ExIotaPair : posinfo → ex-tm → ex-tm → maybe ex-guide → posinfo → ex-tm
    ExIotaProj : ex-tm → num → posinfo → ex-tm
    ExLam : posinfo → erased? → posinfo → var → maybe ex-tk → ex-tm → ex-tm
    ExLet : posinfo → erased? → ex-def → ex-tm → ex-tm
    ExOpen : posinfo → opacity → posinfo → var → ex-tm → ex-tm
    ExParens : posinfo → ex-tm → posinfo → ex-tm
    ExPhi : posinfo → ex-tm → ex-tm → ex-tm → posinfo → ex-tm
    ExRho : posinfo → rho-hnf → maybe (𝕃 num) → ex-tm → maybe ex-guide → ex-tm → ex-tm
    ExSigma : posinfo → ex-tm → ex-tm
    ExTheta : posinfo → theta → ex-tm → 𝕃 lterm → ex-tm
    ExMu : posinfo → ex-is-mu → ex-tm → maybe ex-tp → posinfo → ex-cases → posinfo → ex-tm
    ExVar : posinfo → var → ex-tm

  data ex-kd : Set where
    ExKdAbs : posinfo → posinfo → var → ex-tk → ex-kd → ex-kd
    ExKdArrow : ex-tk → ex-kd → ex-kd
    ExKdHole : posinfo → ex-kd
    ExKdParens : posinfo → ex-kd → posinfo → ex-kd
    ExKdStar : posinfo → ex-kd
    ExKdVar : posinfo → var → ex-args → ex-kd

{-# COMPILE GHC ex-param = data CedilleTypes.Param (CedilleTypes.Param) #-}
{-# COMPILE GHC ex-file = data CedilleTypes.File (CedilleTypes.Module) #-}
{-# COMPILE GHC ex-cmd = data CedilleTypes.Cmd (CedilleTypes.CmdKind | CedilleTypes.CmdDef | CedilleTypes.CmdData | CedilleTypes.CmdImport) #-}
{-# COMPILE GHC ex-ctr = data CedilleTypes.Ctr (CedilleTypes.Ctr) #-}
{-# COMPILE GHC ex-arg = data CedilleTypes.Arg (CedilleTypes.TermArg | CedilleTypes.TypeArg) #-}
{-# COMPILE GHC def-datatype = data CedilleTypes.DefDatatype (CedilleTypes.DefDatatype) #-}
{-# COMPILE GHC import-as = data CedilleTypes.ImportAs (CedilleTypes.ImportAs) #-}
{-# COMPILE GHC ex-imprt = data CedilleTypes.Imprt (CedilleTypes.Import) #-}
{-# COMPILE GHC ex-case-arg-sym = data CedilleTypes.CaseArgSym (CedilleTypes.CaseArgTm | CedilleTypes.CaseArgEr | CedilleTypes.CaseArgTp) #-}
--{-# COMPILE GHC case-arg = data CedilleTypes.CaseArg (CedilleTypes.CaseArg) #-}
{-# COMPILE GHC lterm = data CedilleTypes.Lterm (CedilleTypes.Lterm) #-}
{-# COMPILE GHC theta = data CedilleTypes.Theta (CedilleTypes.Abstract | CedilleTypes.AbstractEq | CedilleTypes.AbstractVars) #-}
{-# COMPILE GHC ex-def = data CedilleTypes.Def (CedilleTypes.DefTerm | CedilleTypes.DefType) #-}
{-# COMPILE GHC ex-guide = data CedilleTypes.Guide (CedilleTypes.Guide) #-}
{-# COMPILE GHC ex-case = data CedilleTypes.Case (CedilleTypes.Case) #-}
{-# COMPILE GHC ex-case-arg = data CedilleTypes.CaseArg (CedilleTypes.CaseArg) #-}
{-# COMPILE GHC ex-tk = data CedilleTypes.TpKd (CedilleTypes.Tkt | CedilleTypes.Tkk) #-}
{-# COMPILE GHC ex-tp = data CedilleTypes.Type (CedilleTypes.TpAbs | CedilleTypes.TpIota | CedilleTypes.TpNoSpans | CedilleTypes.TpLet | CedilleTypes.TpApp | CedilleTypes.TpAppt | CedilleTypes.TpArrow | CedilleTypes.TpEq | CedilleTypes.TpHole | CedilleTypes.TpLam | CedilleTypes.TpParens | CedilleTypes.TpVar) #-}
{-# COMPILE GHC pos-tm = data CedilleTypes.PosTerm (CedilleTypes.PosTerm) #-}
{-# COMPILE GHC ex-is-mu = data CedilleTypes.IsMu (CedilleTypes.IsMu | CedilleTypes.IsMu') #-}
{-# COMPILE GHC ex-tm = data CedilleTypes.Term (CedilleTypes.App | CedilleTypes.AppTp | CedilleTypes.Beta | CedilleTypes.Chi | CedilleTypes.Delta | CedilleTypes.Epsilon | CedilleTypes.Hole | CedilleTypes.IotaPair | CedilleTypes.IotaProj | CedilleTypes.Lam | CedilleTypes.Let | CedilleTypes.Open | CedilleTypes.Parens | CedilleTypes.Phi | CedilleTypes.Rho | CedilleTypes.Sigma | CedilleTypes.Theta | CedilleTypes.Mu | CedilleTypes.Var) #-}
{-# COMPILE GHC ex-kd = data CedilleTypes.Kind (CedilleTypes.KdAbs | CedilleTypes.KdArrow | CedilleTypes.KdHole | CedilleTypes.KdParens | CedilleTypes.KdStar | CedilleTypes.KdVar) #-}


------------------------------------------------------------------------
-- 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₂)) ρ


{-#  OPTIONS --type-in-type #-}
module TooFewArgs where

open import AgdaPrelude

myFun : (a : Set) -> a -> a -> a
myFun a x y = x

myApp : Nat
myApp = myFun _ Zero