open import Nat
open import Prelude
open import List

open import contexts
open import core

open import lemmas-env
open import lemmas-progress
open import decidability
open import results-checks

-- TODO we're forced to prove this weaker version, since the strong version is
--      unprovable. That said, this weak version is still disappointing, so we
--      should come up with some more thoerems to shore up its deficiencies -
--      in particular, we should do something to mitigate the fact that an e
--      may succeed for every even n and fail for every odd n
--      - also, that evaluation may return different results for different n
-- TODO complete, then delete
--      e => r → ∀{n} e [n]=> r
--        something similar for =>∅ ?
--      (Σ[r] (e => r) ∧ e => ∅) → ⊥
--      ∀{k} → Σ[r] (e [k]=> r) ∨ e [k]=> ∅
module progress where
  progress : ∀{Δ Σ' Γ E e τ n} →
               Δ , Σ' , Γ ⊢ E →
               Δ , Σ' , Γ ⊢ e :: τ →
               -- Either there's some properly-typed result that e will eval to ...
               Σ[ r ∈ result ] Σ[ k ∈ constraints ] (
                  (E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒ r ⊣ k) ∧
                  Δ , Σ' ⊢ r ·: τ)
               -- ... or evaluation will have a constraint failure
               ∨ E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒∅

  xc-progress : ∀{Δ Σ' r1 r2 τ n} →
                  Δ , Σ' ⊢ r1 ·: τ →
                  Δ , Σ' ⊢ r2 ·: τ →
                  Σ[ k ∈ constraints ] Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:= k
                  ∨ Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:=∅

  xb-progress : ∀{Δ Σ' r ex τ n} →
                  Δ , Σ' ⊢ r ·: τ →
                  Δ , Σ' ⊢ ex :· τ →
                  Σ[ k ∈ constraints ] (r ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:= k)
                  ∨ r ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:=∅

  rule-fails : {n↓ : Nat} {E : env} {r : result} {ex : ex} → Set
  rule-fails {n↓} {E} {r} {ex} =
              Σ[ c-j ∈ Nat ] Σ[ x-j ∈ Nat ] Σ[ e-j ∈ exp ] (
                 r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:=∅
                 ∨ Σ[ k1 ∈ constraints ] (
                      r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒∅)
                 ∨ Σ[ k1 ∈ constraints ] Σ[ k2 ∈ constraints ] Σ[ r-j ∈ result ] (
                      r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒ r-j ⊣ k2 ∧ r-j ⇐ ex ⌊ ⛽⟨ n↓ ⟩ ⌋:=∅))

  lemma-xb-progress-case : ∀{Δ Σ' E r rules ex τ n n↓} →
                             (n == 1+ n↓) →
                             (len : Nat) →
                             (unchecked : rule ctx) →
                             len == ∥ unchecked ∥ →
                             (failed : (rule-fails {n↓} {E} {r} {ex}) ctx) →
                             (∀{c rule} → (c , rule) ∈ unchecked → (c , rule) ∈ rules) →
                             (∀{c c-j x-j e-j p-j} →
                                (c , c-j , x-j , e-j , p-j) ∈ failed →
                                c == c-j ∧ (c , |C x-j => e-j) ∈ rules) →
                             (∀{c} → dom rules c → dom unchecked c ∨ dom failed c) →
                             Δ , Σ' ⊢ [ E ]case r of⦃· rules ·⦄ ·: τ →
                             Δ , Σ' ⊢ ex :· τ →
                             ex ≠ ¿¿ →
                             Σ[ k ∈ constraints ] ([ E ]case r of⦃· rules ·⦄ ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:= k)
                             ∨ [ E ]case r of⦃· rules ·⦄ ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:=∅

  progress {n = Z} Γ⊢E ta
    = Inl (_ , _ , ELimit , π2 (typ-inhabitance-pres Γ⊢E ta))
  progress {n = 1+ n} Γ⊢E ta'@(TAFix ta) = Inl (_ , _ , EFix , TAFix Γ⊢E ta')
  progress {n = 1+ n} Γ⊢E (TAVar x∈Γ)
    with env-all-Γ Γ⊢E x∈Γ
  ... | _ , x∈E , ta = Inl (_ , _ , EVar x∈E , ta)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg)
    with progress Γ⊢E ta-arg
  ... | Inr arg-fails = Inr (EFAppArg arg-fails)
  ... | Inl (rarg , _ , arg-evals , ta-rarg)
    with progress Γ⊢E ta-f
  ... | Inr f-fails = Inr (EFAppFun f-fails)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]fix f ⦇·λ x => ef ·⦈ , _ , f-evals , ta'@(TAFix Γ'⊢E' (TAFix ta-ef)))
    with progress {n = n} (EnvInd (EnvInd Γ'⊢E' ta') ta-rarg) ta-ef
  ... | Inr ef-fails = Inr (EFAppFixEval CF⛽ refl f-evals arg-evals ef-fails)
  ... | Inl (ref , _ , ef-evals , ta-ref) = Inl (_ , _ , EAppFix CF⛽ refl f-evals arg-evals ef-evals , ta-ref)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]??[ u ] , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ((rf-f ∘ rf-arg) , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl (fst _ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl (snd _ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]case rf of⦃· rules ·⦄ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ((C⁻[ _ ] _) , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E TAUnit = Inl (_ , _ , EUnit , TAUnit)
  progress {n = 1+ n} Γ⊢E (TAPair _ ta1 ta2)
    with progress Γ⊢E ta1
  ... | Inr fails                    = Inr (EFPair1 fails)
  ... | Inl (_ , _ , evals1 , ta-r1)
    with progress Γ⊢E ta2
  ... | Inr fails                    = Inr (EFPair2 fails)
  ... | Inl (_ , _ , evals2 , ta-r2) = Inl (_ , _ , EPair evals1 evals2 , TAPair ta-r1 ta-r2)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta)
    with progress Γ⊢E ta
  ... | Inr fails = Inr (EFFst fails)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (⟨ r1 , r2 ⟩ , _ , evals , TAPair ta-r1 ta-r2)
    = Inl (_ , _ , EFst evals , ta-r1)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , evals , TAFix _ ())
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ((C⁻[ x ] q) , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]??[ x₁ ] , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ((q ∘ q₁) , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (fst q , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (snd q , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]case q of⦃· x₁ ·⦄ , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta)
    with progress Γ⊢E ta
  ... | Inr fails = Inr (EFSnd fails)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (⟨ r1 , r2 ⟩ , _ , evals , TAPair ta-r1 ta-r2)
    = Inl (_ , _ , ESnd evals , ta-r2)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , evals , TAFix _ ())
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ((C⁻[ x ] q) , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]??[ x₁ ] , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ((q ∘ q₁) , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (fst q , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (snd q , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]case q of⦃· x₁ ·⦄ , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {n = 1+ n} Γ⊢E (TACtor d∈Σ' c∈d ta)
    with progress Γ⊢E ta
  ... | Inr e-fails = Inr (EFCtor e-fails)
  ... | Inl (_ , _ , e-evals , ta-r) = Inl (_ , _ , ECtor e-evals , TACtor d∈Σ' c∈d ta-r)
  progress {Σ' = Σ'} {n = 1+ n} Γ⊢E (TACase d∈σ' e-ta cctx⊆rules h-rules)
    with progress Γ⊢E e-ta
  ... | Inr e-fails = Inr (EFMatchScrut e-fails)
  ... | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , e-evals , TAFix _ ())
  ... | Inl ([ x ]??[ x₁ ] , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((re ∘ re₁) , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl (fst _ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl (snd _ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ([ x ]case re of⦃· x₁ ·⦄ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((C⁻[ _ ] _) , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((C[ c ] re) , _ , e-evals , TACtor d∈'σ' c∈cctx' ta-re)
    rewrite ctxunicity d∈'σ' d∈σ'
    with π2 (cctx⊆rules (_ , c∈cctx'))
  ... | form
    with h-rules form
  ... | _ , _ , _ , c∈cctx , ec-ta
    rewrite ctxunicity c∈cctx c∈cctx'
    with progress {n = n} (EnvInd Γ⊢E ta-re) ec-ta
  ... | Inr ec-fails = Inr (EFMatchRule CF⛽ form e-evals ec-fails)
  ... | Inl (_ , _ , ec-evals , ta-rec) = Inl (_ , _ , EMatch CF⛽ form e-evals ec-evals , ta-rec)
  progress {n = 1+ n} Γ⊢E (TAHole u∈Δ) = Inl (_ , _ , EHole , TAHole u∈Δ Γ⊢E)
  progress {n = 1+ n} Γ⊢E (TAAsrt _ ta1 ta2)
    with progress Γ⊢E ta1
  ... | Inr e1-fails = Inr (EFAsrtL e1-fails)
  ... | Inl (r1 , _ , e1-evals , ta-r1)
    with progress Γ⊢E ta2
  ... | Inr e2-fails = Inr (EFAsrtR e2-fails)
  ... | Inl (r2 , _ , e2-evals , ta-r2)
    with xc-progress ta-r1 ta-r2
  ... | Inl (_ , c-succ) = Inl (_ , _ , EAsrt e1-evals e2-evals c-succ , TAUnit)
  ... | Inr c-fail       = Inr (EFAsrt e1-evals e2-evals c-fail)

  lemma-xc-no-coerce : ∀{Δ Σ' r1 r2 τ n} →
                         Δ , Σ' ⊢ r1 ·: τ →
                         Δ , Σ' ⊢ r2 ·: τ →
                         r1 ≠ r2 →
                         (∀{ex} → Coerce r1 := ex → ⊥) →
                         r1 ≠ ⟨⟩ →
                         (∀{r'1 r'2} → r1 ≠ ⟨ r'1 , r'2 ⟩) →
                         (∀{c r} → r1 ≠ (C[ c ] r)) →
                         Σ[ k ∈ constraints ] Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:= k
                         ∨ Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:=∅
  lemma-xc-no-coerce ta1 (TAFix x x₁) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TAApp ta2 ta3) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 TAUnit r1≠r2 no-coerce not-unit not-pair not-ctor
    with xb-progress ta1 TAUnit
  ...  | Inl (_ , xb) = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) CoerceUnit xb))
  ...  | Inr xb-fails = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) CoerceUnit xb-fails)
  lemma-xc-no-coerce ta1 ta2@(TAPair _ _) r1≠r2 no-coerce not-unit not-pair not-ctor
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ {c-r2 → nc (_ , c-r2)})
  ...  | Inl (_ , c-r2)
    with xb-progress ta1 (Coerce-preservation ta2 c-r2)
  ...  | Inr xb-fails   = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb))
  lemma-xc-no-coerce ta1 (TAFst ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TASnd ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 ta2@(TACtor _ _ _) r1≠r2 no-coerce not-unit not-pair not-ctor
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ {c-r2 → nc (_ , c-r2)})
  ...  | Inl (_ , c-r2)
    with xb-progress ta1 (Coerce-preservation ta2 c-r2)
  ...  | Inr xb-fails   = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb))
  lemma-xc-no-coerce ta1 (TAUnwrapCtor x x₁ ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TACase x x₁ ta2 x₂ x₃) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TAHole x x₁) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())

  xc-progress {r1 = r1} {r2} ta1 ta2
    with result-==-dec r1 r2
  ... | Inl refl = Inl (_ , XCExRefl)
  xc-progress {r1 = _} {_} ta1@(TAFix x x₁) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TAApp _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} TAUnit ta2 | Inr r1≠r2
    with xb-progress ta2 TAUnit
  ...  | Inl (_ , xb) = Inl (_ , (XCBackProp2 r1≠r2 (Inl (λ ())) (Inl (λ ())) CoerceUnit xb))
  ...  | Inr xb-fails = Inr (XCFXB2 r1≠r2 (Inl (λ ())) (Inl (λ ())) CoerceUnit xb-fails)
  xc-progress (TAPair ta1a ta1b) (TAPair ta2a ta2b) | Inr r1≠r2
    with xc-progress ta1a ta2a
  ...  | Inr xca-fails = Inr (XCFPair1 xca-fails)
  ...  | Inl (_ , xca)
    with xc-progress ta1b ta2b
  ...  | Inr xcb-fails = Inr (XCFPair2 xcb-fails)
  ...  | Inl (_ , xcb) = Inl (_ , XCPair r1≠r2 xca xcb)
  xc-progress ta1@(TAPair _ _) ta2@(TAApp _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAFst _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TASnd _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAUnwrapCtor _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TACase _ _ _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAHole _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAFst _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TASnd _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress (TACtor {c = c1} d∈σ1 c1∈cctx ta1) (TACtor {c = c2} d∈σ2 c2∈cctx ta2) | Inr r1≠r2
    with natEQ c1 c2
  ...  | Inr ne         = Inr (XCFCtorMM ne)
  ...  | Inl refl
    rewrite ctxunicity d∈σ1 d∈σ2 | ctxunicity c1∈cctx c2∈cctx
    with xc-progress ta1 ta2
  ...  | Inr xc-fails   = Inr (XCFCtor xc-fails)
  ...  | Inl (_ , xc)   = Inl (_ , XCCtor (λ where refl → r1≠r2 refl) xc)
  xc-progress ta1@(TACtor _ _ _) ta2@(TAApp _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAFst _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TASnd _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAUnwrapCtor _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TACase _ _ _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAHole _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress {r1 = _} {_} ta1@(TAUnwrapCtor _ _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TACase _ _ _ _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TAHole _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()

  xb-progress {n = Z} _ _ = Inl (_ , XBLimit)
  xb-progress {ex = ex} {n = 1+ n} ta-r ta-ex
    with ex-¿¿-dec {ex}
  ... | Inl refl = Inl (_ , XBNone)
  xb-progress {n = 1+ n} ta-f@(TAFix Γ⊢E (TAFix ta-e)) (TAMap _ ta-v ta-ex) | Inr ne
    with progress {n = n} (EnvInd (EnvInd Γ⊢E ta-f) ta-v) ta-e
  ... | Inr fails    = Inr (XBFFixEval CF⛽ refl fails)
  ... | Inl (_ , _ , evals , ta)
    with xb-progress {n = n} ta ta-ex
  ... | Inr fails    = Inr (XBFFix CF⛽ refl evals fails)
  ... | Inl (_ , xb) = Inl (_ , XBFix CF⛽ refl evals xb)
  xb-progress (TAFix x (TAFix _)) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAApp {arg = v} ta-rf ta-rarg) ta-ex | Inr ne
    with value-dec {v}
  ... | Inr nv  = Inr (XBFAppNonVal ne nv)
  ... | Inl val
    with xb-progress ta-rf (TAMap val ta-rarg ta-ex)
  ... | Inr fails    = Inr (XBFApp ne val fails)
  ... | Inl (_ , xb) = Inl (_ , XBApp ne val xb)
  xb-progress TAUnit TAUnit | Inr ne = Inl (_ , XBUnit)
  xb-progress TAUnit TADC   | Inr ne = Inl (_ , XBNone)
  xb-progress (TAPair ta-r1 ta-r2) (TAPair ta-ex1 ta-ex2) | Inr ne
    with xb-progress ta-r1 ta-ex1
  ... | Inr fails     = Inr (XBFPair1 fails)
  ... | Inl (_ , xb1)
    with xb-progress ta-r2 ta-ex2
  ... | Inr fails     = Inr (XBFPair2 fails)
  ... | Inl (_ , xb2) = Inl (_ , XBPair xb1 xb2)
  xb-progress (TAPair ta-r1 ta-r2) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAFst ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TAPair ta-ex TADC)
  ... | Inr fails    = Inr (XBFFst ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBFst ne xb)
  xb-progress (TASnd ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TAPair TADC ta-ex)
  ... | Inr fails    = Inr (XBFSnd ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBSnd ne xb)
  xb-progress (TACtor {c = c1} h1a h1b ta-r) (TACtor {c = c2} h2a h2b ta-ex) | Inr ne
    with natEQ c1 c2
  ... | Inr ne'  = Inr (XBFCtorMM ne')
  ... | Inl refl
    rewrite ctxunicity h1a h2a | ctxunicity h1b h2b
    with xb-progress ta-r ta-ex
  ... | Inr fails    = Inr (XBFCtor fails)
  ... | Inl (_ , xb) = Inl (_ , XBCtor xb)
  xb-progress (TACtor x x₁ ta-r) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAUnwrapCtor h1 h2 ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TACtor h1 h2 ta-ex)
  ... | Inr fails    = Inr (XBFUnwrapCtor ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBUnwrapCtor ne xb)
  xb-progress {n = 1+ n} ta-C@(TACase {rules = rules} x x₁ ta-r x₂ x₃) ta-ex | Inr ne
    = lemma-xb-progress-case {n = 1+ n} {n} refl ∥ rules ∥ rules refl ∅ (λ y → y) (λ ()) Inl ta-C ta-ex ne
  xb-progress (TAHole x x₁) TAUnit | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) (TAPair ta-ex ta-ex₁) | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) (TACtor x₂ x₃ ta-ex) | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAHole x x₁) (TAMap x₂ x₃ ta-ex) | Inr ne
    = Inr XBFHole

  lemma-xb-progress-case {E = E} {r} {rules} {ex} {n = n} {n↓} refl Z [] len-unchecked failed unchecked-wf failed-wf exh ta-C ta-ex n¿¿
    = Inr (XBFMatch CF⛽ n¿¿ all-failed)
      where
        all-failed : ∀{c-j x-j : Nat} {e-j : exp} →
                       (c-j , |C x-j => e-j) ∈ rules →
                       r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:=∅
                       ∨ Σ[ k1 ∈ constraints ] (
                             r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒∅)
                       ∨ Σ[ k1 ∈ constraints ] Σ[ k2 ∈ constraints ] Σ[ r-j ∈ result ] (
                             r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒ r-j ⊣ k2 ∧ r-j ⇐ ex ⌊ ⛽⟨ n↓ ⟩ ⌋:=∅)
        all-failed c-j∈rules
          with exh (_ , c-j∈rules)
        ... | Inl (_ , ())
        ... | Inr ((c-j , x-j , e-j , p-j) , c-j∈f)
          with failed-wf c-j∈f
        ... | refl , c-j∈'rules
          with ctxunicity c-j∈rules c-j∈'rules
        ... | refl = p-j
  lemma-xb-progress-case {n = 1+ n↓} {n↓} refl (1+ len) unchecked len-unchecked failed unchecked-wf failed-wf exh ta-C@(TACase {rules = rules} d∈σ' Γ⊢E ta-r _ ta-rules) ta-ex n¿¿
    with ctx-elim {Γ = unchecked}
  ... | Inl refl = abort (0≠1+n (! len-unchecked))
  ... | Inr (c , |C x-j => e-j , unchecked' , refl , c#unchecked')
    with unchecked-wf (x,a∈Γ,,x,a {Γ = unchecked'})
  ... | c∈rules
    with ta-rules c∈rules
  ... | _ , c∈cctx , ta-be
    with xb-progress ta-r (TACtor d∈σ' c∈cctx TADC)
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inl fails)
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , xb-r)
    with progress {n = n↓} (EnvInd Γ⊢E (TAUnwrapCtor d∈σ' c∈cctx ta-r)) ta-be
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inr (Inl (_ , xb-r , fails)))
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , _ , evals , ta-br)
    with xb-progress {n = n↓} ta-br ta-ex
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inr (Inr (_ , _ , _ , xb-r , evals , fails)))
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , xb)
          = Inl (_ , (XBMatch CF⛽ n¿¿ c∈rules xb-r evals xb))

{- TODO delete - this strong version is unprovable
module progress where
  progress : ∀{Δ Σ' Γ E e τ} →
               Δ , Σ' , Γ ⊢ E →
               Δ , Σ' , Γ ⊢ e :: τ →
               -- Either there's some properly-typed result that e will eval to
               -- for any beta reduction limit ...
               Σ[ r ∈ result ] (
                  Δ , Σ' ⊢ r ·: τ ∧
                  ∀{n} → Σ[ k ∈ constraints ] (E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒ r ⊣ k))
               ∨
               -- ... or evaluation will have a constraint failure for any
               -- beta reduction limit
               (∀{n} → E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒∅)
  progress Γ⊢E ta'@(TALam _ ta) = Inl (_ , TALam Γ⊢E ta' , (_ , EFun))
  progress Γ⊢E ta'@(TAFix _ _ ta) = Inl (_ , TAFix Γ⊢E ta' , (_ , EFix))
  progress Γ⊢E (TAVar x∈Γ)
    with env-all-Γ Γ⊢E x∈Γ
  ... | _ , x∈E , ta = Inl (_ , ta , (_ , EVar x∈E))
  progress Γ⊢E (TAApp _ ta-f ta-arg)
    with progress Γ⊢E ta-arg
  ... | Inr arg-fails = Inr (EFAppArg arg-fails)
  ... | Inl (_ , ta-rarg , arg-evals)
    with progress Γ⊢E ta-f
  ... | Inr f-fails = Inr (EFAppFun f-fails)
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl (([ E' ]λ x => ef) , TALam Γ'⊢E' (TALam x#Γ' ta-ef) , f-evals)
    with progress (EnvInd Γ'⊢E' ta-rarg) ta-ef
  ... | q = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ E' ]fix f ⦇·λ x => ef ·⦈ , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ x ]??[ x₁ ] , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ((rf ∘ rf₁) , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ((get[ x th-of x₁ ] rf) , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ x ]case rf of⦃· x₁ ·⦄ , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl (PF x , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TATpl ∥es∥==∥τs∥ _ tas) = {!!}
  progress {Δ} {Σ'} {E = E} {τ = τ} Γ⊢E (TAGet {i = i} {len} {e} len==∥τs∥ i<∥τs∥ ta)
    with progress Γ⊢E ta
  ... | Inr e-fails = Inr (EFGet e-fails)
  ... | Inl (⟨ rs ⟩ , TATpl ∥rs∥==∥τs∥ tas , e-evals)
          = let i<∥rs∥ = tr (λ y → i < y) (! ∥rs∥==∥τs∥) i<∥τs∥ in
            Inl (_ , tas i<∥rs∥ i<∥τs∥ , _ , EGet (len==∥τs∥ · ! ∥rs∥==∥τs∥) i<∥rs∥ (π2 e-evals))
  ... | Inl (([ x ]λ x₁ => x₂) , TALam _ () , e-evals)
  ... | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , TAFix _ () , e-evals)
  ... | Inl ([ x ]??[ x₁ ] , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ((r ∘ r₁) , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ((get[ x th-of x₁ ] r) , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ([ x ]case r of⦃· x₁ ·⦄ , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl (PF x , TAPF () , e-evals)
  progress Γ⊢E (TACtor d∈Σ' c∈d ta)
    with progress Γ⊢E ta
  ... | Inl (_ , ta-r , e-evals) = Inl (_ , TACtor d∈Σ' c∈d ta-r , _ , ECtor (π2 e-evals))
  ... | Inr e-fails = Inr (EFCtor e-fails)
  progress Γ⊢E (TACase x ta x₁ x₂) = {!!}
  progress Γ⊢E (TAHole u∈Δ) = Inl (_ , TAHole u∈Δ Γ⊢E , (_ , EHole))
  progress Γ⊢E (TAPF ta) = Inl (_ , TAPF ta , (_ , EPF))
  progress Γ⊢E (TAAsrt x ta ta₁) = {!!}
-}


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

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
open import LibraBFT.Impl.Consensus.BlockStorage.BlockStore
open import LibraBFT.Impl.Consensus.BlockStorage.BlockTree
open import LibraBFT.Impl.Consensus.ConsensusTypes.ExecutedBlock as ExecutedBlock
open import LibraBFT.Impl.Consensus.ConsensusTypes.Vote as Vote
open import LibraBFT.Impl.OBM.Prelude
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.ByteString
open import Util.Hash
open import Util.KVMap                                           as Map
open import Util.PKCS
open import Util.Prelude

open QCProps
open Invariants

module LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockTree where

module insertBlockESpec (eb0 : ExecutedBlock) (bt : BlockTree) where
  eb0Id = eb0 ^∙ ebId

  open Reqs (eb0 ^∙ ebBlock) bt

  -- This is not quite right.  It does not yet account for the updating of the parent Block
  -- Is it needed (see below)?
  record Updated (hv : HashValue) (pre post : BlockTree) (eb : ExecutedBlock) : Set where
    field
      ≢hv¬Upd : ∀ {hv'} → hv' ≢ hv → btGetBlock hv' post ≡ btGetBlock hv' pre

  record ContractOk (bt“ : BlockTree) (eb : ExecutedBlock) : Set where
    constructor mkContractOk
    field
      bt≡x    : bt ≡ (bt“ & btIdToBlock ∙~ (bt ^∙ btIdToBlock))
      -- The following two fields are not used, but something like this will be useful in proving
      -- btiPres and may provide value in their own right
      ¬upd    : ∀ {eb'} → btGetBlock eb0Id bt ≡ just eb' → bt ≡ bt“
      upd     :           btGetBlock eb0Id bt ≡ nothing  →  Updated eb0Id bt bt“ eb
      blocks≈ : NoHC1 → eb [ _≈Block_ ]L eb0 at ebBlock
      btiPres : ∀ {eci} → Preserves BlockTreeInv (bt , eci) (bt“ , eci)

  Contract : Either ErrLog (BlockTree × ExecutedBlock) → Set
  Contract (Left _) = ⊤
  Contract (Right (bt' , b)) = ContractOk bt' b

  open insertBlockE

  postulate -- TODO-1: prove; note that the contract is stronger than we need because insertBlockE
            -- is called only when btGetBlock eb0Id bt ≡ nothing in LibraBFT
    contract' : EitherD-weakestPre (step₀ eb0 bt) Contract

  contract : Contract (insertBlockE.E eb0 bt)
  contract = EitherD-contract (step₀ eb0 bt) Contract contract'

module insertQuorumCertESpec
  (qc : QuorumCert) (bt0  : BlockTree) where
  open insertQuorumCertE qc bt0

  Ok : Set
  Ok = ∃₂ λ bt1 il → insertQuorumCertE qc bt0 ≡ Right (bt1 , il)

  private
    Ok' : BlockTree → List InfoLog → Either ErrLog (BlockTree × List InfoLog) → Set
    Ok' bt il m = m ≡ Right (bt , il)

  record ContractOk (btPre btPost : BlockTree) (ilPre ilPost : List InfoLog) : Set where
    constructor mkContractOk
    field
      noNewQCs : ∈Post⇒∈PreOrBT (_≡ qc) btPre btPost

  ContractOk-trans : ∀ {btPre btInt btPost ilPre ilInt ilPost}
                   → ContractOk btPre btInt  ilPre ilInt
                   → ContractOk btInt btPost ilInt ilPost
                   → ContractOk btPre btPost ilPre ilPost
  ContractOk-trans (mkContractOk noNewQCs) (mkContractOk noNewQCs₁) =
                    mkContractOk (∈Post⇒∈PreOr'-trans _∈BlockTree_ (_≡ qc) noNewQCs noNewQCs₁)

  Contract : EitherD-Post ErrLog (BlockTree × List InfoLog)
  Contract (Left _) = ⊤
  Contract (Right (bt1 , il)) = ContractOk bt0 bt1 [] il

  contract' : EitherD-weakestPre step₀ Contract
  contract'
     with safetyInvariant
  ...| Left e     = tt
  ...| Right unit = contract-step₁'
    where
    contract-step₁' : EitherD-weakestPre (step₁ blockId) Contract
    proj₁ contract-step₁' _ = tt
    proj₂ contract-step₁' block _ = contract-step₂'
      where
      contract-step₂' : EitherD-weakestPre (step₂ blockId block) Contract
      proj₁ contract-step₂' _ = tt
      proj₂ contract-step₂' hcb _ =
        contract-step₃'
        where
        contract-cont2' : ∀ (bt : BlockTree) (info : List InfoLog)
                         → let (bt' , info') = continue2 bt info
                           in ContractOk bt bt' info info'
        contract-cont2' bt info
           with (bt ^∙ btHighestCommitCert ∙ qcCommitInfo ∙ biRound) <? (qc ^∙ qcCommitInfo ∙ biRound)
        ...| yes hqcR<qcR = mkContractOk (∈BlockTree-upd-hcc refl refl)
        ...| no  hqcR≥qcR = mkContractOk (λ _ x → inj₁ x)

        cont1-update-bt : BlockTree → BlockTree
        cont1-update-bt bt = bt & btIdToQuorumCert ∙~ Map.insert blockId qc (bt ^∙ btIdToQuorumCert)

        info' : List InfoLog → Bool → List InfoLog
        info' il b = (fakeInfo ∷ il) ++ (if b then (fakeInfo ∷ []) else [])

        contract-cont1' : ∀ (btPre : BlockTree) (infoPre : List InfoLog)
                        → let (btPost , infoPost) = continue1 btPre blockId block infoPre
                          in  ContractOk btPre btPost infoPre infoPost
        contract-cont1' btPre infoPre
           with Map.kvm-member blockId (btPre ^∙ btIdToQuorumCert)
        ...| true  = mkContractOk (ContractOk.noNewQCs (contract-cont2' btPre (info' infoPre $ ExecutedBlock.isNilBlock block )))
        ...| false = ContractOk-trans {btInt = cont1-update-bt btPre} {ilInt = info' infoPre $ ExecutedBlock.isNilBlock block }
                               (mkContractOk (∈Post⇒∈PreOrBT-QCs≡ _ refl refl))
                               (mkContractOk (ContractOk.noNewQCs (contract-cont2'
                                                                     (cont1-update-bt btPre)
                                                                     (info' infoPre $ ExecutedBlock.isNilBlock block))))

        bt' = bt0 & btHighestCertifiedBlockId ∙~ block ^∙ ebId
                  & btHighestQuorumCert       ∙~ qc

        contract-step₃' : EitherD-weakestPre (step₃ blockId block hcb) Contract
        proj₁ contract-step₃' _ = ContractOk-trans
                                    (mkContractOk (∈BlockTree-upd-hqc refl refl))
                                    (contract-cont1' bt' (fakeInfo ∷ []))
        proj₂ contract-step₃' _ = ContractOk-trans
                                    (mkContractOk (∈Post⇒∈PreOr'-refl _∈BlockTree_ _))
                                    (contract-cont1' bt0 [])


{-# OPTIONS --safe #-}

module Definition.Conversion.EqRelInstance where

open import Definition.Untyped
open import Definition.Untyped.Properties using (wkSingleSubstId)
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening using (_∷_⊆_; wkEq; step; id)
open import Definition.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Universe
open import Definition.Conversion.Stability
open import Definition.Conversion.Soundness
open import Definition.Conversion.Lift
open import Definition.Conversion.Conversion
open import Definition.Conversion.Transitivity
open import Definition.Conversion.Weakening
open import Definition.Conversion.Whnf
open import Definition.Typed.EqualityRelation
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction
open import Definition.Conversion.Symmetry

open import Tools.Nat
open import Tools.Product
import Tools.PropositionalEquality as PE
open import Tools.Function

-- Algorithmic equality of neutrals with injected conversion.
data _⊢_~_∷_^_ (Γ : Con Term) (k l A : Term) (r : TypeInfo) : Set where
  ↑ : ∀ {B} → Γ ⊢ A ≡ B ^ r → Γ ⊢ k ~ l ↑ B ^ r → Γ ⊢ k ~ l ∷ A ^ r

-- Properties of algorithmic equality of neutrals with injected conversion.

~-var : ∀ {x A r Γ} → Γ ⊢ var x ∷ A ^ r → Γ ⊢ var x ~ var x ∷ A ^ r
~-var x =
  let ⊢A = syntacticTerm x
  in  ↑ (refl ⊢A) (var-refl′ x)

~-app : ∀ {f g a b F G Γ rF lF lG lΠ}
      → Γ ⊢ f ~ g ∷ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ ! , ι lΠ ]
      → Γ ⊢ a [genconv↑] b ∷ F ^ [ rF , ι lF ]
      → Γ ⊢ f ∘ a ^ lΠ ~ g ∘ b ^ lΠ ∷ G [ a ] ^ [ ! , ι lG ]
~-app {rF = !} (↑ A≡B (~↑! x)) x₁ =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΠFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΠHE = Π≡A ΠFG≡B′ whnfB′
      F≡H , _ , _ , _ , G≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) B≡ΠHE ΠFG≡B′)
      _ , ⊢f , _ = syntacticEqTerm (soundnessConv↑Term x₁)
  in  ↑ (substTypeEq G≡E (refl ⊢f))
        (app-cong′  (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _)
                       B≡ΠHE ([~] _ (red D) whnfB′ x))
             (convConvTerm x₁ F≡H))
~-app {rF = %} (↑ A≡B (~↑! x)) x₁ =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΠFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΠHE = Π≡A ΠFG≡B′ whnfB′
      F≡H , _ , _ , _ , G≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) B≡ΠHE ΠFG≡B′)
      _ , ⊢f , _ = syntacticEqTerm (proj₂ (proj₂ (soundness~↑% x₁)))
  in  ↑ (substTypeEq G≡E (genRefl ⊢f))
        (app-cong′ (PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _)
                       B≡ΠHE ([~] _ (red D) whnfB′ x))
                   (conv~↑% x₁ F≡H))
~-natrec : ∀ {z z′ s s′ n n′ F F′ Γ lF}
         → (Γ ∙ ℕ ^ [ ! , ι ⁰ ]) ⊢ F [conv↑] F′ ^ [ ! , ι lF ]  →
      Γ ⊢ z [conv↑] z′ ∷ (F [ zero ]) ^ ι lF →
      Γ ⊢ s [conv↑] s′ ∷ (Π ℕ ^ ! ° ⁰ ▹ (F ^ ! ° lF ▹▹ F [ suc (var 0) ]↑ ° lF ° lF) ° lF ° lF) ^ ι lF →
      Γ ⊢ n ~ n′ ∷ ℕ ^ [ ! , ι ⁰ ] →
      Γ ⊢ natrec lF F z s n ~ natrec lF F′ z′ s′ n′ ∷ (F [ n ]) ^ [ ! , ι lF ]
~-natrec {n = n} {n′ = n′} x x₁ x₂ (↑ A≡B (~↑! x₄)) =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ℕ≡B′ = trans A≡B (subset* (red D))
      B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
      k~l′ = PE.subst (λ x → _ ⊢ n ~ n′ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x₄)
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
      _ , ⊢n , _ = syntacticEqTerm (soundness~↓! k~l′)
  in  ↑ (refl (substType ⊢F ⊢n)) (natrec-cong′ x x₁ x₂ k~l′)

~-Emptyrec : ∀ {e e' F F′ Γ l lEmpty}
         → Γ ⊢ F [conv↑] F′ ^ [ ! , ι l ] →
         Γ ⊢ e ∷ Empty lEmpty ^ [ % , ι lEmpty ] →
         Γ ⊢ e' ∷ Empty lEmpty ^ [ % , ι lEmpty ] →
         Γ ⊢ Emptyrec l lEmpty F e ~ Emptyrec l lEmpty F′ e' ∷ F ^ [ ! , ι l ]
~-Emptyrec {e = e} {e' = e'} x ⊢e ⊢e' =
  let k~l′ = %~↑ ⊢e ⊢e'
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
  in  ↑ (refl ⊢F) (Emptyrec-cong′ x k~l′)

~-IdCong : ∀ {A A' : Term} {l : Level} {t t' u u' : Term} {Γ : Con Term} →
      Γ ⊢ A ~ A' ∷ Univ ! l ^ [ ! , next l ] →
      Γ ⊢ t [conv↑] t' ∷ A ^ ι l →
      Γ ⊢ u [conv↑] u' ∷ A ^ ι l →
      Γ ⊢ Id A t u ~ Id A' t' u' ∷ SProp l ^ [ ! , next l ]
~-IdCong (↑ A≡B (~↑! x)) t~t' u~u' =
     let ⊢Γ = wfEqTerm (soundnessConv↑Term t~t')
         _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         A~A′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-cong A~A′ t~t' u~u'))

~-Idℕ : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ u [genconv↑] u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ t u ~ Id ℕ t' u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-Idℕ ⊢Γ (↑ A≡B (~↑! x)) u~u' =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕ t~t′ u~u'))

~-Idℕ0 : ∀ {u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ u ~ u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ zero u ~ Id ℕ zero u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-Idℕ0 ⊢Γ (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕ0 t~t′))

~-IdℕS : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ u ~ u' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ Id ℕ (suc t) u ~ Id ℕ (suc t') u' ∷ SProp ⁰ ^ [ ! , next ⁰ ]
~-IdℕS ⊢Γ X (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-ℕS X t~t′))

~-IdU : ∀ {t t' u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ u [genconv↑] u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) t u ~ Id (U ⁰) t' u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdU ⊢Γ (↑ A≡B (~↑! x)) X =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-U t~t′ X))

~-IdUℕ : ∀ {u u' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ u ~ u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) ℕ u ~ Id (U ⁰) ℕ u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdUℕ ⊢Γ (↑ A≡B (~↑! x)) =
     let _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-Uℕ t~t′))

~-IdUΠ : ∀ {A : Term} {rA : Relevance} {B A' B' u u' : Term}
    {Γ : Con Term} →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ u ~ u' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u ~
    Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° ⁰) u' ∷ SProp ¹ ^ [ ! , next ¹ ]
~-IdUΠ X (↑ A≡B (~↑! x)) =
     let ⊢Γ =  wfEqTerm (soundnessConv↑Term X)
         _ , ⊢B = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (Ugenⱼ ⊢Γ)) (~↑! (Id-UΠ X t~t′))

~-castcong : ∀ {A A' B B' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ~ A' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B [genconv↑] B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ A ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) A B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) A' B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ A B e t ~ cast ⁰ A' B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castcong (↑ A≡B (~↑! x)) X Y ⊢e ⊢e' =
     let _ , ⊢B , _ = syntacticEqTerm (soundnessConv↑Term X)
         _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-cong t~t′ X Y ⊢e ⊢e'))

~-castℕ : ∀ {B B' e e' t t' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ B ~ B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ B e t ~ cast ⁰ ℕ B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castℕ ⊢Γ (↑ A≡B (~↑! x)) X ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-ℕ t~t′ X ⊢e ⊢e'))

~-castℕℕ : ∀ {e e' t t' : Term} {Γ : Con Term} →
    ⊢ Γ →
    Γ ⊢ t ~ t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ ℕ e t ~ cast ⁰ ℕ ℕ e' t' ∷ ℕ ^ [ ! , ι ⁰ ]
~-castℕℕ ⊢Γ (↑ A≡B (~↑! x)) ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         ℕ≡B′ = trans A≡B (subset* (red D))
         B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡ℕ
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ (ℕⱼ ⊢Γ))) (~↑! (cast-ℕℕ t~t′ ⊢e ⊢e'))

~-castΠ : ∀ {A A' : Term} {rA : Relevance} {P P' B B' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ~ B' ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) B ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) B' ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) B e t ~ cast ⁰ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) B' e' t' ∷ B ^ [ ! , ι ⁰ ]
~-castΠ X (↑ A≡B (~↑! x)) Y ⊢e ⊢e' =
     let _ , ⊢B' = syntacticEq A≡B
         B′ , whnfB′ , D = whNorm ⊢B'
         U≡B′ = trans A≡B (subset* (red D))
         B≡U = U≡A-whnf U≡B′ whnfB′
         t~t′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓! x ^ _) B≡U
                      ([~] _ (red D) whnfB′ x)
         _ , ⊢B , _ = syntacticEqTerm (soundness~↓! t~t′)
     in ↑ (refl (univ ⊢B)) (~↑! (cast-Π X t~t′ Y ⊢e ⊢e'))

~-castℕΠ : ∀ {A A' : Term} {rA : Relevance} {P P' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ A ∷ Univ rA ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ rA , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ ℕ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) ℕ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) ℕ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ ℕ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) e t ~ cast ⁰ ℕ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) e' t' ∷
    Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castℕΠ ⊢A ⊢P X Y ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢A ▹ ⊢P))) (~↑! (cast-ℕΠ X Y ⊢e ⊢e'))

~-castΠℕ : ∀ {A A' : Term} {rA : Relevance} {P P' e e' t t' : Term}
    {Γ : Con Term} →
    Γ ⊢ A ∷ Univ rA ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ rA , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰
    ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e ∷ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ℕ ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ rA ° ⁰ ▹ P ° ⁰ ° ⁰) ℕ e t ~
    cast ⁰ (Π A' ^ rA ° ⁰ ▹ P' ° ⁰ ° ⁰) ℕ e' t' ∷ ℕ ^ [ ! , ι ⁰ ]
~-castΠℕ ⊢A ⊢P X Y ⊢e ⊢e' = ↑ (refl (univ (ℕⱼ (wfTerm ⊢A)))) (~↑! (cast-Πℕ X Y ⊢e ⊢e'))

~-castΠΠ%! : ∀ {A A' P P' B B' Q Q' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ∷ Univ % ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ % , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ∷ Univ ! ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ B ^ [ ! , ι ⁰ ]) ⊢ Q ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰ [genconv↑] Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e  ∷ Id (U ⁰) (Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ % ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~
        cast ⁰ (Π A' ^ % ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰) e' t' ∷ Π B ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castΠΠ%! ⊢A ⊢P X ⊢B ⊢Q Y t~t' ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢B ▹ ⊢Q)))
                                           (~↑! (cast-ΠΠ%! X Y t~t' ⊢e ⊢e'))

~-castΠΠ!% : ∀ {A A' P P' B B' Q Q' e e' t t' : Term} {Γ : Con Term} →
    Γ ⊢ A ∷ Univ ! ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ A ^ [ ! , ι ⁰ ]) ⊢ P ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰ [genconv↑] Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ B ∷ Univ % ⁰ ^ [ ! , next ⁰ ] →
    (Γ ∙ B ^ [ % , ι ⁰ ]) ⊢ Q ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰ [genconv↑] Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰ ∷ U ⁰ ^ [ ! , next ⁰ ] →
    Γ ⊢ t [genconv↑] t' ∷ Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ] →
    Γ ⊢ e  ∷ Id (U ⁰) (Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ e' ∷ Id (U ⁰) (Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰) ^ [ % , next ⁰ ] →
    Γ ⊢ cast ⁰ (Π A ^ ! ° ⁰ ▹ P ° ⁰ ° ⁰) (Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~
        cast ⁰ (Π A' ^ ! ° ⁰ ▹ P' ° ⁰ ° ⁰) (Π B' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰) e' t' ∷ Π B ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]
~-castΠΠ!% ⊢A ⊢P X ⊢B ⊢Q Y t~t' ⊢e ⊢e' = ↑ (refl (univ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢B ▹ ⊢Q)))
                                           (~↑! (cast-ΠΠ!% X Y t~t' ⊢e ⊢e'))

~-sym : {k l A : Term} {r : TypeInfo} {Γ : Con Term} → Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ l ~ k ∷ A ^ r
~-sym (↑ A≡B x) =
  let ⊢Γ = wfEq A≡B
      B , A≡B′ , l~k = sym~↑ (reflConEq ⊢Γ) x
  in  ↑ (trans A≡B A≡B′) l~k

~-trans : {k l m A : Term} {r : TypeInfo} {Γ : Con Term}
        → Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ l ~ m ∷ A ^ r
        → Γ ⊢ k ~ m ∷ A ^ r
~-trans (↑ x (~↑! x₁)) (↑ x₂ (~↑! x₃)) =
  let ⊢Γ = wfEq x
      k~m , _ = trans~↑! PE.refl (reflConEq ⊢Γ) x₁ x₃
  in  ↑ x (~↑! k~m)
~-trans (↑ x (~↑% x₁)) (↑ x₂ (~↑% x₃)) =
  let ⊢Γ = wfEq x
      k~m = trans~↑% (reflConEq ⊢Γ) x₁ (conv~↑% x₃ (trans (sym x₂) x))
  in  ↑ x (~↑% k~m)

~-wk : {k l A : Term} {r : TypeInfo} {ρ : Wk} {Γ Δ : Con Term} →
      ρ ∷ Δ ⊆ Γ →
      ⊢ Δ → Γ ⊢ k ~ l ∷ A ^ r → Δ ⊢ wk ρ k ~ wk ρ l ∷ wk ρ A ^ r
~-wk x x₁ (↑ x₂ x₃) = ↑ (wkEq x x₁ x₂) (wk~↑ x x₁ x₃)

~-conv : {k l A B : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ k ~ l ∷ A ^ r → Γ ⊢ A ≡ B ^ r → Γ ⊢ k ~ l ∷ B ^ r
~-conv (↑ x x₁) x₂ = ↑ (trans (sym x₂) x) x₁

~-to-conv : {k l A : Term} {Γ : Con Term} {r : TypeInfo} →
      Γ ⊢ k ~ l ∷ A ^ r →  Γ ⊢ k [genconv↑] l ∷ A ^ r
~-to-conv {r = [ ! , ll ]} (↑ x x₁) = convConvTerm (lift~toConv↑ x₁) (sym x)
~-to-conv {r = [ % , ll ]} (↑ x (~↑% x₁)) = conv~↑% x₁ (sym x)

un-univConv : ∀ {A B : Term} {r : Relevance} {l : Level} {Γ : Con Term} →
                Γ ⊢ A [conv↑] B ^ [ r , ι l ] →
                Γ ⊢ A [conv↑] B ∷ Univ r l ^ next l
un-univConv {A} {B} {r} {l} ([↑] A′ B′ D D′ whnfA′ whnfB′ (univ x)) =
            let ⊢Γ = wfEqTerm (soundnessConv↓Term x)
            in [↑]ₜ (Univ r l) A′ B′ (id (Ugenⱼ ⊢Γ)) (un-univ⇒* D) (un-univ⇒* D′) Uₙ whnfA′ whnfB′ x

Πₜ-cong : ∀ {F G H E rF rG lF lG lΠ Γ}
        → lF ≤ lΠ
        → lG ≤ lΠ
        → Γ ⊢ F ^ [ rF , ι lF ]
        → Γ ⊢ F [conv↑] H ∷ Univ rF lF ^ next lF
        → Γ ∙ F ^ [ rF , ι lF ] ⊢ G [conv↑] E ∷ Univ rG lG ^ next lG
        → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ [conv↑] Π H ^ rF ° lF ▹ E ° lG ° lΠ ∷ Univ rG lΠ ^ next lΠ
Πₜ-cong lF< lG< x x₁ x₂ = liftConvTerm (Π-cong PE.refl PE.refl PE.refl PE.refl lF< lG< x x₁ x₂)

~-irrelevance : {k l A : Term} {Γ : Con Term} {ll : TypeLevel}
               → Γ ⊢ k ∷ A ^ [ % , ll ]
               → Γ ⊢ l ∷ A ^ [ % , ll ]
               → Γ ⊢ k ~ l ∷ A ^ [ % , ll ]
~-irrelevance ⊢k ⊢l =
  let X = ~↑% (%~↑ ⊢k ⊢l)
      ⊢A  = syntacticTerm ⊢k
  in ↑ (refl ⊢A) X

soundnessgenConv : ∀ {a b A r Γ} → Γ ⊢ a [genconv↑] b ∷ A ^ r → Γ ⊢ a ≡ b ∷ A ^ r
soundnessgenConv {r = [ ! , l ]} = soundnessConv↑Term
soundnessgenConv {r = [ % , l ]} x = proj₂ (proj₂ (soundness~↑% x))

symgenConv : ∀ {t u A r Γ} → Γ ⊢ t [genconv↑] u ∷ A ^ r → Γ ⊢ u [genconv↑] t ∷ A ^ r
symgenConv {r = [ ! , l ]} = symConvTerm
symgenConv {r = [ % , l ]} t<>u = let ⊢Γ = wfEqTerm (proj₂ (proj₂ (soundness~↑% t<>u)))
                          in  sym~↑% (reflConEq ⊢Γ) t<>u

wkgenConv↑Term : ∀ {ρ t u A Γ r Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
             → Γ ⊢ t [genconv↑] u ∷ A ^ r
             → Δ ⊢ wk ρ t [genconv↑] wk ρ u ∷ wk ρ A ^ r
wkgenConv↑Term {r = [ ! , l ]} = wkConv↑Term
wkgenConv↑Term {r = [ % , l ]} = wk~↑%

convgenconv : ∀ {t u A B : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ t [genconv↑] u ∷ A ^ r →
      Γ ⊢ A ≡ B ^ r → Γ ⊢ t [genconv↑] u ∷ B ^ r
convgenconv {r = [ ! , l ]} = convConvTerm
convgenconv {r = [ % , l ]} = conv~↑%

transgenConv : ∀ {t u v A : Term} {r : TypeInfo} {Γ : Con Term} →
      Γ ⊢ t [genconv↑] u ∷ A ^ r →
      Γ ⊢ u [genconv↑] v ∷ A ^ r → Γ ⊢ t [genconv↑] v ∷ A ^ r
transgenConv {r = [ ! , l ]} = transConvTerm
transgenConv {r = [ % , l ]} = trans~↑!Term

-- Algorithmic equality instance of the generic equality relation.
instance eqRelInstance : EqRelSet
eqRelInstance = eqRel _⊢_[conv↑]_^_ _⊢_[genconv↑]_∷_^_ _⊢_~_∷_^_
                      ~-to-conv soundnessConv↑ soundnessgenConv
                      univConv↑ un-univConv
                      symConv symgenConv ~-sym
                      transConv transgenConv ~-trans
                      convgenconv ~-conv
                      wkConv↑ wkgenConv↑Term ~-wk
                      reductionConv↑ reductionConv↑Term
                      (liftConv ∘ᶠ (U-refl PE.refl)) ( liftConvTerm ∘ᶠ  (U-refl PE.refl))
                      (liftConvTerm ∘ᶠ ℕ-refl)
                      (liftConvTerm ∘ᶠ (Empty-refl PE.refl))
                      Πₜ-cong
                      (λ x x₁ x₂ → liftConvTerm (∃-cong PE.refl x x₁ x₂))
                      (liftConvTerm ∘ᶠ zero-refl)
                      (liftConvTerm ∘ᶠ suc-cong)
                      (λ l< l<' x x₁ x₂ x₃ x₄ x₅ → liftConvTerm (η-eq l< l<' x x₁ x₂ x₃ x₄ x₅))
                      ~-var ~-app ~-natrec ~-Emptyrec
                      ~-IdCong ~-Idℕ ~-Idℕ0 ~-IdℕS ~-IdU ~-IdUℕ ~-IdUΠ
                      ~-castcong ~-castℕ ~-castℕℕ ~-castΠ ~-castℕΠ ~-castΠℕ ~-castΠΠ%! ~-castΠΠ!%
                      ~-irrelevance


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

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Concrete.Records
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Concrete.Obligations.PreferredRound
import      LibraBFT.Concrete.Properties.Common          as Common
import      LibraBFT.Concrete.Properties.PreferredRound  as PR
open import LibraBFT.Impl.Consensus.Network              as Network
open import LibraBFT.Impl.Consensus.Network.Properties   as NetworkProps
open import LibraBFT.Impl.Consensus.RoundManager
import      LibraBFT.Impl.Handle                         as Handle
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Impl.Handle.InitProperties
open        initHandlerSpec
open import LibraBFT.Impl.IO.OBM.InputOutputHandlers
open import LibraBFT.Impl.IO.OBM.Properties.InputOutputHandlers
open import LibraBFT.Impl.Properties.Common
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open        ReachableSystemStateProps
open import LibraBFT.Impl.Properties.Util
open import Optics.All
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open Invariants
open RoundManagerTransProps

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId

open        ParamsWithInitAndHandlers Handle.InitHandler.initAndHandlers
open import LibraBFT.ImplShared.Util.HashCollisions Handle.InitHandler.initAndHandlers

open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms
                      Handle.InitHandler.initAndHandlers
                      PeerCanSignForPK PeerCanSignForPK-stable
open        Structural impl-sps-avp

-- This module proves the two "PreferredRound" proof obligations for our handler.

module LibraBFT.Impl.Properties.PreferredRound (𝓔 : EpochConfig) where

------------------------------------------------------------------------------

preferredRound₁ : PR.ImplObligation₁ Handle.InitHandler.initAndHandlers 𝓔
preferredRound₁ {pid} {pid'} {pk = pk} {pre} preach sps@(step-init rm×acts uni) {v = v} {m = m} {v' = v'} {m' = m'}
                hpk v'⊂m' m'∈acts sig' ¬bootstrap' pcs4' v⊂m m∈pool sig ¬bootstrap eid≡ rnd< v≈vabs v'≈vabs'
                c3
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  with initHandlerSpec.ContractOk.isInitPM init-contract m'∈acts
...| (_ , refl , noSigs)
  with v'⊂m'
...| vote∈qc vs∈qc _ qc∈pm = ⊥-elim (noSigs vs∈qc qc∈pm)

preferredRound₁ {pid} {pid'} {pk = pk} {pre} preach sps@(step-msg {sndr , P vm} vm'∈pool ini) {v = v} {m = m} {v' = v'} {m' = m'}
                hpk v'⊂m' m'∈acts sig' ¬bootstrap' pcs4' v⊂m m∈pool sig ¬bootstrap eid≡ rnd< v≈vabs v'≈vabs'
                c3 = obm-dangerous-magic' "Extend and use handleProposalSpec.contract"

preferredRound₁ {pid} {pre = pre} preach sps@(step-msg {_ , V vm} _ _)
                _ v'⊂m' m'∈acts sig' ¬bootstrap' ¬msb _ _ _ _ _ _ _ _ _
   with v'⊂m'
...| vote∈qc vs∈qc v≈rbld qc∈m' rewrite cong _vSignature v≈rbld =
       ⊥-elim ∘′ ¬msb $ qcVoteSigsSentB4-handle pid preach sps m'∈acts qc∈m' sig' vs∈qc v≈rbld ¬bootstrap'
...| vote∈vm = ⊥-elim (sendVote∉actions{outs = hvOut}{st = hvPre} (sym noVotes) m'∈acts)
  where
  hvPre = peerStates pre pid
  hvOut = LBFT-outs (handleVote 0 vm) hvPre
  open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

------------------------------------------------------------------------------

-- This proof is essentially the same as the votesOnce₂: no handler sends two different Votes
-- TODO-2: refactor for DRY?
preferredRound₂ : PR.ImplObligation₂ Handle.InitHandler.initAndHandlers 𝓔

preferredRound₂ {pid} _ (step-init rm×acts uni) _ v⊂m m∈acts _ _ _ _ _ _ _ _ _ _ _ _
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  with initHandlerSpec.ContractOk.isInitPM init-contract m∈acts
...| (_ , refl , noSigs)
  with v⊂m
...| vote∈qc vs∈qc _ qc∈pm = ⊥-elim (noSigs vs∈qc qc∈pm)

preferredRound₂ {pid}{pk = pk}{pre} rss (step-msg{sndr , m“} m“∈pool ini) {v = v}{v' = v'} hpk v⊂m m∈acts sig ¬bootstrap ¬msb4 pcsfpk v'⊂m' m'∈acts sig' ¬bootstrap' ¬msb4' _ _ round<
   with v⊂m
...| vote∈qc vs∈qc v≈rbld qc∈m rewrite cong _vSignature v≈rbld =
       ⊥-elim ∘′ ¬msb4 $ qcVoteSigsSentB4-handle pid rss (step-msg m“∈pool ini) m∈acts qc∈m sig vs∈qc v≈rbld ¬bootstrap
...| vote∈vm
  with v'⊂m'
...| vote∈qc vs∈qc' v≈rbld' qc∈m' rewrite cong _vSignature v≈rbld' =
       ⊥-elim ∘′ ¬msb4' $ qcVoteSigsSentB4-handle pid rss (step-msg m“∈pool ini) m'∈acts qc∈m' sig' vs∈qc' v≈rbld' ¬bootstrap'
...| vote∈vm
  with m“
...| P pm = ⊥-elim (<⇒≢ round< (cong (_^∙ vRound) v≡v'))
  where
  hpPool = msgPool pre
  hpPre  = peerStates pre pid
  hpOut  = LBFT-outs (handleProposal 0 pm) hpPre
  open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hpPool hpPre)

  v≡v' : v ≡ v'
  v≡v'
    with BlockId-correct? (pm ^∙ pmProposal)
  ...| no ¬validProposal = ⊥-elim (sendVote∉actions {outs = hpOut} {st = hpPre} (sym (proj₂ $ invalidProposal ¬validProposal)) m∈acts)
  ...| yes refl
    with voteAttemptCorrect refl (nohc rss m“∈pool pid ini (invariantsCorrect pid pre ini rss) refl refl   )
  ...| Voting.mkVoteAttemptCorrectWithEpochReq (Left (_ , Voting.mkVoteUnsentCorrect noVoteMsgOuts _)) _ =
    ⊥-elim (sendVote∉actions{outs = hpOut}{st = hpPre} (sym noVoteMsgOuts) m∈acts)
  ...| Voting.mkVoteAttemptCorrectWithEpochReq (Right (Voting.mkVoteSentCorrect vm pid voteMsgOuts _)) _ = begin
    v            ≡⟨        cong (_^∙ vmVote) (sendVote∈actions{outs = hpOut}{st = hpPre} (sym voteMsgOuts) m∈acts) ⟩
    vm ^∙ vmVote ≡⟨ (sym $ cong (_^∙ vmVote) (sendVote∈actions{outs = hpOut}{st = hpPre} (sym voteMsgOuts) m'∈acts)) ⟩
    v'           ∎
    where
    open ≡-Reasoning
... | V vm = ⊥-elim (sendVote∉actions{outs = hvOut}{st = hvPre} (sym noVotes) m∈acts)
  where
  hvPre = peerStates pre pid
  hvOut = LBFT-outs (handle pid (V vm) 0) hvPre
  open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)


module subst where

open import lib

open import cedille-types
open import ctxt-types
open import is-free
open import rename
open import general-util
open import syntax-util

substh-ret-t : Set → Set
substh-ret-t T = ∀ {ed} → ctxt → renamectxt → trie ⟦ ed ⟧ → T → T

substh : ∀ {ed} → substh-ret-t ⟦ ed ⟧
substh-term : substh-ret-t term
substh-type : substh-ret-t type
substh-kind : substh-ret-t kind
substh-tk : substh-ret-t tk
substh-optClass : substh-ret-t optClass
substh-optGuide : substh-ret-t optGuide
substh-optTerm : substh-ret-t optTerm
substh-optType : substh-ret-t optType
substh-liftingType : substh-ret-t liftingType
substh-arg : substh-ret-t arg
substh-args : substh-ret-t args
substh-params : substh-ret-t params
substh-cases : substh-ret-t cases
substh-varargs : {ed : exprd} → ctxt → renamectxt → trie ⟦ ed ⟧ → varargs → varargs × renamectxt

substh{TERM} = substh-term
substh{TYPE} = substh-type
substh{KIND} = substh-kind
substh{LIFTINGTYPE} = substh-liftingType
substh{TK} = substh-tk
substh{ARG} = substh-arg
substh{QUALIF} = λ Γ ρ σ q → q

subst-rename-var-if : {ed : exprd} → ctxt → renamectxt → var → trie ⟦ ed ⟧ → var
subst-rename-var-if Γ ρ "_" σ = "_"
subst-rename-var-if Γ ρ x σ =
  {- rename bound variable x iff it is one of the vars being substituted for,
     or if x occurs free in one of the terms we are substituting for vars,
     or if it is the renamed version of any variable -}
  if trie-contains σ x || trie-any (is-free-in check-erased x) σ || renamectxt-in-range ρ x || ctxt-binds-var Γ x then
    rename-away-from x (λ s → ctxt-binds-var Γ s || trie-contains σ s) ρ
  else
    x

substh-term Γ ρ σ (App t m t') = App (substh-term Γ ρ σ t) m (substh-term Γ ρ σ t')
substh-term Γ ρ σ (AppTp t tp) = AppTp (substh-term Γ ρ σ t) (substh-type Γ ρ σ tp)
substh-term Γ ρ σ (Hole x₁) = Hole x₁
substh-term Γ ρ σ (Lam _ b _ x oc t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Lam posinfo-gen b posinfo-gen x' (substh-optClass Γ ρ σ oc)
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-term Γ ρ σ (Let _ (DefTerm _ x m t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (Let posinfo-gen (DefTerm posinfo-gen x' (substh-optType Γ ρ σ m) (substh-term Γ ρ σ t))
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-term Γ ρ σ (Let _ (DefType _ x k t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (Let posinfo-gen (DefType posinfo-gen x' (substh-kind Γ ρ σ k) (substh-type Γ ρ σ t))
      (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-term Γ ρ σ (Open _ x t) = Open posinfo-gen x (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Parens _ t _) = substh-term Γ ρ σ t
substh-term{TERM} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   trie-lookup-else (Var posinfo-gen x') σ x'
substh-term{ARG} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   inst-lookup-term σ x'
substh-term{QUALIF} Γ ρ σ (Var _ x) =
 let x' = renamectxt-rep ρ x in
   qualif-lookup-term σ x'
substh-term Γ ρ σ (Var _ x) = Var posinfo-gen (renamectxt-rep ρ x)
substh-term Γ ρ σ (Beta _ ot ot') = Beta posinfo-gen (substh-optTerm Γ ρ σ ot) (substh-optTerm Γ ρ σ ot')
substh-term Γ ρ σ (IotaPair _ t1 t2 og pi') = IotaPair posinfo-gen (substh-term Γ ρ σ t1) (substh-term Γ ρ σ t2) (substh-optGuide Γ ρ σ og) pi'
substh-term Γ ρ σ (IotaProj t n _) = IotaProj (substh-term Γ ρ σ t) n posinfo-gen
substh-term Γ ρ σ (Epsilon _ lr m t) = Epsilon posinfo-gen lr m (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Sigma _ t) = Sigma posinfo-gen (substh-term Γ ρ σ t)
substh-term Γ ρ σ (Phi _ t t₁ t₂ _) = Phi posinfo-gen (substh-term Γ ρ σ t) (substh-term Γ ρ σ t₁) (substh-term Γ ρ σ t₂) posinfo-gen
substh-term Γ ρ σ (Rho _ op on t og t') = Rho posinfo-gen op on (substh-term Γ ρ σ t) (substh-optGuide Γ ρ σ og) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Chi _ T t') = Chi posinfo-gen (substh-optType Γ ρ σ T) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Delta _ T t') = Delta posinfo-gen (substh-optType Γ ρ σ T) (substh-term Γ ρ σ t')
substh-term Γ ρ σ (Theta _ θ t ls) = Theta posinfo-gen (substh-theta θ) (substh-term Γ ρ σ t) (substh-lterms ls)
  where substh-lterms : lterms → lterms
        substh-lterms (LtermsNil pi) = LtermsNil pi
        substh-lterms (LtermsCons m t ls) = LtermsCons m (substh-term Γ ρ σ t) (substh-lterms ls)
        substh-vars : vars → vars
        substh-vars (VarsStart x) = VarsStart (renamectxt-rep ρ x)
        substh-vars (VarsNext x xs) = VarsNext (renamectxt-rep ρ x) (substh-vars xs)
        substh-theta : theta → theta
        substh-theta (AbstractVars xs) = AbstractVars (substh-vars xs)
        substh-theta θ = θ
substh-term Γ ρ σ (Mu _ x t ot _ cs _) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
    Mu posinfo-gen x' (substh-term (ctxt-var-decl x' Γ) ρ' σ t) (substh-optType Γ ρ σ ot) posinfo-gen (substh-cases Γ ρ' σ cs) posinfo-gen
substh-term Γ ρ σ (Mu' _ t ot _ cs _) = Mu' posinfo-gen (substh-term Γ ρ σ t) (substh-optType Γ ρ σ ot) posinfo-gen (substh-cases Γ ρ σ cs) posinfo-gen

substh-cases Γ ρ σ NoCase = NoCase
substh-cases Γ ρ σ (SomeCase _ x varargs t cs) =
  let res = substh-varargs Γ ρ σ varargs in
  SomeCase posinfo-gen x (fst res) (substh-term Γ (snd res) σ t) (substh-cases Γ ρ σ cs)

substh-varargs Γ ρ σ NoVarargs                = NoVarargs , ρ
substh-varargs Γ ρ σ (NormalVararg x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  NormalVararg x' (fst res) , snd res
substh-varargs Γ ρ σ (ErasedVararg x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  ErasedVararg x' (fst res) , snd res
substh-varargs Γ ρ σ (TypeVararg   x varargs) =
  let x' = subst-rename-var-if Γ ρ x σ in
  let ρ' = renamectxt-insert ρ x x'    in
  let res = substh-varargs Γ ρ' σ varargs in
  TypeVararg x' (fst res) , snd res

substh-type Γ ρ σ (Abs _ b _ x atk t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Abs posinfo-gen b posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (TpLambda _ _ x atk t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    TpLambda posinfo-gen posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (Iota _ _ x m t) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Iota posinfo-gen posinfo-gen x' (substh-type Γ ρ σ m)
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
substh-type Γ ρ σ (Lft _ _ x t l) =
  let x' = subst-rename-var-if Γ ρ x σ in
    Lft posinfo-gen posinfo-gen x' (substh-term (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t)
      (substh-liftingType Γ ρ σ l)
substh-type Γ ρ σ (TpApp tp tp₁) = TpApp (substh-type Γ ρ σ tp) (substh-type Γ ρ σ tp₁)
substh-type Γ ρ σ (TpAppt tp t) = TpAppt (substh-type Γ ρ σ tp) (substh-term Γ ρ σ t)
substh-type Γ ρ σ (TpArrow tp arrowtype tp₁) = TpArrow (substh-type Γ ρ σ tp) arrowtype (substh-type Γ ρ σ tp₁)
substh-type Γ ρ σ (TpEq _ x₁ x₂ _) = TpEq posinfo-gen (substh-term Γ ρ σ x₁) (substh-term Γ ρ σ x₂) posinfo-gen
substh-type Γ ρ σ (TpParens _ tp _) = substh-type Γ ρ σ tp
substh-type Γ ρ σ (NoSpans tp _) = substh-type Γ ρ σ tp
substh-type{TYPE} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   trie-lookup-else (TpVar posinfo-gen x') σ x'
substh-type{ARG} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   inst-lookup-type σ x'
substh-type{QUALIF} Γ ρ σ (TpVar _ x) =
 let x' = renamectxt-rep ρ x in
   qualif-lookup-type σ x'
substh-type Γ ρ σ (TpVar _ x) = TpVar posinfo-gen (renamectxt-rep ρ x)
substh-type Γ ρ σ (TpHole _) = TpHole posinfo-gen --ACG
substh-type Γ ρ σ (TpLet _ (DefTerm _ x m t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (TpLet posinfo-gen (DefTerm posinfo-gen x' (substh-optType Γ ρ σ m) (substh-term Γ ρ σ t))
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-type Γ ρ σ (TpLet _ (DefType _ x k t) t') =
  let x' = subst-rename-var-if Γ ρ x σ in
     (TpLet posinfo-gen (DefType posinfo-gen x' (substh-kind Γ ρ σ k) (substh-type Γ ρ σ t))
      (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ t'))
substh-kind Γ ρ σ (KndArrow k k₁) = KndArrow (substh-kind Γ ρ σ k) (substh-kind Γ ρ σ k₁)
substh-kind Γ ρ σ (KndParens x₁ k x₂) = substh-kind Γ ρ σ k
substh-kind Γ ρ σ (KndPi _ _ x atk k) =
  let x' = subst-rename-var-if Γ ρ x σ in
    KndPi posinfo-gen posinfo-gen x' (substh-tk Γ ρ σ atk)
      (substh-kind (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ k)
substh-kind Γ ρ σ (KndTpArrow t k) = KndTpArrow (substh-type Γ ρ σ t) (substh-kind Γ ρ σ k)
substh-kind{QUALIF} Γ ρ σ (KndVar _ x xs) =
   qualif-lookup-kind (substh-args Γ ρ σ xs) σ x
substh-kind Γ ρ σ (KndVar _ x xs) = KndVar posinfo-gen x (substh-args Γ ρ σ xs)
substh-kind Γ ρ σ (Star _) = Star posinfo-gen

substh-arg Γ ρ σ (TermArg me t) = TermArg me (substh-term Γ ρ σ t)
substh-arg Γ ρ σ (TypeArg T) = TypeArg (substh-type Γ ρ σ T)

substh-args Γ ρ σ (ArgsCons a as) = ArgsCons (substh-arg Γ ρ σ a) (substh-args Γ ρ σ as)
substh-args Γ ρ σ ArgsNil = ArgsNil

substh-params{QUALIF} Γ ρ σ (ParamsCons (Decl _ pi me x atk _) ps) =
  ParamsCons (Decl posinfo-gen posinfo-gen me (pi % x) (substh-tk Γ ρ σ atk) posinfo-gen)
    (substh-params Γ (renamectxt-insert ρ x (pi % x)) (trie-remove σ (pi % x)) ps)
substh-params Γ ρ σ (ParamsCons (Decl _ _ me x atk _) ps) =
  ParamsCons (Decl posinfo-gen posinfo-gen me x (substh-tk Γ ρ σ atk) posinfo-gen)
    (substh-params Γ (renamectxt-insert ρ x x) (trie-remove σ x) ps)
substh-params Γ ρ σ ParamsNil = ParamsNil

substh-tk Γ ρ σ (Tkk k) = Tkk (substh-kind Γ ρ σ k)
substh-tk Γ ρ σ (Tkt t) = Tkt (substh-type Γ ρ σ t)

substh-optClass Γ ρ σ NoClass = NoClass
substh-optClass Γ ρ σ (SomeClass atk) = SomeClass (substh-tk Γ ρ σ atk)
substh-liftingType Γ ρ σ (LiftArrow l l₁) = LiftArrow (substh-liftingType Γ ρ σ l) (substh-liftingType Γ ρ σ l₁)
substh-liftingType Γ ρ σ (LiftParens _ l _) = substh-liftingType Γ ρ σ l
substh-liftingType Γ ρ σ (LiftPi _ x tp l) =
  let x' = subst-rename-var-if Γ ρ x σ in
    LiftPi posinfo-gen x' (substh-type Γ ρ σ tp)
       (substh-liftingType (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ l)
substh-liftingType Γ ρ σ (LiftStar _) = LiftStar posinfo-gen
substh-liftingType Γ ρ σ (LiftTpArrow tp l) =
  LiftTpArrow (substh-type Γ ρ σ tp) (substh-liftingType Γ ρ σ l)

substh-optType Γ ρ σ NoType = NoType
substh-optType Γ ρ σ (SomeType T) = SomeType (substh-type Γ ρ σ T)

substh-optTerm Γ ρ σ NoTerm = NoTerm
substh-optTerm Γ ρ σ (SomeTerm t _) = (SomeTerm (substh-term Γ ρ σ t) posinfo-gen)

substh-optGuide Γ ρ σ NoGuide = NoGuide
substh-optGuide Γ ρ σ (Guide _ x T) =
  let x' = subst-rename-var-if Γ ρ x σ in
  Guide posinfo-gen x' (substh-type (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') σ T)

subst-ret-t : Set → Set
subst-ret-t T = {ed : exprd} → ctxt → ⟦ ed ⟧ → var → T → T

subst : ∀ {ed} → subst-ret-t ⟦ ed ⟧
subst Γ t x = substh Γ empty-renamectxt (trie-single x t)

subst-term = subst {TERM}
subst-type = subst {TYPE}
subst-kind = subst {KIND}
subst-liftingType = subst {LIFTINGTYPE}
subst-tk = subst {TK}

subst-renamectxt : ∀ {ed : exprd} → ctxt → renamectxt → ⟦ ed ⟧ → ⟦ ed ⟧
subst-renamectxt {ed} Γ ρ = substh {ed} {ed} Γ ρ empty-trie

rename-var : ∀ {ed} → ctxt → var → var → ⟦ ed ⟧ → ⟦ ed ⟧
rename-var Γ x x' = subst-renamectxt Γ (renamectxt-single x x')

substs-ret-t : Set → Set
substs-ret-t T = ∀ {ed} → ctxt → trie ⟦ ed ⟧ → T → T

substs : ∀ {ed} → substs-ret-t ⟦ ed ⟧
substs Γ = substh Γ empty-renamectxt

substs-term = substs {TERM}
substs-type = substs {TYPE}
substs-kind = substs {KIND}
substs-liftingType = substs {LIFTINGTYPE}
substs-tk = substs {TK}

substs-args : substs-ret-t args
substs-args Γ = substh-args Γ empty-renamectxt

substs-params : substs-ret-t params
substs-params Γ = substh-params Γ empty-renamectxt

subst-params-args : ∀ {ed} → ctxt → params → args → ⟦ ed ⟧ → ⟦ ed ⟧ × params × args
subst-params-args Γ (ParamsCons (Decl _ _ me x atk _) ps) (ArgsCons a as) t =
  subst-params-args Γ (substs-params Γ (trie-single x a) ps) as (subst Γ a x t)
subst-params-args Γ ps as t = t , ps , as


------------------------------------------------------------------------------
-- ABP auxiliary lemma
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.StrongerInductionPrinciple.LemmaI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the auxiliary lemma

module Helper where

  helper : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
           Bit b →
           Fair os₂ →
           S b (i' ∷ is') os₁ os₂ as bs cs ds js →
           ∀ ft₁ os₁' → F*T ft₁ → Fair os₁' → os₁ ≡ ft₁ ++ os₁' →
           ∃[ js' ] js ≡ i' ∷ js'
  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js} Bb Fos₂
         (asS , bsS , csS , dsS , jsS)
         .(T ∷ []) os₁' f*tnil Fos₁' os₁-eq = js' , js-eq
    where
    os₁-eq-helper : os₁ ≡ T ∷ os₁'
    os₁-eq-helper = os₁              ≡⟨ os₁-eq ⟩
                    (T ∷ []) ++ os₁' ≡⟨ ++-∷ T [] os₁' ⟩
                    T ∷ ([] ++ os₁') ≡⟨ ∷-rightCong (++-leftIdentity os₁') ⟩
                    T ∷ os₁'         ∎

    as' : D
    as' = await b i' is' ds

    as-eq : as ≡ < i' , b > ∷ as'
    as-eq = trans asS (send-eq b i' is' ds)

    bs' : D
    bs' = corrupt os₁' · as'

    bs-eq : bs ≡ ok < i' , b > ∷ bs'
    bs-eq =
     bs ≡⟨ bsS ⟩
      corrupt os₁ · as
        ≡⟨ ·-rightCong as-eq ⟩
      corrupt os₁ · (< i' , b > ∷ as')
        ≡⟨ ·-leftCong (corruptCong os₁-eq-helper) ⟩
      corrupt (T ∷ os₁') · (< i' , b > ∷ as')
        ≡⟨ corrupt-T os₁' < i' , b > as' ⟩
      ok < i' , b > ∷ corrupt os₁' · as'
        ≡⟨ refl ⟩
      ok < i' , b > ∷ bs' ∎

    cs' : D
    cs' = ack (not b) · bs'

    js' : D
    js' = out (not b) · bs'

    js-eq : js ≡ i' ∷ js'
    js-eq = js                            ≡⟨ jsS ⟩
            out b · bs                    ≡⟨ ·-rightCong bs-eq ⟩
            out b · (ok < i' , b > ∷ bs') ≡⟨ out-ok≡ b b i' bs' refl ⟩
            i' ∷ out (not b) · bs'        ≡⟨ refl ⟩
            i' ∷ js'                      ∎

    ds' : D
    ds' = ds

  helper {b} {i'} {is'} {os₁} {os₂} {as} {bs} {cs} {ds} {js}
         Bb Fos₂ (asS , bsS , csS , dsS , jsS)
         .(F ∷ ft₁^) os₁' (f*tcons {ft₁^} FTft₁^) Fos₁' os₁-eq =
         helper Bb (tail-Fair Fos₂) ihS ft₁^ os₁' FTft₁^ Fos₁' refl

    where
    os₁^ : D
    os₁^ = ft₁^ ++ os₁'

    os₂^ : D
    os₂^ = tail₁ os₂

    os₁-eq-helper : os₁ ≡ F ∷ os₁^
    os₁-eq-helper = os₁                ≡⟨ os₁-eq ⟩
                    (F ∷ ft₁^) ++ os₁' ≡⟨ ++-∷ F ft₁^ os₁' ⟩
                    F ∷ ft₁^ ++ os₁'   ≡⟨ refl ⟩
                    F ∷ os₁^           ∎

    as^ : D
    as^ = await b i' is' ds

    as-eq : as ≡ < i' , b > ∷ as^
    as-eq = trans asS (send-eq b i' is' ds)

    bs^ : D
    bs^ = corrupt os₁^ · as^

    bs-eq : bs ≡ error ∷ bs^
    bs-eq =
      bs
        ≡⟨ bsS ⟩
      corrupt os₁ · as
        ≡⟨ ·-rightCong as-eq ⟩
      corrupt os₁ · (< i' , b > ∷ as^)
        ≡⟨ ·-leftCong (corruptCong os₁-eq-helper) ⟩
      corrupt (F ∷ os₁^) · (< i' , b > ∷ as^)
        ≡⟨ corrupt-F os₁^ < i' , b > as^ ⟩
      error ∷ corrupt os₁^ · as^
        ≡⟨ refl ⟩
      error ∷ bs^ ∎

    cs^ : D
    cs^ = ack b · bs^

    cs-eq : cs ≡ not b ∷ cs^
    cs-eq = cs                    ≡⟨ csS ⟩
            ack b · bs            ≡⟨ ·-rightCong bs-eq ⟩
            ack b · (error ∷ bs^) ≡⟨ ack-error b bs^ ⟩
            not b ∷ ack b · bs^   ≡⟨ refl ⟩
            not b ∷ cs^           ∎

    ds^ : D
    ds^ = corrupt os₂^ · cs^

    ds-eq-helper₁ : os₂ ≡ T ∷ tail₁ os₂ → ds ≡ ok (not b) ∷ ds^
    ds-eq-helper₁ h =
      ds                                 ≡⟨ dsS ⟩
      corrupt os₂ · cs                   ≡⟨ ·-rightCong cs-eq ⟩
      corrupt os₂ · (not b ∷ cs^)        ≡⟨ ·-leftCong (corruptCong h) ⟩
      corrupt (T ∷ os₂^) · (not b ∷ cs^) ≡⟨ corrupt-T os₂^ (not b) cs^ ⟩
      ok (not b) ∷ corrupt os₂^ · cs^    ≡⟨ refl ⟩
      ok (not b) ∷ ds^                   ∎

    ds-eq-helper₂ : os₂ ≡ F ∷ tail₁ os₂ → ds ≡ error ∷ ds^
    ds-eq-helper₂ h =
      ds                                 ≡⟨ dsS ⟩
      corrupt os₂ · cs                   ≡⟨ ·-rightCong cs-eq ⟩
      corrupt os₂ · (not b ∷ cs^)        ≡⟨ ·-leftCong (corruptCong h) ⟩
      corrupt (F ∷ os₂^) · (not b ∷ cs^) ≡⟨ corrupt-F os₂^ (not b) cs^ ⟩
      error ∷ corrupt os₂^ · cs^         ≡⟨ refl ⟩
      error ∷ ds^                        ∎

    ds-eq : ds ≡ ok (not b) ∷ ds^ ∨ ds ≡ error ∷ ds^
    ds-eq = case (λ h → inj₁ (ds-eq-helper₁ h))
                 (λ h → inj₂ (ds-eq-helper₂ h))
                 (head-tail-Fair Fos₂)

    as^-eq-helper₁ : ds ≡ ok (not b) ∷ ds^ → as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq-helper₁ h =
      await b i' is' ds
        ≡⟨ awaitCong₄ h ⟩
      await b i' is' (ok (not b) ∷ ds^)
        ≡⟨ await-ok≢ b (not b) i' is' ds^ (x≢not-x Bb) ⟩
      < i' , b > ∷ await b i' is' ds^
        ≡⟨ sym (send-eq b i' is' ds^) ⟩
      send b · (i' ∷ is') · ds^ ∎

    as^-eq-helper₂ : ds ≡ error ∷ ds^ → as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq-helper₂ h =
      await b i' is' ds               ≡⟨ awaitCong₄ h ⟩
      await b i' is' (error ∷ ds^)    ≡⟨ await-error b i' is' ds^ ⟩
      < i' , b > ∷ await b i' is' ds^ ≡⟨ sym (send-eq b i' is' ds^) ⟩
      send b · (i' ∷ is') · ds^     ∎

    as^-eq : as^ ≡ send b · (i' ∷ is') · ds^
    as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

    js-eq : js ≡ out b · bs^
    js-eq = js                    ≡⟨ jsS ⟩
            out b · bs            ≡⟨ ·-rightCong bs-eq ⟩
            out b · (error ∷ bs^) ≡⟨ out-error b bs^ ⟩
            out b · bs^ ∎

    ihS : S b (i' ∷ is') os₁^ os₂^ as^ bs^ cs^ ds^ js
    ihS = as^-eq , refl , refl , refl , js-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈ Fair
-- and hence by unfolding Fair, we conclude that there are ft₁ :  F*T
-- and os₁' : Fair, such that os₁ = ft₁ ++ os₁'.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma : ∀ {b i' is' os₁ os₂ as bs cs ds js} →
         Bit b →
         Fair os₁ →
         Fair os₂ →
         S b (i' ∷ is') os₁ os₂ as bs cs ds js →
         ∃[ js' ] js ≡ i' ∷ js'
lemma Bb Fos₁ Fos₂ s with Fair-out Fos₁
... | ft , os₁' , FTft , prf ,  Fos₁' = helper Bb Fos₂ s ft os₁' FTft Fos₁' prf


module Luau.Syntax.ToString where

open import Agda.Builtin.Float using (primShowFloat)
open import Luau.Syntax using (Block; Stat; Expr; VarDec; FunDec; nil; var; var_∈_; addr; _$_; function_is_end; return; local_←_; _∙_; done; block_is_end; _⟨_⟩; _⟨_⟩∈_; number; BinaryOperator; +; -; *; /; binexp)
open import FFI.Data.String using (String; _++_)
open import Luau.Addr.ToString using (addrToString)
open import Luau.Type.ToString using (typeToString)
open import Luau.Var.ToString using (varToString)

varDecToString : ∀ {a} → VarDec a → String
varDecToString (var x) = varToString x
varDecToString (var x ∈ T) =  varToString x ++ " : " ++ typeToString T

funDecToString : ∀ {a} → FunDec a → String
funDecToString ("" ⟨ x ⟩∈ T) = "function(" ++ varDecToString x ++ "): " ++ typeToString T
funDecToString ("" ⟨ x ⟩) = "function(" ++ varDecToString x ++ ")"
funDecToString (f ⟨ x ⟩∈ T) = "function " ++ varToString f ++ "(" ++ varDecToString x ++ "): " ++ typeToString T
funDecToString (f ⟨ x ⟩) = "function " ++ varToString f ++ "(" ++ varDecToString x ++ ")"

binOpToString : BinaryOperator → String
binOpToString + = "+"
binOpToString - = "-"
binOpToString * = "*"
binOpToString / = "/"

exprToString′ : ∀ {a} → String → Expr a → String
statToString′ : ∀ {a} → String → Stat a → String
blockToString′ : ∀ {a} → String → Block a → String

exprToString′ lb nil =
  "nil"
exprToString′ lb (addr a) =
  addrToString(a)
exprToString′ lb (var x) =
  varToString(x)
exprToString′ lb (M $ N) =
  (exprToString′ lb M) ++ "(" ++ (exprToString′ lb N) ++ ")"
exprToString′ lb (function F is B end) =
  funDecToString F ++ lb ++
  "  " ++ (blockToString′ (lb ++ "  ") B) ++ lb ++
  "end"
exprToString′ lb (block b is B end) =
  "(" ++ b ++ "()" ++ lb ++
  "  " ++ (blockToString′ (lb ++ "  ") B) ++ lb ++
  "end)()"
exprToString′ lb (number x) = primShowFloat x
exprToString′ lb (binexp x op y) = exprToString′ lb x ++ " " ++ binOpToString op ++ " " ++ exprToString′ lb y

statToString′ lb (function F is B end) =
  "local " ++ funDecToString F ++ lb ++
  "  " ++ (blockToString′ (lb ++ "  ") B) ++ lb ++
  "end"
statToString′ lb (local x ← M) =
  "local " ++ varDecToString x ++ " = " ++ (exprToString′ lb M)
statToString′ lb (return M) =
  "return " ++ (exprToString′ lb M)

blockToString′ lb (S ∙ done) = statToString′ lb S
blockToString′ lb (S ∙ B) = statToString′ lb S ++ lb ++ blockToString′ lb B
blockToString′ lb (done) = ""

exprToString : ∀ {a} → Expr a → String
exprToString = exprToString′ "\n"

statToString : ∀ {a} → Stat a → String
statToString = statToString′ "\n"

blockToString : ∀ {a} → Block a → String
blockToString = blockToString′ "\n"


-- {-# OPTIONS -v tc.meta.assign:50 #-}
module Issue483c where

import Common.Level

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

data ⊥ : Set where
record ⊤ : Set where

refute : .⊥ → ⊥
refute ()

mk⊤ : ⊥ → ⊤
mk⊤ ()

X   : .⊤ → ⊥
bad : .(x : ⊥) → X (mk⊤ x) ≡ refute x
X     = _
bad x = refl

false : ⊥
false = X _


open import Data.String using ( String )
open import Data.ByteString using ( ByteString ; Style ; lazy ; strict )
open import Data.ByteString.UTF8 using ( toString ; fromString )
open import System.IO.Primitive using ( HandleR ; HandleW ; hOpenR ; hOpenW ; hCloseR ; hCloseW ; hGetStrict ; hGetLazy ; hPutStrict ; hPutLazy )

-- A proposed binding for the Haskell IO library.

-- The semantics is strict IO, there is no visibility for semi-closed handles.

module System.IO where

open System.IO.Primitive public using ( Unit ; IO ; unit ; return ; _>>=_ ; commit ; onCommit ; stdin ; stdout ; stderr )

-- Command is a synonym for IO Unit

Command : Set
Command = IO Unit

skip : Command
skip = return unit

-- Other operations are defined in terms of _>>=_

infixl 1 _>>_
infixl 4 _<$>_ _<*>_

_>>_ : {A B : Set} → (IO A) → (IO B) → (IO B)
a >> b = a >>= (λ x → b)

_<$>_ : {A B : Set} → (A → B) → (IO A) → (IO B)
_<$>_ f a = a >>= (λ x → return (f x))

_<*>_ : {A B : Set} → (IO (A → B)) → (IO A) → (IO B)
_<*>_ f a = f >>= (λ x → x <$> a)

-- TODO: Use the new "syntax" construct to define do-like notation?

-- TODO: RW and Append mode?

data IOMode : Set where
  read write : IOMode

Handle : IOMode → Set
Handle read = HandleR
Handle write = HandleW

-- TODO: There should really be a separate type for file paths,
-- and some sanity-checking to support protection against
-- injection attacks.

hOpen : {m : IOMode} → String → IO (Handle m)
hOpen {read} = hOpenR
hOpen {write} = hOpenW

hGetBytes : {s : Style} → (Handle read) → IO (ByteString s)
hGetBytes {lazy}   = hGetLazy
hGetBytes {strict} = hGetStrict

getBytes : {s : Style} → IO (ByteString s)
getBytes = hGetBytes stdin

hPutBytes : {s : Style} → (Handle write) → (ByteString s) → Command
hPutBytes {lazy}   = hPutLazy
hPutBytes {strict} = hPutStrict

putBytes : {s : Style} → (ByteString s) → Command
putBytes = hPutBytes stdout

hClose : {m : IOMode} → (Handle m) → Command
hClose {read} = hCloseR
hClose {write} = hCloseW

-- TODO: Better handling of codecs, don't just hard-wire UTF-8!
-- TODO: Lazy vs strict strings?
-- Default arguments would help a lot here.

hGetStr : (Handle read) → (IO String)
hGetStr hdl = toString <$> hGetBytes {lazy} hdl

getStr : (IO String)
getStr = hGetStr stdin

hPutStr : (Handle write) → String → Command
hPutStr hdl s = hPutBytes {lazy} hdl (fromString s)

putStr : String → Command
putStr = hPutStr stdout


{-# OPTIONS --with-K #-}
open import Axiom.Extensionality.Propositional using (Extensionality)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary using (Irrelevant)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_)
open import Relation.Binary.PropositionalEquality.WithK using (≡-erase)

-- acursed and unmentionable
-- turn back traveller
module AKS.Unsafe where

open import Relation.Binary.PropositionalEquality.TrustMe using (trustMe) public

postulate
  TODO : ∀ {a} {A : Set a} → A
  BOTTOM : ∀ {a} {A : Set a} → A
  .irrelevance : ∀ {a} {A : Set a} -> .A -> A
  ≡-recomp : ∀ {a} {A : Set a} {x y : A} → .(x ≡ y) → x ≡ y
  fun-ext : ∀ {ℓ₁ ℓ₂} → Extensionality ℓ₁ ℓ₂

≡-recomputable : ∀ {a} {A : Set a} {x y : A} → .(x ≡ y) → x ≡ y
≡-recomputable x≡y = ≡-erase (≡-recomp x≡y)

≢-irrelevant : ∀ {a} {A : Set a} → Irrelevant {A = A} _≢_
≢-irrelevant {x} {y} [x≉y]₁ [x≉y]₂ = trustMe