From Coq Require Import ssreflect.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config BasicAst.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICLiftSubst
  PCUICSigmaCalculus.

#[global] Hint Extern 20 (#|?X| = #|?Y|) =>
  match goal with
  [ H : All2_fold _ ?X ?Y |- _ ] => apply (All2_fold_length H)
  | [ H : All2_fold _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H)
  | [ H : on_contexts_over _ _ _ ?X ?Y |- _ ] => apply (All2_fold_length H)
  | [ H : on_contexts_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H)
   end : pcuic.

Ltac pcuic_core :=
  try (solve [ intuition auto; eauto with pcuic || (try lia || congruence) ]).

Ltac pcuic :=
  pcuic_core || ltac:(try (red; repeat red; cbn in *; pcuic_core)).

Definition lengths :=
  (@context_assumptions_expand_lets_ctx,
   @context_assumptions_subst_context,
   context_assumptions_fold,
   @context_assumptions_app,
   @context_assumptions_map,
   @context_assumptions_mapi,
   @context_assumptions_mapi_context,
   @context_assumptions_smash_context,
   @context_assumptions_subst_instance,
   @context_assumptions_lift_context,
   @inst_case_context_assumptions,
    @expand_lets_ctx_length, @subst_context_length,
    @subst_instance_length, @expand_lets_k_ctx_length, @inds_length, @lift_context_length,
    @app_length, @repeat_length, @List.rev_length, @extended_subst_length, @reln_length,
    Nat.add_0_r, @app_nil_r, @rev_map_length, @rev_length, @unfold_length,
    @map_length, @mapi_length, @mapi_rec_length, @map_InP_length,
    @fold_context_length,
    @fold_context_k_length, @cofix_subst_length, @fix_subst_length,
    fix_context_length,
    @smash_context_length,
    @arities_context_length,
    @forget_types_length,
    @PCUICCases.ind_predicate_context_length,
    @PCUICCases.cstr_branch_context_length,
    @PCUICCases.inst_case_branch_context_length,
    @PCUICCases.inst_case_predicate_context_length,
    @inst_case_context_length,
    @ind_predicate_context_length,
    @map_context_length, @skipn_map_length,
    @mapi_context_length, idsn_length,
    @projs_length, ren_ids_length).

Ltac len ::=
  repeat (rewrite !lengths /= //); try solve [lia_f_equal].

Tactic Notation "len" "in" hyp(id) :=
  repeat (rewrite !lengths /= // in id);
  try solve [lia_f_equal].

(* Can be used after [move] by ssr tactics, e.g. [rewrite foo => /lens] *)
Notation "'lens'" := ltac:(len) (only parsing).


From stdpp Require Import gmap.
From iris.heap_lang Require Export lang.
From iris.prelude Require Import options.

(* This file contains some metatheory about the heap_lang language,
  which is not needed for verifying programs. *)

(* Closed expressions and values. *)
Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
  match e with
  | Val v => is_closed_val v
  | Var x => bool_decide (x ∈ X)
  | Rec f x e => is_closed_expr (f :b: x :b: X) e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Free e | Load e =>
     is_closed_expr X e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Store e1 e2 | FAA e1 e2 =>
     is_closed_expr X e1 && is_closed_expr X e2
  | If e0 e1 e2 | Case e0 e1 e2 | CmpXchg e0 e1 e2 | Resolve e0 e1 e2 =>
     is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
  | NewProph => true
  end
with is_closed_val (v : val) : bool :=
  match v with
  | LitV _ => true
  | RecV f x e => is_closed_expr (f :b: x :b: []) e
  | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
  | InjLV v | InjRV v => is_closed_val v
  end.

Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
Proof. revert X Y; induction e; naive_solver (eauto; set_solver). Qed.

Lemma is_closed_weaken_nil X e : is_closed_expr [] e → is_closed_expr X e.
Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.

Lemma is_closed_subst X e x v :
  is_closed_val v → is_closed_expr (x :: X) e → is_closed_expr X (subst x v e).
Proof.
  intros Hv. revert X.
  induction e=> X /= ?; destruct_and?; split_and?; simplify_option_eq;
    try match goal with
    | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
    end; eauto using is_closed_weaken with set_solver.
Qed.
Lemma is_closed_subst' X e x v :
  is_closed_val v → is_closed_expr (x :b: X) e → is_closed_expr X (subst' x v e).
Proof. destruct x; eauto using is_closed_subst. Qed.

(* Substitution *)
Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
Proof.
  revert X. induction e=> X /=; rewrite ?bool_decide_spec ?andb_True=> ??;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
Qed.

Lemma subst_is_closed_nil e x v : is_closed_expr [] e → subst x v e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.

Lemma subst_subst e x v v' :
  subst x v (subst x v' e) = subst x v' e.
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst' e x v v' :
  subst' x v (subst' x v' e) = subst' x v' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y v v' :
  x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst_ne' e x y v v' :
  x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_rec' f y e x v :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x v (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
Lemma subst_rec_ne' f y e x v :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x v (Rec f y e) = Rec f y (subst' x v e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.

Lemma bin_op_eval_closed op v1 v2 v' :
  is_closed_val v1 → is_closed_val v2 → bin_op_eval op v1 v2 = Some v' →
  is_closed_val v'.
Proof.
  rewrite /bin_op_eval /bin_op_eval_bool /bin_op_eval_int /bin_op_eval_loc;
    repeat case_match; by naive_solver.
Qed.

Lemma heap_closed_alloc σ l n w :
  (0 < n)%Z →
  is_closed_val w →
  map_Forall (λ _ v, from_option is_closed_val true v) (heap σ) →
  (∀ i : Z, (0 ≤ i)%Z → (i < n)%Z → heap σ !! (l +ₗ i) = None) →
  map_Forall (λ _ v, from_option is_closed_val true v)
             (heap_array l (replicate (Z.to_nat n) w) ∪ heap σ).
Proof.
  intros Hn Hw Hσ Hl.
  eapply (map_Forall_ind
            (λ k v, ((heap_array l (replicate (Z.to_nat n) w) ∪ heap σ)
                       !! k = Some v))).
  - apply map_Forall_empty.
  - intros m i x Hi Hix Hkwm Hm.
    apply map_Forall_insert_2; auto.
    apply lookup_union_Some in Hix; last first.
    { eapply heap_array_map_disjoint;
        rewrite replicate_length Z2Nat.id; auto with lia. }
    destruct Hix as [(?&?&?&?&?&[-> Hlt%inj_lt]%lookup_replicate_1)%heap_array_lookup|
                     [j Hj]%elem_of_map_to_list%elem_of_list_lookup_1].
    + simplify_eq/=. rewrite !Z2Nat.id in Hlt; eauto with lia.
    + apply map_Forall_to_list in Hσ.
      by eapply Forall_lookup in Hσ; eauto; simpl in *.
  - apply map_Forall_to_list, Forall_forall.
    intros [? ?]; apply elem_of_map_to_list.
Qed.

(* The stepping relation preserves closedness *)
Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
  is_closed_expr [] e1 →
  map_Forall (λ _ v, from_option is_closed_val true v) σ1.(heap) →
  head_step e1 σ1 obs e2 σ2 es →
  is_closed_expr [] e2 ∧ Forall (is_closed_expr []) es ∧
  map_Forall (λ _ v, from_option is_closed_val true v) σ2.(heap).
Proof.
  intros Cl1 Clσ1 STEP.
  induction STEP; simpl in *; split_and!;
    try apply map_Forall_insert_2; try by naive_solver.
  - subst. repeat apply is_closed_subst'; naive_solver.
  - unfold un_op_eval in *. repeat case_match; naive_solver.
  - eapply bin_op_eval_closed; eauto; naive_solver.
  - by apply heap_closed_alloc.
  - select (_ !! _ = Some _) ltac:(fun H => by specialize (Clσ1 _ _ H)).
  - select (_ !! _ = Some _) ltac:(fun H => by specialize (Clσ1 _ _ H)).
  - case_match; try apply map_Forall_insert_2; by naive_solver.
Qed.

Fixpoint subst_map (vs : gmap string val) (e : expr) : expr :=
  match e with
  | Val _ => e
  | Var y => if vs !! y is Some v then Val v else Var y
  | Rec f y e => Rec f y (subst_map (binder_delete y (binder_delete f vs)) e)
  | App e1 e2 => App (subst_map vs e1) (subst_map vs e2)
  | UnOp op e => UnOp op (subst_map vs e)
  | BinOp op e1 e2 => BinOp op (subst_map vs e1) (subst_map vs e2)
  | If e0 e1 e2 => If (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Pair e1 e2 => Pair (subst_map vs e1) (subst_map vs e2)
  | Fst e => Fst (subst_map vs e)
  | Snd e => Snd (subst_map vs e)
  | InjL e => InjL (subst_map vs e)
  | InjR e => InjR (subst_map vs e)
  | Case e0 e1 e2 => Case (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Fork e => Fork (subst_map vs e)
  | AllocN e1 e2 => AllocN (subst_map vs e1) (subst_map vs e2)
  | Free e => Free (subst_map vs e)
  | Load e => Load (subst_map vs e)
  | Store e1 e2 => Store (subst_map vs e1) (subst_map vs e2)
  | CmpXchg e0 e1 e2 => CmpXchg (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | FAA e1 e2 => FAA (subst_map vs e1) (subst_map vs e2)
  | NewProph => NewProph
  | Resolve e0 e1 e2 => Resolve (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  end.

Lemma subst_map_empty e : subst_map ∅ e = e.
Proof.
  assert (∀ x, binder_delete x (∅:gmap _ val) = ∅) as Hdel.
  { intros [|x]; by rewrite /= ?delete_empty. }
  induction e; simplify_map_eq; rewrite ?Hdel; auto with f_equal.
Qed.
Lemma subst_map_insert x v vs e :
  subst_map (<[x:=v]>vs) e = subst x v (subst_map (delete x vs) e).
Proof.
  revert vs. induction e=> vs; simplify_map_eq; auto with f_equal.
  - match goal with
    | |- context [ <[?x:=_]> _ !! ?y ] =>
       destruct (decide (x = y)); simplify_map_eq=> //
    end. by case (vs !! _); simplify_option_eq.
  - destruct (decide _) as [[??]|[<-%dec_stable|[<-%dec_stable ?]]%not_and_l_alt].
    + rewrite !binder_delete_insert // !binder_delete_delete; eauto with f_equal.
    + by rewrite /= delete_insert_delete delete_idemp.
    + by rewrite /= binder_delete_insert // delete_insert_delete
        !binder_delete_delete delete_idemp.
Qed.
Lemma subst_map_singleton x v e :
  subst_map {[x:=v]} e = subst x v e.
Proof. by rewrite subst_map_insert delete_empty subst_map_empty. Qed.

Lemma subst_map_binder_insert b v vs e :
  subst_map (binder_insert b v vs) e =
  subst' b v (subst_map (binder_delete b vs) e).
Proof. destruct b; rewrite ?subst_map_insert //. Qed.
Lemma subst_map_binder_insert_empty b v e :
  subst_map (binder_insert b v ∅) e = subst' b v e.
Proof. by rewrite subst_map_binder_insert binder_delete_empty subst_map_empty. Qed.

Lemma subst_map_binder_insert_2 b1 v1 b2 v2 vs e :
  subst_map (binder_insert b1 v1 (binder_insert b2 v2 vs)) e =
  subst' b2 v2 (subst' b1 v1 (subst_map (binder_delete b2 (binder_delete b1 vs)) e)).
Proof.
  destruct b1 as [|s1], b2 as [|s2]=> /=; auto using subst_map_insert.
  rewrite subst_map_insert. destruct (decide (s1 = s2)) as [->|].
  - by rewrite delete_idemp subst_subst delete_insert_delete.
  - by rewrite delete_insert_ne // subst_map_insert subst_subst_ne.
Qed.
Lemma subst_map_binder_insert_2_empty b1 v1 b2 v2 e :
  subst_map (binder_insert b1 v1 (binder_insert b2 v2 ∅)) e =
  subst' b2 v2 (subst' b1 v1 e).
Proof.
  by rewrite subst_map_binder_insert_2 !binder_delete_empty subst_map_empty.
Qed.

(* subst_map on closed expressions *)
Lemma subst_map_is_closed X e vs :
  is_closed_expr X e →
  (∀ x, x ∈ X → vs !! x = None) →
  subst_map vs e = e.
Proof.
  revert X vs. assert (∀ x x1 x2 X (vs : gmap string val),
    (∀ x, x ∈ X → vs !! x = None) →
    x ∈ x2 :b: x1 :b: X →
    binder_delete x1 (binder_delete x2 vs) !! x = None).
  { intros x x1 x2 X vs ??. rewrite !lookup_binder_delete_None. set_solver. }
  induction e=> X vs /= ? HX; repeat case_match; naive_solver eauto with f_equal.
Qed.

Lemma subst_map_is_closed_nil e vs : is_closed_expr [] e → subst_map vs e = e.
Proof. intros. apply subst_map_is_closed with []; set_solver. Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches Compilers.Compilers Elab.ElabCompilers.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVSTLC SimpleEvalCtx SimpleVCPS.
Import Core.Notations.

Require Coq.derive.Derive.

Notation compiler := (compiler string).

(*TODO: repackage this in compilers*)
Import CompilerDefs.Notations.

Definition Ectx_cps_def : compiler :=
  match # from eval_ctx with
  | {{s #"Ectx" "G" "A" "B" }} =>
    {{s #"blk" (#"ext" (#"ext" "G" (#"neg" "B")) "A") }}
  | {{e #"[ ]" "G" "A"}} =>
    {{e #"jmp" {ovar 1} {ovar 0} }}
  | {{e #"plug" "G" "A" "B" "E" "e"}} =>
    bind_k 1 (var "e") (var "A") (var "E")
  end.

Derive Ectx_cps
       SuchThat (elab_preserving_compiler cps_subst
                                          (cps_lang
                                             ++ block_subst
                                             ++ value_subst)
                                          Ectx_cps_def
                                          Ectx_cps
                                          eval_ctx)
       As Ectx_cps_preserving.
Proof. auto_elab_compiler. Qed.
#[export] Hint Resolve cps_subst_preserving : elab_pfs.


Require Import HoTT.
Require Import UnivalenceAxiom.
Load sigma_lemmas.
Load trunc_lemmas.

(* Load stuff. *)

Require Import Functor Category.
(*These notations are defined elsewhere, but I do not know how to import it.*)
Local Notation "x --> y" := (morphism _ x y) (at level 99, right associativity, y at level 200) : type_scope.
Notation "F '_0' x" := (Functor.Core.object_of F x) (at level 10, no associativity, only parsing) : object_scope.
Notation "F '_1' m" := (Functor.Core.morphism_of F m) (at level 10, no associativity) : morphism_scope.
Open Scope category_scope.
Open Scope morphism_scope.

(* Definition diagonal_functor {C : PreCategory} : Functor C (C*C). *)
(* Proof.   *)
(*   srapply @Build_Functor. *)
(*   (* Map on objects *) *)
(*   - exact (fun c => (c,c)). *)
(*   (* Map on morphisms *) *)
(*   - exact (fun c d f => (f, f)). *)
(*   (* Respect composition *) *)
(*   - exact (fun c d e f g => idpath). *)
(*   (* Respect identity *) *)
(*   - exact (fun c => idpath). *)
(* Defined. *)

Definition pair_1 {C D : PreCategory} {c c' : C} {d d' : D} (f : c --> c') (g : d --> d') :
  morphism (C*D) (c, d) (c', d') := (f,g).

(* Definition transport_morphism_Fl {C D : PreCategory} (F : Functor C D) {c1 c2 : C} {d : D} (p : c1 = c2) (f : F c1 --> d): *)
(*            transport (fun c : C => F c --> d) p f = f o (F _1 (idtoiso C p))^-1. (* (idtoiso D (ap F p))^-1. *) *)
(* Proof. *)
(*   induction p. simpl. *)
(*   apply inverse. *)
(*   refine (_ @ right_identity D _ _ f). *)
(*   apply (ap (fun g => f o g)). *)
(*   apply identity_of. *)
(* Defined. *)

(* (* Another version that doesn't use the inverse. *)
(*    Definitionally the inverse isn't given uniquely, and that gives some problems later. . . *)
(*  *) *)
(* Definition transport_morphism_Fl' {C D : PreCategory} (F : Functor C D) *)
(*            {c1 c2 : C} {d : D} (p : c1 = c2) (f : F c1 --> d): *)
(*   f = transport (fun c : C => F c --> d) p f o (F _1 (idtoiso C p)). *)
(* Proof. *)
(*   induction p. simpl. *)
(*   apply inverse. *)
(*   refine (_ @ right_identity D _ _ f). *)
(*   apply (ap (fun g => f o g)). *)
(*   apply identity_of. *)
(* Defined.   *)

Record Magma : Type :=
  { magma_cat :> PreCategory; binary_op : Functor (magma_cat*magma_cat) magma_cat }.
Arguments binary_op {m}.

Definition binary_op_0 {M : Magma} : ((object M) * (object M) -> object M )%type :=
  object_of binary_op.

Local Notation "a + b" := (Core.object_of binary_op (a, b)). (* Just for printing. *)
Local Notation "a + b" := (binary_op (a, b)).

(* Definition binary_op_1 {M : Magma} {s1 s2 d1 d2 : object M} : *)
(*   ((s1 --> d1) * (s2 --> d2))%type -> ((s1 + s2) --> (d1 + d2)). *)
(* Proof. *)
(*   intro m. apply (morphism_of binary_op). exact m. *)
(* Defined. *)

Local Notation "f +^ g" := (binary_op _1 (f, g)) (at level 40). (* This is just for printing *)
Local Notation "f +^ g" := (binary_op _1 (pair_1 f g)) (at level 40).

(* Sum of idmaps is the idmap *)
Definition sum_idmap {M : Magma} {m n : M} : (identity m +^ identity n) = identity (m + n) :=
  identity_of binary_op (m, n).

(* Translation from right *)
Definition translate_fr {M : Magma} (a : M) : Functor M M.
Proof.
  refine (Functor.compose (D := M*M) binary_op _).
  srapply @Build_Functor.
  (* Objects *)
  - exact (fun m => (m, a)).
  (* Morphisms *)
  - intros m n f. exact (f,identity a).
  (* Respect composition *)
  - intros l m n.
    intros f g.
    apply path_prod. exact idpath. apply inverse. apply left_identity.
  (* Respect identity *)
  - exact (fun _ => idpath).
Defined.

(* Translation from left *)
Definition translate_fl {M : Magma} (a : M) : Functor M M.
Proof.
  refine (Functor.compose (D := M*M) binary_op _).
  srapply @Build_Functor.
  (* Objects *)
  - exact (fun m => (a, m)).
  (* Morphisms *)
  - intros m n f. exact (identity a, f).
  (* Respect composition *)
  - intros l m n.
    intros f g.
    apply path_prod. apply inverse. apply left_identity. exact idpath.
  (* Respect identity *)
  - exact (fun _ => idpath).
Defined.

Section Monoidal_Category.
  (* Require cancellation law, even if that is not reflected in the name. *)
  Record Symmetric_Monoidal_Category : Type :=
    {smon_magma :> Magma ;
     (* isgroupoid_smon_magma : forall (a b : smon_magma) (f : a --> b), IsIsomorphism f; *)
     e : smon_magma ;
     assoc : forall a b c : smon_magma, (a + b) + c --> a + (b + c);
     iso_assoc : forall a b c : smon_magma, IsIsomorphism (assoc a b c);
     natural_assoc : forall (a b c a' b' c': smon_magma) (f : a-->a') (g : b --> b') (h : c --> c'),
       assoc a' b' c' o ((f +^ g) +^ h) = (f +^ (g +^ h)) o assoc a b c;
     lid : forall a : smon_magma, e + a --> a;
     iso_lid : forall a : smon_magma, IsIsomorphism (lid a);
     natural_lid : forall (a a' : smon_magma) (f : a --> a'),
       lid a' o (1 +^ f) = f o lid a;
     rid : forall a : smon_magma, a + e --> a;
     iso_rid : forall a : smon_magma, IsIsomorphism (rid a);
     natural_rid : forall (a a' : smon_magma) (f : a --> a'),
       rid a' o (f +^ 1) = f o rid a;
     symm : forall a b : smon_magma, a + b -->  b + a;
     natural_sym : forall (a b a' b' : smon_magma) (f : a --> a') (g : b --> b'),
         symm a' b' o (f +^ g) = (g +^ f) o symm a b;
     symm_inv : forall a b : smon_magma, symm a b o symm b a = 1;
     coh_tri : forall a b : smon_magma,
         (1 +^ lid b) o (assoc a e b) = (rid a +^ 1) ;
     coh_pent : forall a b c d : smon_magma,
         (assoc a b (c+d)) o (assoc (a+b) c d)  =
         (1 +^ assoc b c d) o (assoc a (b+c) d) o (assoc a b c +^ 1);
     coh_hex : forall a b c : smon_magma,
         (assoc b c a) o (symm a (b + c)) o (assoc a b c) =
         (1 +^ symm a c) o (assoc b a c) o (symm a b +^ 1)

         (* (assoc c a b) o (symm (a+b) c) o assoc a b c = *)
         (* (symm a c +^ 1) o (assoc a c b) o (1 +^ symm b c); (*I am guessing that this is correct*) *)
     (* cancellation : forall (s t a : smon_magma) (f g : s --> t), (f +^ identity a) = (g +^ identity a) -> f = g *)
    }.

  (* Coherence results that are true given the above, but whose proofs are omitted (for now) *)
  Lemma coh_lid_assoc_lid (M : Symmetric_Monoidal_Category) : forall a b : M,
      lid M (a + b) o assoc M (e M) a b = (lid M a +^ 1).
  Admitted.

  (*Want to define the category [Sigma] of finite sets and isomorphisms. *)
  Definition isset_Finite (A : Type) :
    Finite A -> IsHSet A.
  Proof.
    intros [m finA]. strip_truncations.
    apply (trunc_equiv' (Fin m) finA^-1).
  Defined.

  (*obj Sigma := {A : Type & Finite A}
    morph A B := Equiv (Fin (card A)) (Fin (card B))*)

  (*Definition Sigma_morphism (m n : nat) := Equiv (Fin m) (Fin n).*)

  Definition Sigma_precat : PreCategory.
  Proof.
    srapply (@Build_PreCategory {A : Type & Finite A}
                                (fun A B => Equiv A.1 B.1)).
                                (* (fun A B => Equiv (Fin (@fcard A.1 A.2)) (Fin (@fcard B.1 B.2)))). *)
    - (*Identity*)
      intro m.
      apply equiv_idmap.
    - (*Compose*)
      intros A B C.
      apply equiv_compose'.
    - (*Associativity*)
      intros A B C D.
      intros e f g.
      apply ecompose_ee_e.
    - (*Composing with identity from left*)
      intros D E. intro f.
      apply ecompose_1e.
    - (*Composing with identity from right*)
      intros D E. intro f.
      apply ecompose_e1.
    - intros A B. simpl.
      srapply @istrunc_equiv. apply isset_Finite. exact B.2.
  Defined.

  Instance isgroupoid_preSigma (a b : Sigma_precat) (f : a --> b) : IsIsomorphism f.
  Proof.
    srapply @Build_IsIsomorphism.
    - exact (f^-1%equiv).
    - apply ecompose_Ve.
    - apply ecompose_eV.
  Defined.

  (* This category is univalent *)
  (* Prove this by reducing to univalence in types *)
  (*First: An isomorphism is the same as an equivalence on the underlying type *)
  Definition equiv_isomorphic_Sigma (A B : Sigma_precat) : (A.1 <~> B.1) <~> Isomorphic A B.
  Proof.
    srapply @equiv_adjointify.
    - (*Inverse*)
      intro f. apply (@Build_Isomorphic _ A B f _).
    - (*Underlying map*)
      exact (@morphism_isomorphic _ A B).
    - intro g. apply path_isomorphic. exact idpath.
    - exact (fun _ => idpath).
  Defined.

  Definition idtoiso_is_path_equiv {A B : Sigma_precat} :
    @idtoiso Sigma_precat A B =
    (equiv_isomorphic_Sigma A B) oE (equiv_equiv_path A.1 B.1) oE (equiv_path_sigma_hprop A B)^-1.
  Proof.
    apply path_arrow.
    intros []. apply path_isomorphic. exact idpath.
  Defined.

  Lemma iscategory_Sigma : IsCategory Sigma_precat.
    intros A B.
    rewrite idtoiso_is_path_equiv. exact _.
  Qed.

  Definition Sigma_cat := Build_Category iscategory_Sigma.

  Definition Sigma_coprod : Functor (Sigma_cat*Sigma_cat) Sigma_cat.
  Proof.
    srapply @Build_Functor.
    - (*Map on objects is sum of types*)
      intros [A B].
      exists (A.1 + B.1)%type. apply finite_sum; exact _.2.
    - (*Map on morphisms.*)
      (*Fin respects sum*)
      intros [A B] [C D].
      unfold morphism. simpl.
      intros [f g]. apply (equiv_functor_sum' f g).
    - (*Respects composition*)
      intros [i1 i2] [j1 j2] [k1 k2].
      intros [f1 f2] [g1 g2]. simpl.
      apply path_equiv. apply path_arrow.
      intros [m | n]; exact idpath.
    - (*Respects identity*)
      intros [i j]. simpl.
      apply path_equiv. apply path_arrow. intros [m | n]; exact idpath.
  Defined.

  (* Ltac reduce_sigma_morphism := intros; apply path_equiv; apply path_arrow; repeat (intros [?m | ]); intros. *)

  Definition Sigma : Symmetric_Monoidal_Category.
  Proof.
    srapply (@Build_Symmetric_Monoidal_Category (Build_Magma Sigma_cat Sigma_coprod)
                                                ( Fin 0 ; finite_fin 0 )).
    - (*Associativity*)
      intros A B C.
      apply equiv_sum_assoc.
    - (* Associativity is natural *)
      intros A B C A' B' C' f g h. apply path_equiv. apply path_arrow.
      intros [[l | m] | n]; exact idpath.
    - (*Left identity*)
      intro a. apply sum_empty_l.
    - (*Left identity is natural*)
      intros A A' f.
      apply path_equiv. apply path_arrow. intros [[] | n]. exact idpath.
    - (*Right identity*)
      intro a. apply sum_empty_r.
    - (*Right identity is natural*)
      intros A A' f.
      apply path_equiv. apply path_arrow. intros [n | []]. exact idpath.
    - (*Symmetry*)
      intros A A'.
      apply equiv_sum_symm.
    - (*Symmetry is natural*)
      intros A A' B B' f g.
      apply path_equiv. apply path_arrow. intros [m | n]; exact idpath.
    - (*Symmetry is its own inverse*)
      intros A B.
      apply path_equiv. apply path_arrow. intros [m | n]; exact idpath.
    - (*Coherence triangle*)
      intros A B.
      apply path_equiv. apply path_arrow. intros [[m | []] | n]; exact idpath.
    - (*Coherence pentagon*)
      intros A B C D.
      apply path_equiv. apply path_arrow. repeat (intros [ | m]); intros; exact idpath.
    - (*Coherence hexagon*)
      simpl. intros A B C.
      apply path_equiv. apply path_arrow. repeat (intros [ | m]); intros; exact idpath.
    (* - (* Translations are faithful *) *)
    (*   (* This proof is not natural in A, but this is a proposition so it doesn't matter. . .*) *)
    (*   intros S T A f g H. *)
    (*   apply path_equiv. apply path_arrow. intro s. *)
    (*   set (collapseA := fun ta : T.1 + A.1%type => *)
    (*                       match ta with *)
    (*                       |Datatypes.inl t => t *)
    (*                       |Datatypes.inr _ => f s (*This is an arbitrary choice.*) *)
    (*                       end). *)
    (*   change (f s) with (collapseA ((f +^ 1) (Datatypes.inl s))). *)
    (*   rewrite H. reflexivity. *)
  Defined.

  (* Instance isgroupoid_Sigma (A B : Sigma) (f : A --> B) : IsIsomorphism f := isgroupoid_preSigma A B f.  *)

  Lemma faithful_cancellation_Sigma (S T A : Sigma) (f g : S --> T) :
    (f +^ identity A) = (g +^ identity A) -> f = g.
  Proof.
    (* This proof is not natural in A, but this is a proposition so it doesn't matter. . .*)
    intro H.
    apply path_equiv. apply path_arrow. intro s.
    set (collapseA := fun ta : T.1 + A.1%type =>
                        match ta with
                        |Datatypes.inl t => t
                        |Datatypes.inr _ => f s (*This is an arbitrary choice.*)
                        end).
    change (f s) with (collapseA ((f +^ 1) (Datatypes.inl s))).
    rewrite H. reflexivity.
  Qed.

End Monoidal_Category.

(* (* A somewhat stupid tactic that tries to rewrite all the identities *) *)
(* Ltac moncat_rewrite := *)
(*   repeat (repeat rewrite natural_assoc; *)
(*           repeat rewrite natural_lid; *)
(*           repeat rewrite natural_rid; *)
(*           repeat rewrite natural_sym; *)
(*           repeat rewrite symm_inv; *)
(*           repeat rewrite coh_tri; *)
(*           repeat rewrite coh_pent; *)
(*           repeat rewrite coh_hex; *)
(*           repeat rewrite coh_lid_assoc_lid). *)

(* Define the group completion of a symmetric monoidal category *)
Section Group_Completion.
  (* Definition Magma_prod (M N : Magma) : Magma. *)
  (* srapply @Build_Magma. *)
  (* - srapply @Build_Category. *)
  (*   + exact (M*M). *)
  (*   + (* *) *)
  (*     admit. *)
  (* - srapply @Build_Functor. *)
  (*   + intros [[a1 a2] [b1 b2]]. simpl. *)
  (*     exact (a1 + b1, a2 + b2). *)
  (*   + simpl. *)

  Notation "( a , b ) --> ( c , d ) " := (morphism (_ * _) (a, b) (c, d)).
  (* Notation " a ==> b " := (morphism (_ * _) a b) (at level 40). *)
  (* Notation "a +p b" := (Datatypes.fst a + Datatypes.fst b, Datatypes.snd a + Datatypes.snd b) (at level 40). (* Level is just arbitrary. . . *) *)

  (* Assume that M is a symmetric monoidal groupoid with cancellation. *)
  Variable M : Symmetric_Monoidal_Category.
  Variable iscategory_M : IsCategory M.
  Variable isgroupoid_M : forall (a b : M) (f : a --> b), IsIsomorphism f.
  Variable cancellation_M : forall (s t a : M) (f g : s --> t), (f +^ identity a) = (g +^ identity a) -> f = g.

  (* Definition isgroupoid (M : Symmetric_Monoidal_Category) : Type := *)
  (*   forall (a b : M) (f : a --> b), IsIsomorphism f. *)
  (* Definition monoid_cancellation (M : Symmetric_Monoidal_Category) : Type := *)
  (*   forall (s t a : M) (f g : s --> t), *)
  (*     (f +^ identity a) = (g +^ identity a) -> f = g. *)

  Instance isgroupoid_prod : forall (a b : (M*M)%category) (f : a --> b), IsIsomorphism f.
  Proof.
    intros [a1 a2] [b1 b2]. intros [f1 f2].
    srapply @Build_IsIsomorphism; simpl.
    - exact (f1^-1, f2^-1).
    - abstract (repeat rewrite left_inverse; reflexivity).
    - abstract (repeat rewrite right_inverse; reflexivity).
  Defined.

  (* The diagonal functor *)
  Definition diag {C : PreCategory} : Functor C (C*C).
  Proof.
    srapply @Build_Functor.
    (* Map on objects *)
    - exact (fun c => (c,c)).
    (* On morphisms *)
    - intros c1 c2 f. exact (f, f).
    (* Respect composition *) - reflexivity.
    (* Respect identity. *)   - reflexivity.
  Defined.

  (* The induced sum on [M*M] *)
  (*    [(a1, a2) + (b1, b2) = (a1+b1, a2 + b2)*)
  Definition sum2 : Functor ((M*M) * (M*M)) (M*M).
  Proof.
    refine (Functor.compose (pair (@binary_op M) (@binary_op M) ) _).
    (* Build a functor swapping 2nd and 3rd component *)
    (* Use associativity to get to where we can swap. *)
    refine (Functor.compose (ProductLaws.Associativity.functor M M (M*M)) _).
    refine (Functor.compose (pair (Functor.identity M) (ProductLaws.Associativity.inverse M M M)) _).
    (* Now we can swap *)
    refine (Functor.compose (pair (Functor.identity M) (pair (ProductLaws.Swap.functor M M) (Functor.identity M) )) _).
    (* Use associativity to get back again *)
    refine (Functor.compose (pair (Functor.identity M) (ProductLaws.Associativity.functor M M M)) _).
    exact (ProductLaws.Associativity.inverse M M (M*M)).
  Defined.

  (* Notation for sum2 on morphisms *)
  Notation "f +^+ g" := (sum2 _1 (pair_1 f g)) (at level 40).

  (* (* Sum of pairs *) *)
  (* Notation "a +p b" := (sum2 (a, b)) (at level 40). *)

  Definition assoc_sum2 (a b c : M*M) : sum2 (sum2 (a,  b), c) --> sum2 (a, (sum2 (b,  c))).
  Proof.
    split; apply assoc.
  Defined.

  (* (* (diag + 1) *) *)
  (* Definition act_on_prod : Functor (M*(M*M)) (M*M) := sum2 o (pair diag (Identity.identity _))%functor.   *)

  (* (* Just to remind me what [act_on_prod] does on objects *) *)
  (* Lemma what_is_act_on_prod : forall (s a1 a2 : M), act_on_prod (s, (a1, a2)) = (s + a1, s + a2). *)
  (*   reflexivity. *)
  (* Qed.  *)

  (* Definition act_on_prod (s : M) : Functor (M*M) (M*M). *)
  (* Proof. *)
  (*   refine (Functor.compose sum2 _). *)
  (*   apply Functor.prod. *)
  (*   (* The constant functor (s,s) *) *)
  (*   - srapply @Build_Functor. *)
  (*     + exact (const (s,s)). *)
  (*     + intros. exact (1,1). *)
  (*     + intros. rewrite left_identity. reflexivity. *)
  (*     + reflexivity. *)
  (*   - apply Identity.identity. *)
  (* Defined.   *)

  Definition group_completion_morph :
    (M*M)%category -> (M*M)%category -> Type.
  Proof.
    intros a b. (* [a_p a_m] [b_p b_m]. *)
    exact {s : M & sum2 (diag s, a) --> b}.   (* (s + a_p, s + a_m) --> (b_p, b_m)}. *)
  Defined.

  (* Must I start with everything reduced for the notation to be readable? *)
  Definition equiv_group_completion_morph (a b : M*M) (f g : group_completion_morph a b) :
    f = g <~> {alpha : f.1 --> g.1 & f.2 = g.2 o ((diag _1 alpha) +^+ 1)}.
  (* (act_on_prod _1 (pair_1 alpha 1))}. *)
  (* (pair_1 (alpha +^ 1) (alpha +^ 1))}. *)
  Proof.
    destruct a as [a1 a2]. destruct b as [b1 b2]. unfold group_completion_morph in f, g.
    (* destruct f as [t f]. destruct g as [s g]. simpl. *) (* simpl in f1, f2, g1, g2. *)
    set (F := Functor.prod (translate_fr a1) (translate_fr a2)).
    refine (_ oE equiv_path_sigma (fun s : M => F s --> (b1, b2)) _ _).
    transitivity {p : f.1 = g.1 & f.2 = g.2 o (F _1 (idtoiso M p))}.
    { apply equiv_functor_sigma_id. intro p.
      destruct f as [s f]. destruct g as [t g].
      simpl in p. destruct p. simpl.
      destruct f as [f1 f2]. destruct g as [g1 g2]. simpl in f1, f2, g1, g2. simpl.
      apply equiv_concat_r.
      apply path_prod; simpl; apply inverse; refine (_ @ right_identity M _ _ _);
        refine (ap (fun g => _ o g) _); apply identity_of. }
    (*   transitivity (f.2 o (F _1 (idtoiso M p ))^-1 = g.2). *)
    (*   - apply equiv_concat_l. *)
    (*     apply iso_moveR_pV. *)
    (*     apply (transport_morphism_Fl' F p f.2). *)
    (*   (* Can't find this specific equivalence implemented. . . *) *)
    (*   - srapply @equiv_adjointify. apply iso_moveL_pM. apply iso_moveR_pV. *)
    (*     intro q. apply (trunc_morphism (M*M)). *)
    (*     intro q. apply (trunc_morphism (M*M)). }  *)
    transitivity ({alpha : f.1 <~=~> g.1 & f.2 = g.2 o pair_1 (morphism_isomorphic +^ 1) (morphism_isomorphic +^ 1)}).
    { srapply @equiv_functor_sigma'.
      - exact (BuildEquiv _ _(idtoiso M (y:=g.1)) _).
      - reflexivity.
    } clear F.
    srapply @equiv_functor_sigma'.
    - srapply @equiv_adjointify.
      + intro e. exact morphism_isomorphic.
      + intro e. refine (Build_Isomorphic (isgroupoid_M _ _ e)).
      + intro e. exact idpath.
      + intro e. apply path_isomorphic. exact idpath.
    - reflexivity.
  Defined.

  Lemma path_group_completion_morph (a b : M*M) (f g : group_completion_morph a b) (alpha : f.1 --> g.1):
    f.2 = g.2 o ((diag _1 alpha) +^+ 1) -> f = g. (* (pair_1 (alpha +^ 1) (alpha +^ 1)) *)
  Proof.
    intro H.
    exact ((equiv_group_completion_morph a b f g)^-1 (alpha; H))%equiv.
  Qed.

  (* (* The following two maps may or may not be equal to the underlying maps of [equiv_group_completion_morph] *) *)
  (* Definition path_to_sigma {M : Symmetric_Monoidal_Category} (a b : M*M) *)
  (*            (f g : group_completion_morph M a b) : *)
  (*   f = g -> {alpha : f.1 --> g.1 & f.2 = g.2 o (pair_1 (alpha +^ 1) (alpha +^ 1))}. *)
  (* Proof. *)
  (*   intro p. *)
  (*   destruct p. *)
  (*   destruct a as [a1 a2]. destruct b as [b1 b2]. *)
  (*   destruct f as [s [f1 f2]]. simpl. *)
  (*   exists (identity s). *)
  (*   apply inverse. *)
  (*   refine (_ @ right_identity (M*M) _ _ (f1, f2)). *)
  (*   apply path_prod; simpl. *)
  (*   apply (ap (fun g => f1 o g)). apply sum_idmap. *)
  (*   apply (ap (fun g => f2 o g)). apply sum_idmap. *)
  (* Defined. *)

  (* Definition path_grp_compl_morph {M : Symmetric_Monoidal_Category} (a b : M*M) *)
  (*            (f g : group_completion_morph M a b) : *)
  (*   {alpha : f.1 --> g.1 & f.2 = g.2 o (pair_1 (alpha +^ 1) (alpha +^ 1))} -> f = g. *)
  (* Proof. *)
  (*   destruct f as [s  f]. destruct g as [t g]. destruct a as [a1 a2]. destruct b as [b1 b2]. simpl. *)
  (*   intros [alpha H]. *)
  (*   srapply @path_sigma; simpl. *)
  (*   - apply (isotoid M _ _). exact (Build_Isomorphic (isgroupoid_smon_magma M s t alpha )). *)
  (*   - (* refine (transport_morphism_Fl (translate_fr ) ((isotoid M s t) *) *)
  (*     (*           {| morphism_isomorphic := alpha; isisomorphism_isomorphic := isgroupoid_smon_magma M s t alpha |}) f *) *)
  (*     (*                               @ _). *) admit. Abort. *)

  Instance isset_group_completion_morph (a b : M*M) :
    IsHSet (group_completion_morph a b).
  Proof.
    intros f g. change (IsTrunc_internal (-1)) with (IsTrunc (-1)).
    apply (trunc_equiv' {alpha : f.1 --> g.1 & f.2 = g.2 o (pair_1 (alpha +^ 1) (alpha +^ 1))}).
     refine (equiv_inverse (equiv_group_completion_morph a b f g)).
    destruct a as [a1 a2]. destruct b as [b1 b2].
    destruct f as [s f]. destruct g as [t g]. (* simpl in f1, f2, g1, g2. *) simpl.
    apply trunc_sigma'.
    - intro alpha. exact _.
    - intros [e H] [e' H']. simpl in e, H, e', H'. simpl.
      apply contr_inhabited_hprop. exact _. simpl.
      srapply @cancellation_M. exact a1.
      destruct (H'^). clear H'.
      destruct g as [g g']. simpl in g, g'. simpl in H.
      pose proof (ap Datatypes.fst H) as fstH. simpl in fstH. clear H. clear g'.
      srefine ((iso_compose_V_pp (isgroupoid_M _ _ g) _)^ @ _ @ iso_compose_V_pp (isgroupoid_M _ _ g) _).
      rewrite fstH. exact idpath.
  Qed.

  Definition group_completion_id (m : M*M) : group_completion_morph m m.
  Proof.
  - exists (e M). exact (lid M (fst m), lid M (snd m)).
  Defined.

  Definition group_completion_compose (a b c : M*M)
             (f : group_completion_morph b c) (g : group_completion_morph a b):
    (* group_completion_morph b c -> group_completion_morph a b -> *)
    group_completion_morph a c.
  Proof.
    (* destruct a as [a1 a2]. destruct b as [b1 b2]. destruct c as [c1 c2]. *)
    (* intros [s f] [t [g1 g2]]. simpl in f, g1, g2. *)
    (* intros [s f] [t g]. *)
    exists (f.1 + g.1).
    refine (f.2 o _).
    change (diag (f.1 + g.1)) with (sum2 ((f.1, f.1), (g.1, g.1))).
    refine (_ o assoc_sum2 _ _ _).
    apply (morphism_of sum2). exact (1, g.2).
  Defined.

  (* Some auxiliary lemmas *)
  Lemma comp_of_addid_fl : forall (a b c s : M) (f : a --> b) (g : b --> c),
      (identity s) +^ (g o f) = (identity s +^ g) o (identity s +^ f).
  Proof.
    intros. rewrite <- composition_of. simpl. rewrite left_identity. reflexivity.
  Qed.

  Lemma comp_of_addid_fr : forall (a b c s : M) (f : a --> b) (g : b --> c),
      (g o f) +^ (identity s) = (g +^ identity s) o (f +^ identity s).
  Proof.
    intros. rewrite <- composition_of. simpl. rewrite left_identity. reflexivity.
  Qed.

  Lemma comp_of_addid_fl_2 : forall (a b c s : (M*M)%category) (f : a --> b) (g : b --> c),
      (identity s) +^+ (g o f) = (identity s +^+ g) o (identity s +^+ f).
  Proof.
    intros [a1 a2] [b1 b2] [c1 c2] [s1 s2].
    intros [f1 f2] [g1 g2]. simpl. repeat rewrite <- comp_of_addid_fl. reflexivity.
  Qed.

  Lemma associative_group_completion :
    forall (a b c d : (M*M)%category)
           (f : group_completion_morph a b) (g : group_completion_morph b c) (h : group_completion_morph c d),
      group_completion_compose a b d (group_completion_compose b c d h g) f =
      group_completion_compose a c d h (group_completion_compose a b c g f).
  Proof.
    intros a b c d.
    (* intros [r f] [s g] [t h]. *) intros f g h.
    (* intros [a1 a2] [b1 b2] [c1 c2] [d1 d2]. *)
    (* intros [r [f1 f2]] [s [g1 g2]] [t [h1 h2]]. simpl in f1, f2, g1, g2, h1, h2. *)
    srapply @path_group_completion_morph. simpl.
    - exact (assoc M h.1 g.1 f.1).
    - change (group_completion_compose a b d (group_completion_compose b c d h g) f).2 with
      ((h.2 o (1 +^+ g.2 o assoc_sum2 (h.1, h.1) (g.1, g.1) b)) o
              (1 +^+ f.2 o assoc_sum2 (h.1 + g.1, h.1 + g.1) (f.1, f.1) a)).
      change (group_completion_compose a c d h (group_completion_compose a b c g f)).2 with
      (h.2 o (1 +^+ (g.2 o (1 +^+ f.2 o assoc_sum2 (g.1, g.1) (f.1, f.1) a)) o
                   assoc_sum2 (h.1, h.1) (g.1 + f.1, g.1 + f.1) a)).
      repeat rewrite associativity.
      apply (ap (fun m => h.2 o m)).
      repeat rewrite comp_of_addid_fl_2.
      repeat rewrite associativity.
      refine (ap (fun m => (1 +^+ g.2)  o m) _).
      (* The nice way to do this is to show that M acts on M*M coherently, but we do it quick and ugly. *)
      destruct a as [a1 a2]. destruct b as [b1 b2]. destruct c as [c1 c2].
      destruct f as [r [f1 f2]]. destruct g as [s [g1 g2]]. destruct h as [t [h1 h2]].
      simpl in f1, f2, g1, g2, h1, h2.
      transitivity (pair_1 ((1 +^ (1 +^ f1)) o (assoc M t s (r + a1) o assoc M (t + s) r a1))
                           ((1 +^ (1 +^ f2)) o (assoc M t s (r + a2) o assoc M (t + s) r a2))); simpl; unfold pair_1.
      { rewrite <- sum_idmap. repeat rewrite <- associativity. repeat rewrite natural_assoc. reflexivity. }
      { unfold pair_1. repeat rewrite coh_pent. repeat rewrite <- associativity. reflexivity. }
  Qed.

  Lemma left_id_group_completion :
    forall (a b : (M * M)%category) (f : group_completion_morph a b),
      group_completion_compose a b b (group_completion_id b) f = f.
  Proof.
    intros [a1 a2] [b1 b2]. intros [s [f1 f2]].
    srapply @path_group_completion_morph.
    - simpl. apply lid.
    - simpl. repeat rewrite <- associativity.
      repeat rewrite natural_lid. repeat rewrite associativity.
      repeat rewrite coh_lid_assoc_lid.  reflexivity.
  Qed.

  Lemma right_id_group_completion :
    forall (a b : (M * M)%category) (f : group_completion_morph a b),
      group_completion_compose a a b f (group_completion_id a) = f.
  Proof.
    intros [a1 a2] [b1 b2]. intros [s [f1 f2]].
    srapply @path_group_completion_morph.
    - simpl. apply rid.
    - simpl. repeat rewrite coh_tri. reflexivity.
  Qed.

  (* The object [(a, b)] represents the difference [a-b]. *)
  Definition group_completion_cat : PreCategory :=
    Build_PreCategory (group_completion_morph) group_completion_id
                      group_completion_compose associative_group_completion
                      left_id_group_completion
                      right_id_group_completion _.

  (* The functor sending object [a] to [a-0] *)
  Definition to_group_completion : Functor M group_completion_cat.
  Proof.
    srapply @Build_Functor; repeat change Core.object with object.
    (* Map on objects *)
    - intro a. exact (a, e M).
    (* Map on arrows *)
    - intros a b f. simpl.
      exists (e M). split; simpl.
      exact (f o lid M a). apply lid.
    (* Respects composition *)
    - intros a b c f g. simpl.
      srapply @path_group_completion_morph.
      + simpl. exact (lid M (e M))^-1.
      + simpl. (* Follows from coherence, but here is a proof. *)
        apply path_prod; simpl.
        * repeat rewrite associativity.
          refine (ap (fun h => g o h) _).
          repeat rewrite <- associativity.
          rewrite natural_lid. repeat rewrite associativity.
          refine (ap (fun h => f o h) _).
          transitivity (lid M a o 1). rewrite right_identity. reflexivity.
          refine (ap (fun h => (lid M a) o h) _).
          repeat rewrite <- associativity.
          rewrite coh_lid_assoc_lid.
          rewrite <- composition_of. simpl.
          rewrite right_inverse. rewrite right_identity. rewrite identity_of. reflexivity.
        * (* rewrite natural_lid. *)
          repeat rewrite <- associativity. rewrite natural_lid. repeat rewrite associativity.
          transitivity (lid M (e M) o 1). rewrite right_identity. reflexivity.
          refine (ap (fun h => (lid M (e M) o h)) _). repeat rewrite <- associativity.
          rewrite coh_lid_assoc_lid. rewrite <- composition_of. simpl. rewrite right_inverse.
          rewrite right_identity. rewrite identity_of. reflexivity.
    (* Respects identity  *)
    - intro a. simpl. unfold group_completion_id. simpl. rewrite left_identity. reflexivity.
  Defined.

  Definition group_completion_sum : Functor (group_completion_cat * group_completion_cat) group_completion_cat.
  Proof.
    srapply @Build_Functor; change Core.object with object.
    (* Map on objects *)
    - (* [a1 - a2] and [b1 - b2] goes to [(a1 + a2) - (b1 + b2) *)
      apply sum2.
    (* Map on morphisms *)
    -
      intros [a a'] [b b']. intros [[s f] [s' f']]. simpl in a, a', b, b'.
      unfold Datatypes.fst in f. unfold Datatypes.snd in f'.
      (* intros [[s [f1 f2]] [t [g1 g2]]]. *)
      exists (s + s').
      refine (sum2 _1 (pair_1 f f') o _). change (Core.object_of sum2) with (object_of sum2).
      (* change ((sum2 o (diag, 1))%functor (s + t, sum2 (a, b))) with (sum2 (diag (s + t), sum2 (a, b))). *)
      (* change (Core.object_of sum2 ((sum2 o (diag, 1))%functor (s, a), (sum2 o (diag, 1))%functor (t, b))) with *)
      (*        (sum2 (sum2 (diag s, a), sum2 (diag t, b))). *)
      change (diag (s + s')) with (sum2 (diag s, diag s')).
      refine ((assoc_sum2 _ _ _)^-1  o _ o assoc_sum2 _ _ _).
      refine (1 +^+ _).
      refine (assoc_sum2 _ _ _ o _ o (assoc_sum2 _ _ _)^-1).
      refine (_ +^+ 1).
      (* It is more general that the product inherits symmetry, but. . . *)
      exact (pair_1 (symm M _ _) (symm M _ _)).
    (* Respect composition *)
    - (* I have half a proof on paper (ignoring associativity), but I do not want to implement it for now.*)
      admit.
      (* simpl. *)
      (* (* intros [a a'] [b b'] [c c']. *) *)
      (* intros [[a_p a_n] [a_p' a_n']] [[b_p b_n] [b_p' b_n']] [[c_p c_n] [c_p' c_n']]. *)
      (* (* intros [[s f] [s' f']]  [[t g] [t' g']]. *) *)
      (* intros [[s [f_p f_n]] [s' [f_p' f_n']]]  [[t [g_p g_n]] [t' [g_p' g_n']]]. *)
      (* simpl in f_p, f_n, f_p', f_n', g_p, g_n, g_p', g_n'. simpl. unfold group_completion_compose. simpl. *)
      (* srapply @path_group_completion_morph. *)
      (* + simpl. *)
      (*   refine ((assoc M _ _ _)^-1 o _ o assoc M _ _ _). *)
      (*   refine (1 +^ _). *)
      (*   refine (assoc M _ _ _ o _ o (assoc M _ _ _)^-1). *)
      (*   refine (_ +^ 1). *)
      (*   apply symm. *)
      (* + apply path_prod ; simpl. *)
      (*   * *)
      (*     (* Don't know why [rewrite <- (composition_of binary_op)] doesn't work directly. . . *) *)
      (*     assert (comp_of_binary_op : forall (a a' b b' c c' : M) (f : b --> c) (f' : b' --> c') (g : a --> b) (g' : a' --> b'), *)
      (*                (f o g) +^ (f' o g') = (f +^ f') o (g +^ g')). *)
      (*     { intros. rewrite <- (composition_of binary_op). simpl. reflexivity. } *)
      (*     rewrite comp_of_binary_op. repeat rewrite associativity. *)
      (*     refine (ap (fun f => (g_p +^ g_p') o f) _). *)
      (*     rewrite comp_of_binary_op.  *)
      (*     repeat rewrite comp_of_addid_fl. repeat rewrite comp_of_addid_fr. repeat rewrite associativity. *)
      (*     repeat rewrite <- comp_of_addid_fl. admit. *)
      (*     * admit. *)
    (* Respect identity *)
    - simpl. intros [[a a'] [b b']]. simpl.
      srapply @path_group_completion_morph.
      + simpl. apply lid.
      + simpl. repeat rewrite associativity. admit. (* Coherence *)
  Admitted.

  (* TODO: Make a section with assumptions that follow from coherence, at use it liberally. *)

  Definition group_completion_moncat : Symmetric_Monoidal_Category.
    srapply (@Build_Symmetric_Monoidal_Category (Build_Magma group_completion_cat group_completion_sum)
            (e M, e M)).

End Group_Completion.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import Definitions Binding.

(** * Record Types *)

(** A record declaration is either a type declaration with equal bounds,
    or a field declaration.*)
Inductive record_dec : dec -> Prop :=
| rd_typ : forall A T, record_dec (dec_typ A T T)
| rd_trm : forall a T, record_dec (dec_trm a T).

(** Given a record declaration, a [record_typ] keeps track of the declaration's
    field member labels (i.e. names of fields) and type member labels
    (i.e. names of abstract type members). [record_typ] also requires that the
    labels are distinct.  *)
Inductive record_typ : typ -> fset label -> Prop :=
| rt_one : forall D l,
  record_dec D ->
  l = label_of_dec D ->
  record_typ (typ_rcd D) \{l}
| rt_cons: forall T ls D l,
  record_typ T ls ->
  record_dec D ->
  l = label_of_dec D ->
  l \notin ls ->
  record_typ (typ_and T (typ_rcd D)) (union ls \{l}).

(** A [record_type] is a [record_typ] with an unspecified set of labels. The meaning
    of [record_type] is an intersection of type/field declarations with distinct labels. *)
Definition record_type T := exists ls, record_typ T ls.

(** Given a type [T = D1 /\ D2 /\ ... /\ Dn] and member declaration [D], [record_has T D] tells whether
    [D] is contained in the intersection of [Di]'s. *)
Inductive record_has: typ -> dec -> Prop :=
| rh_one : forall D,
    record_has (typ_rcd D) D
| rh_andl : forall T U D,
    record_has T D ->
    record_has (typ_and T U) D
| rh_andr : forall T U D,
    record_has U D ->
    record_has (typ_and T U) D.

Hint Constructors record_typ record_has.

(** ** Lemmas About Records and Record Types *)

(** [G ⊢ ds :: U]                          #
#
    [U] is a record type with labels [ls]  #
#
    [ds] are definitions with label [ls']  #
#
    [l \notin ls']                          #
#
    [―――――――――――――――――――――――――――――――――――]  #
#
    [l \notin ls] *)
Lemma hasnt_notin : forall G ds ls l U,
    G /- ds :: U ->
    record_typ U ls ->
    defs_hasnt ds l ->
    l \notin ls.
Proof.

  Ltac inversion_def_typ :=
    match goal with
    | [ H: _ /- _ : _ |- _ ] => inversions H
    end.

  introv Hds Hrec Hhasnt.
  inversions Hhasnt. gen ds. induction Hrec; intros; inversions Hds.
  - inversion_def_typ; simpl in *; case_if; apply* notin_singleton.
  - apply notin_union; split; simpl in *.
    + apply* IHHrec. case_if*.
    + inversion_def_typ; case_if; apply* notin_singleton.
Qed.

(** [labels(D) = labels(D^x)] *)
Lemma open_dec_preserves_label: forall D x i,
  label_of_dec (open_rec_dec i x D) = label_of_dec D.
Proof.
  intros. induction D; reflexivity.
Qed.

(** [record_dec D]   #
#
    [――――――――――――――] #
#
    [record_dec D^x] *)
Lemma open_record_dec: forall D x,
  record_dec D -> record_dec (open_dec x D).
Proof.
  intros. inversion H; unfold open_dec; constructor.
Qed.

(** [record_typ T]   #
#
    [――――――――――――――] #
#
    [record_typ T^x] *)
Lemma open_record_typ: forall T x ls,
  record_typ T ls -> record_typ (open_typ x T) ls.
Proof.
  introv H.
  induction H; unfold open_typ; simpl;
    [apply rt_one | apply rt_cons];
    try apply open_record_dec ; try rewrite open_dec_preserves_label;
    assumption.
Qed.

(** [record_typ T]   #
#
    [――――――――――――――] #
#
    [record_typ T^x] *)
Lemma open_record_type: forall T x,
  record_type T -> record_type (open_typ x T).
Proof.
  introv [ls H]. exists ls. apply open_record_typ.
  assumption.
Qed.

(** The type of definitions is a record type. *)
Lemma ty_defs_record_type : forall G ds T,
    G /- ds :: T ->
    record_type T.
Proof.
 intros. induction H; destruct D;
    repeat match goal with
        | [ H: record_type _ |- _ ] =>
          destruct H
        | [ Hd: _ /- _ : dec_typ _ _ _ |- _ ] =>
          inversions Hd
        | [ Hd: _ /- _ : dec_trm _ _ |- _ ] =>
          inversions Hd
    end;
    match goal with
    | [ ls: fset label,
        t: trm_label |- _ ] =>
      exists (ls \u \{ label_trm t })
    | [ ls: fset label,
        t: typ_label |- _ ] =>
      exists (ls \u \{ label_typ t })
    | [ t: trm_label |- _ ] =>
      exists \{ label_trm t }
    | [ t: typ_label |- _ ] =>
      exists \{ label_typ t }
    end;
    constructor*; try constructor; apply (hasnt_notin H); eauto.
Qed.

(** Opening does not affect the labels of a [record_typ]. *)
Lemma opening_preserves_labels : forall z T ls ls',
    record_typ T ls ->
    record_typ (open_typ z T) ls' ->
    ls = ls'.
Proof.
  introv Ht Hopen. gen ls'.
  dependent induction Ht; intros.
  - inversions Hopen. rewrite* open_dec_preserves_label.
  - inversions Hopen. rewrite* open_dec_preserves_label.
    specialize (IHHt ls0 H4). rewrite* IHHt.
Qed.

(** Opening does not affect the labels of a [record_type]. *)
Lemma record_type_open : forall z T,
    z \notin fv_typ T ->
    record_type (open_typ z T) ->
    record_type T.
Proof.
  introv Hz H. destruct H. dependent induction H.
  - exists \{ l }. destruct T; inversions x. constructor.
    + destruct d; inversions H.
      * apply (proj21 open_fresh_typ_dec_injective) in H3.
        { subst. constructor. }
        { simpl in Hz; auto. }
        { simpl in Hz; auto. }
      * constructor.
    + destruct d; inversions H.
      * apply (proj21 open_fresh_typ_dec_injective) in H3.
        { subst. constructor. }
        { simpl in Hz; auto. }
        { simpl in Hz; auto. }
      * constructor.
  - destruct T; inversions x. simpl in Hz.
    assert (Hz': z \notin fv_typ T1) by auto.
    destruct (IHrecord_typ T1 z Hz' eq_refl) as [ls' ?]. clear Hz'.
    destruct T2; inversions H5.
    destruct d; inversions H0.
    + exists (ls' \u \{ label_typ t }). apply (proj21 open_fresh_typ_dec_injective) in H6.
      * subst. constructor*.
        { constructor. }
        {
          simpl in H2. pose proof (opening_preserves_labels z H1 H).
          rewrite* H0.
        }
      * simpl in Hz; auto.
      * simpl in Hz; auto.
    + exists (ls' \u \{ label_trm t }). constructor*.
      * constructor.
      * simpl in H2. pose proof (opening_preserves_labels z H1 H).
        rewrite* H0.
Qed.

(** If [T] is a record type with labels [ls], and [T = ... /\ D /\ ...],
    then [label(D) isin ls]. *)
Lemma record_typ_has_label_in: forall T D ls,
  record_typ T ls ->
  record_has T D ->
  label_of_dec D \in ls.
Proof.
  introv Htyp Has. generalize dependent D. induction Htyp; intros.
  - inversion Has. subst. apply in_singleton_self.
  - inversion Has; subst; rewrite in_union.
    + left. apply* IHHtyp.
    + right. inversions H5. apply in_singleton_self.
Qed.

(** [T = ... /\ {A: T1..T1} /\ ...] #
#
    [T = ... /\ {A: T2..T2} /\ ...] #
#
    [―――――――――――――――――――――――――――] #
#
    [T1 = T2] *)
Lemma unique_rcd_typ: forall T A T1 T2,
  record_type T ->
  record_has T (dec_typ A T1 T1) ->
  record_has T (dec_typ A T2 T2) ->
  T1 = T2.
Proof.
  introv Htype Has1 Has2.
  generalize dependent T2. generalize dependent T1. generalize dependent A.
  destruct Htype as [ls Htyp]. induction Htyp; intros; inversion Has1; inversion Has2; subst.
  - inversion* H3.
  - inversion* H5.
  - apply record_typ_has_label_in with (D:=dec_typ A T1 T1) in Htyp.
    + inversions H9. false* H1.
    + assumption.
  - apply record_typ_has_label_in with (D:=dec_typ A T2 T2) in Htyp.
    + inversions H5. false* H1.
    + assumption.
  - inversions H5. inversions* H9.
Qed.

(** [ds = ... /\ {a = t} /\ ...]  #
#
    [ds = ... /\ {a = t'} /\ ...] #
#
    [―――――――――――――――――――――――――] #
#
    [t = t'] *)
Lemma defs_has_inv: forall ds a t t',
    defs_has ds (def_trm a t) ->
    defs_has ds (def_trm a t') ->
    t = t'.
Proof.
  intros. unfold defs_has in *.
  inversions H. inversions H0.
  rewrite H1 in H2. inversions H2.
  reflexivity.
Qed.

(** * Inert types
       A type is inert if it is either a dependent function type, or a recursive type
       whose type declarations have equal bounds (enforced through [record_type]). #
#
       For example, the following types are inert:
       - [lambda(x: S)T]
       - [mu(x: {a: T} /\ {B: U..U})]
       - [mu(x: {C: {A: T..U}..{A: T..U}})]
       And the following types are not inert:
       - [{a: T}]
       - [{B: U..U}]
       - [top]
       - [x.A]
       - [mu(x: {B: S..T})], where [S <> T]. *)
Inductive inert_typ : typ -> Prop :=
  | inert_typ_all : forall S T, inert_typ (typ_all S T)
  | inert_typ_bnd : forall T,
      record_type T ->
      inert_typ (typ_bnd T).

(** An inert context is a typing context whose range consists only of inert types. *)
Inductive inert : ctx -> Prop :=
  | inert_empty : inert empty
  | inert_all : forall G x T,
      inert G ->
      inert_typ T ->
      x # G ->
      inert (G & x ~ T).

(** In the proof, it is useful to be able to distinguish record types from
    other types. A record type is a concatenation of type declarations with equal
    bounds [{A: T..T}] and field declarations [{a: T}]. *)

Hint Constructors inert_typ inert.

Lemma inert_concat: forall G' G,
    inert G ->
    inert G' ->
    ok (G & G') ->
    inert (G & G').
Proof.
  induction G' using env_ind; introv Hg Hg' Hok.
  - rewrite* concat_empty_r.
  - rewrite concat_assoc.
    inversions Hg'; inversions Hok;
      rewrite concat_assoc in *; try solve [false* empty_push_inv].
    destruct (eq_push_inv H) as [Heq1 [Heq2 Heq3]]; subst.
    destruct (eq_push_inv H3) as [Heq1 [Heq2 Heq3]]; subst.
    apply inert_all; auto.
Qed.


Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.LemmasTypes.

Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.SpecSyntax.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.LemmasTyping.
Require Import StlcIso.LemmasEvaluation.
Require Import StlcIso.CanForm.
Require Import StlcIso.Fix.
Require Import StlcIso.Size.
Require Import StlcIso.TypeSafety.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.SpecAnnot.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.CanForm.
Require Import StlcFix.Size.
Require Import StlcFix.StlcOmega.
Require Import StlcFix.TypeSafety.
Require Import Common.Relations.

Module F.
  Include StlcFix.SpecEvaluation.
  Include StlcFix.SpecSyntax.
  Include StlcFix.SpecTyping.
  Include StlcFix.SpecAnnot.
  Include StlcFix.LemmasTyping.
  Include StlcFix.LemmasEvaluation.
  Include StlcFix.CanForm.
  Include StlcFix.Size.
  Include StlcFix.TypeSafety.
End F.

Module I.
  Include RecTypes.SpecTypes.
  Include RecTypes.InstTy.
  Include RecTypes.LemmasTypes.

  Include StlcIso.SpecEvaluation.
  Include StlcIso.SpecSyntax.
  Include StlcIso.SpecTyping.
  Include StlcIso.LemmasTyping.
  Include StlcIso.LemmasEvaluation.
  Include StlcIso.CanForm.
  Include StlcIso.Fix.
  Include StlcIso.Size.
  Include StlcIso.TypeSafety.
End I.

Definition UValFI' := fun (S : I.Ty -> F.Ty) (τ : I.Ty) =>
  let τl := match τ with
            | I.tunit => F.tunit
            | I.tbool => F.tbool
            | I.tarr τ1 τ2 as τ => F.tarr (S τ1) (S τ2)
            | I.tprod τ1 τ2 as τ => F.tprod (S τ1) (S τ2)
            | I.tsum τ1 τ2 =>
              let σ1 := S τ1 in
              let σ2 := S τ2 in
              F.tsum σ1 σ2
            | I.trec τ => S τ[beta1 (I.trec τ)]
            | I.tvar i => F.tunit
            end
  in F.tsum τl F.tunit.

Arguments UValFI'/ S τ.

Fixpoint UValFI (n : nat) (τ : I.Ty) {struct n} : F.Ty :=
  match n with
    | 0 => F.tunit
    | S n => UValFI' (UValFI n) τ
  end.

Arguments UValFI !n !τ.

Definition unkUVal (n : nat) : F.Tm :=
  match n with
  | 0 => F.unit
  | _ => F.inr F.unit
  end.

Definition unkUValA (n : nat) (τ : I.Ty) : F.TmA :=
  match n with
  | 0 => F.a_unit
  | (S n) => F.a_inr (match τ with
      | I.tunit => F.tunit
      | I.tbool => F.tbool
      | I.tarr τ1 τ2 as τ => F.tarr (UValFI n τ1) (UValFI n τ2)
      | I.tprod τ1 τ2 as τ => F.tprod (UValFI n τ1) (UValFI n τ2)
      | I.tsum τ1 τ2 =>
        let σ1 := UValFI n τ1 in
        let σ2 := UValFI n τ2 in
        F.tsum σ1 σ2
      | I.trec τ => UValFI n τ[beta1 (I.trec τ)]
      | I.tvar i => F.tunit
      end) F.tunit F.a_unit
  end.

Lemma unkUVal_unkUValA {n τ} : unkUVal n = eraseAnnot (unkUValA n τ).
Proof.
  destruct n;
  now cbn.
Qed.

Lemma unkUVal_Value (n : nat) : F.Value (unkUVal n).
Proof.
  case n; simpl; trivial.
Qed.

Lemma unkUValT {Γ n τ} : F.Typing Γ (unkUVal n) (UValFI n τ).
Proof.
  induction n;
  eauto using F.Typing.
Qed.

Lemma unkUValAT {Γ n τ} : F.AnnotTyping Γ (unkUValA n τ) (UValFI n τ).
Proof.
  induction n;
  eauto using F.AnnotTyping.
Qed.

#[export]
Hint Resolve unkUValT : uval_typing.
#[export]
Hint Resolve unkUValAT : uval_typing.

(* Definition constr_uvalfi {Γ} (n : nat) (τ : I.Ty) (t : F.Tm) {P : ClosedTy τ} {Q : F.Typing Γ t (@UValFI n τ P)} : F.Tm := *)
(*   F.inl t. *)

(* Definition inUnit_pctx (n : nat) := pinr (pinl phole). *)
(* Definition inUnit (n : nat) (t : Tm) := pctx_app t (inUnit_pctx n). *)
(* Arguments inUnit_pctx / n. *)

(* Lemma inUnit_Value {n v} : Value v → Value (inUnit n v). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Lemma inUnit_pctx_T {Γ n} : ⟪Unit_pctx n : Γ , tunit → Γ , UVal (S n) ⟫. *)
(* Proof. *)
(*   unfold inUnit_pctx. crushTyping. *)
(* Qed. *)

Lemma inUnitT {Γ n t} : ⟪ Γ ⊢ t : F.tunit ⟫ → ⟪ Γ ⊢ F.inl t : UValFI (S n) I.tunit ⟫.
Proof.
  intuition.
Qed.

(* Arguments inUnit n t : simpl never. *)

Definition inBool_pctx (n : nat) : PCtx := pinl phole.
Definition inBool (n : nat) (t : Tm): Tm := pctx_app t (inBool_pctx n).

Arguments inBool_pctx /n.

Lemma inBool_pctx_T {Γ n} : ⟪ ⊢ inBool_pctx n : Γ , tbool → Γ , UValFI (S n) I.tbool ⟫.
Proof.
  unfold inBool_pctx. unfold UValFI. crushTyping.
Qed.

Lemma inBoolT {Γ n t} : ⟪ Γ ⊢ t : tbool ⟫ → ⟪ Γ ⊢ inBool n t : UValFI (S n) I.tbool ⟫.
Proof.
  unfold inBool. eauto using inBool_pctx_T with typing.
Qed.

Lemma inBool_Value {n v} : Value v → Value (inBool n v).
Proof.
  simpl; trivial.
Qed.

Definition inProd_pctx (n : nat) : PCtx := pinl phole.
Definition inProd (n : nat) (t : Tm) : Tm := pctx_app t (inProd_pctx n).

Lemma inProd_pctx_T {Γ n τ₁ τ₂} : ⟪ ⊢ inProd_pctx n : Γ , UValFI n τ₁ × UValFI n τ₂ → Γ , UValFI (S n) (I.tprod τ₁ τ₂)⟫.
Proof.
  unfold inProd_pctx. crushTyping.
Qed.

Lemma inProd_T {Γ n t τ₁ τ₂} : ⟪ Γ ⊢ t : UValFI n τ₁ × UValFI n τ₂ ⟫ → ⟪ Γ ⊢ inProd n t : UValFI (S n) (I.tprod τ₁ τ₂) ⟫.
Proof.
  unfold inProd. eauto using inProd_pctx_T with typing.
Qed.

Lemma inProd_Value {n v} : Value v → Value (inProd n v).
Proof.
  simpl; trivial.
Qed.

(* Definition inArr_pctx (n : nat) : PCtx := pinr (pinr (pinr (pinr (pinl phole)))). *)
(* Definition inArr (n : nat) (t : Tm) : Tm := pctx_app t (inArr_pctx n). *)

(* Arguments inArr_pctx / n. *)

(* Lemma inArr_pctx_T {Γ n} : ⟪ ⊢ inArr_pctx n : Γ , UValFI n ⇒ UValFI n → Γ , UValFI (S n) ⟫. *)
(* Proof. *)
(*   unfold inArr_pctx. crushTyping. *)
(* Qed. *)

Lemma inArr_T {Γ n t τ τ'} : ⟪ Γ ⊢ t : F.tarr (UValFI n τ) (UValFI n τ') ⟫ → ⟪ Γ ⊢ F.inl t : UValFI (S n) (I.tarr τ τ') ⟫.
Proof.
  intuition.
Qed.

(* Lemma inArr_Value {n v} : Value v → Value (inArr n v). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Definition inSum_pctx (n : nat) : PCtx := pinr (pinr (pinr (pinr (pinr phole)))). *)
(* Definition inSum (n : nat) (t : Tm) : Tm := pctx_app t (inSum_pctx n). *)

(* Lemma inSum_pctx_T {Γ n} : ⟪ ⊢ inSum_pctx n : Γ , UVal n ⊎ UVal n → Γ , UVal (S n) ⟫. *)
(* Proof. *)
(*   unfold inSum_pctx. crushTyping. *)
(* Qed. *)

Lemma inSum_T {Γ n t τ τ'} : ⟪ Γ ⊢ t : F.tsum (UValFI n τ) (UValFI n τ') ⟫ → ⟪ Γ ⊢ F.inl t : UValFI (S n) (I.tsum τ τ') ⟫.
Proof.
  intuition.
Qed.

(* Lemma inSum_Value {n v} : Value v → Value (inSum n v). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* (t : F.Tm) {P : F.Typing t (UValFI n I.tunit)} : F.Tm := *)
Definition case_uvalfi_unit (n : nat) : F.Tm :=
  let τ := UValFI (S n) I.tunit in
  let t := F.caseof (F.var 0) (F.var 0) (F.Om F.tunit) in
  F.abs τ t.

Definition case_uvalfi_arr (n : nat) (τ1 τ2 : I.Ty) : F.Tm :=
  let τ := @UValFI (S n) (I.tarr τ1 τ2) in
  let τ' := F.tarr (UValFI n τ1) (UValFI n τ2) in
  let t := F.caseof (F.var 0) (F.var 0) (F.Om τ') in
  F.abs τ t.

Lemma uvalfi_expand_arr {n τ1 τ2} :
  UValFI (S n) (I.tarr τ1 τ2) = F.tsum (F.tarr (UValFI n τ1) (UValFI n τ2)) F.tunit.
Proof.
  reflexivity.
Qed.

Lemma case_uval_arr_typing {Γ n τ1 τ2} :
  let τ := I.tarr τ1 τ2 in
  let uval_dest := case_uvalfi_arr n τ1 τ2 in
  let arg_type := UValFI (S n) τ in
  let ret_type := F.tarr (UValFI n τ1) (UValFI n τ2) in
  let type := F.tarr arg_type ret_type in
  F.Typing Γ uval_dest type.
Proof.
  intros.
  unfold uval_dest.
  unfold type.
  unfold arg_type.
  unfold ret_type.
  (* unfold uval_dest, arg_type, ret_type, type, case_uvalfi_arr. *)
  (* crushTyping. *)
  constructor.
  unfold τ.
  apply (@F.WtCaseof (F.evar Γ arg_type) (F.var 0) (F.var 0) (F.Om ret_type) ret_type F.tunit ret_type).
  unfold arg_type.
  unfold ret_type.
  constructor.
  simpl.
  constructor.
  constructor.
  constructor.
  apply wtOm_tau.
Qed.

Definition case_uvalfi_tsum (n : nat) (τ1 τ2 : I.Ty) : F.Tm :=
  let τ := UValFI (S n) (I.tsum τ1 τ2) in
  let τ' := F.tsum (UValFI n τ1) (@UValFI n τ2) in
  let t := F.caseof (F.var 0) (F.var 0) (F.Om τ') in
  F.abs τ t.

Definition case_uvalfi_trec (n : nat) (τb : I.Ty) : F.Tm :=
  let τ_rec := I.trec τb in
  let τ := UValFI (S n) τ_rec in
  let τ' := UValFI n τb[beta1 τ_rec] in
  let t := F.caseof (F.var 0) (F.var 0) (F.Om τ') in
  F.abs τ t.

Definition caseV0 (case₁ : F.Tm) (case₂ : F.Tm) : F.Tm :=
  F.caseof (F.var 0) (case₁ [wkm↑]) (case₂[wkm↑]).

Lemma caseV0_T {Γ : F.Env} {τ₁ τ₂ τ : F.Ty} {case₁ case₂ : F.Tm} :
  F.Typing (F.evar Γ τ₁) case₁ τ →
  F.Typing (F.evar Γ τ₂) case₂ τ →
  F.Typing (F.evar Γ (F.tsum τ₁ τ₂)) (caseV0 case₁ case₂) τ.
Proof.
  unfold caseV0.
  F.crushTyping.
Qed.

#[export]
Hint Resolve caseV0_T : uval_typing.

Definition caseUVal_pctx (τ : F.Ty) := F.pcaseof₁ F.phole (F.var 0) (stlcOmega τ).
Definition caseUVal_pctxA (τ : F.Ty) := F.a_pcaseof₁ τ F.tunit τ F.a_phole (F.a_var 0) (stlcOmegaA τ).

Definition caseUnit_pctx := caseUVal_pctx F.tunit.
Definition caseUnit_pctxA (n : nat) := caseUVal_pctxA F.tunit.
Definition caseBool_pctx := caseUVal_pctx F.tbool.
Definition caseBool_pctxA (n : nat) := caseUVal_pctxA F.tbool.
Definition caseProd_pctx (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctx (F.tprod (UValFI n τ1) (UValFI n τ2)).
Definition caseProd_pctxA (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctxA (F.tprod (UValFI n τ1) (UValFI n τ2)).
Definition caseSum_pctx (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctx (F.tsum (UValFI n τ1) (UValFI n τ2)).
Definition caseSum_pctxA (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctxA (F.tsum (UValFI n τ1) (UValFI n τ2)).
Definition caseArr_pctx (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctx (F.tarr (UValFI n τ1) (UValFI n τ2)).
Definition caseArr_pctxA (n : nat) (τ1 τ2 : I.Ty) := caseUVal_pctxA (F.tarr (UValFI n τ1) (UValFI n τ2)).
Definition caseRec_pctx (n : nat) (τ : I.Ty) := caseUVal_pctx (UValFI n τ[beta1 (I.trec τ)]).
Definition caseRec_pctxA (n : nat) (τ : I.Ty) := caseUVal_pctxA (UValFI n τ[beta1 (I.trec τ)]).

Definition caseUVal (τ : F.Ty) (t : F.Tm) := F.pctx_app t (caseUVal_pctx τ).
Definition caseUValA (τ : F.Ty) (t : F.TmA) := F.pctxA_app t (caseUVal_pctxA τ).

(* Definition caseUValIso (n : nat) (τ : I.Ty) (t : F.Tm) := caseUVal (UValFI n τ) t. *)
(* Definition caseUValIsoA (n : nat) (τ' τ : I.Ty) (t : F.Tm) := caseUVal (UValFI n τ) t. *)

Arguments caseUVal_pctx τ : simpl never.
Arguments caseUVal τ t : simpl never.

Definition caseUnit t := F.pctx_app t caseUnit_pctx.
Definition caseUnitA n t := F.pctxA_app t (caseUnit_pctxA n).
Definition caseBool t := F.pctx_app t caseBool_pctx.
Definition caseBoolA n t := F.pctxA_app t (caseBool_pctxA n).
Definition caseSum n t τ1 τ2 := F.pctx_app t (caseSum_pctx n τ1 τ2).
Definition caseSumA n t τ1 τ2 := F.pctxA_app t (caseSum_pctxA n τ1 τ2).
Definition caseProd n t τ1 τ2 := F.pctx_app t (caseProd_pctx n τ1 τ2).
Definition caseProdA n t τ1 τ2 := F.pctxA_app t (caseProd_pctxA n τ1 τ2).
Definition caseArr n t τ1 τ2 := F.pctx_app t (caseArr_pctx n τ1 τ2).
Definition caseArrA n t τ1 τ2 := F.pctxA_app t (caseArr_pctxA n τ1 τ2).
Definition caseRec n t τ := F.pctx_app t (caseRec_pctx n τ).
Definition caseRecA n t τ := F.pctxA_app t (caseRec_pctxA n τ).

Lemma caseUnit_pctx_T {Γ n} :
  ⟪ ⊢ caseUnit_pctx : Γ, UValFI (S n) I.tunit → Γ, F.tunit ⟫.
Proof.
  unfold caseUnit_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseUnit_pctxA_T {Γ n} :
  ⟪ a⊢ caseUnit_pctxA n : Γ, UValFI (S n) I.tunit → Γ, F.tunit ⟫.
Proof.
  unfold caseUnit_pctxA, caseUVal_pctxA.
  cbn.
  repeat constructor.
Qed.

Lemma caseUnit_T {Γ n t} :
  ⟪ Γ ⊢ t : UValFI (S n) I.tunit ⟫ →
  ⟪ Γ ⊢ caseUnit t : F.tunit ⟫.
Proof.
  unfold caseUnit; eauto using caseUnit_pctx_T with typing uval_typing.
Qed.

Lemma caseUnitA_T {Γ n t} :
  ⟪ Γ a⊢ t : UValFI (S n) I.tunit ⟫ →
  ⟪ Γ a⊢ caseUnitA n t : F.tunit ⟫.
Proof.
  unfold caseUnitA; eauto using caseUnit_pctxA_T with typing uval_typing.
Qed.

Lemma caseUnit_pctx_ectx : ECtx caseUnit_pctx.
Proof. simpl; trivial. Qed.

Lemma caseBool_pctx_T {Γ n} :
  ⟪ ⊢ caseBool_pctx : Γ, UValFI (S n) I.tbool → Γ, F.tbool ⟫.
Proof.
  unfold caseBool_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseBool_pctxA_T {Γ n} :
  ⟪ a⊢ caseBool_pctxA n : Γ, UValFI (S n) I.tbool → Γ, F.tbool ⟫.
Proof.
  unfold caseBool_pctxA, caseUVal_pctxA.
  cbn.
  repeat constructor.
Qed.

Lemma caseBool_T {Γ n t} :
  ⟪ Γ ⊢ t : UValFI (S n) I.tbool ⟫ →
  ⟪ Γ ⊢ caseBool t : F.tbool ⟫.
Proof.
  unfold caseBool; eauto using caseBool_pctx_T with typing uval_typing.
Qed.

Lemma caseBoolA_T {Γ n t} :
  ⟪ Γ a⊢ t : UValFI (S n) I.tbool ⟫ →
  ⟪ Γ a⊢ caseBoolA n t : F.tbool ⟫.
Proof.
  unfold caseBoolA; eauto using caseBool_pctxA_T with typing uval_typing.
Qed.

Lemma caseBool_pctx_ectx : ECtx caseBool_pctx.
Proof. simpl; trivial. Qed.

Lemma caseSum_pctx_T {Γ n τ1 τ2} :
  ⟪ ⊢ caseSum_pctx n τ1 τ2 : Γ, UValFI (S n) (I.tsum τ1 τ2) → Γ, F.tsum (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseSum_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseSum_pctxA_T {Γ n τ1 τ2} :
  ⟪ a⊢ caseSum_pctxA n τ1 τ2 : Γ, UValFI (S n) (I.tsum τ1 τ2) → Γ, F.tsum (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseSum_pctxA, caseUVal_pctxA.
  repeat constructor.
Qed.

Lemma caseSum_T {Γ n t τ1 τ2} :
  ⟪ Γ ⊢ t : UValFI (S n) (I.tsum τ1 τ2) ⟫ →
  ⟪ Γ ⊢ caseSum n t τ1 τ2 : F.tsum (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseSum; eauto using caseSum_pctx_T with typing uval_typing.
Qed.

Lemma caseSumA_T {Γ n t τ1 τ2} :
  ⟪ Γ a⊢ t : UValFI (S n) (I.tsum τ1 τ2) ⟫ →
  ⟪ Γ a⊢ caseSumA n t τ1 τ2 : F.tsum (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseSumA; eauto using caseSum_pctxA_T with typing uval_typing.
Qed.

Lemma caseSum_pctx_ectx {n τ τ'} : ECtx (caseSum_pctx n τ τ').
Proof. simpl; trivial. Qed.

Lemma eraseAnnot_caseSumA {n t τ₁ τ₂} :
  eraseAnnot (caseSumA n t τ₁ τ₂) = caseSum n (eraseAnnot t) τ₁ τ₂.
Proof.
  now cbn.
Qed.

Lemma caseProd_pctx_T {Γ n τ1 τ2} :
  ⟪ ⊢ caseProd_pctx n τ1 τ2 : Γ, UValFI (S n) (I.tprod τ1 τ2) → Γ, F.tprod (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseProd_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseProd_pctxA_T {Γ n τ1 τ2} :
  ⟪ a⊢ caseProd_pctxA n τ1 τ2 : Γ, UValFI (S n) (I.tprod τ1 τ2) → Γ, F.tprod (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseProd_pctxA, caseUVal_pctxA.
  repeat constructor.
Qed.

Lemma caseProd_T {Γ n t τ1 τ2} :
  ⟪ Γ ⊢ t : UValFI (S n) (I.tprod τ1 τ2) ⟫ →
  ⟪ Γ ⊢ caseProd n t τ1 τ2 : F.tprod (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseProd; eauto using caseProd_pctx_T with typing uval_typing.
Qed.

Lemma caseProdA_T {Γ n t τ1 τ2} :
  ⟪ Γ a⊢ t : UValFI (S n) (I.tprod τ1 τ2) ⟫ →
  ⟪ Γ a⊢ caseProdA n t τ1 τ2 : F.tprod (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseProdA; eauto using caseProd_pctxA_T with typing uval_typing.
Qed.

Lemma caseProd_pctx_ectx {n τ τ'} : ECtx (caseProd_pctx n τ τ').
Proof. simpl; trivial. Qed.

Lemma eraseAnnot_caseProdA {n t τ₁ τ₂} :
  eraseAnnot (caseProdA n t τ₁ τ₂) = caseProd n (eraseAnnot t) τ₁ τ₂.
Proof.
  now cbn.
Qed.

Lemma caseArr_pctx_T {Γ n τ1 τ2} :
  ⟪ ⊢ caseArr_pctx n τ1 τ2 : Γ, UValFI (S n) (I.tarr τ1 τ2) → Γ, F.tarr (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseArr_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseArr_pctxA_T {Γ n τ1 τ2} :
  ⟪ a⊢ caseArr_pctxA n τ1 τ2 : Γ, UValFI (S n) (I.tarr τ1 τ2) → Γ, F.tarr (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseArr_pctxA, caseUVal_pctxA.
  repeat constructor.
Qed.

Lemma caseArr_T {Γ n t τ1 τ2} :
  ⟪ Γ ⊢ t : UValFI (S n) (I.tarr τ1 τ2) ⟫ →
  ⟪ Γ ⊢ caseArr n t τ1 τ2 : F.tarr (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseArr; eauto using caseArr_pctx_T with typing uval_typing.
Qed.

Lemma caseArrA_T {Γ n t τ1 τ2} :
  ⟪ Γ a⊢ t : UValFI (S n) (I.tarr τ1 τ2) ⟫ →
  ⟪ Γ a⊢ caseArrA n t τ1 τ2 : F.tarr (UValFI n τ1) (UValFI n τ2) ⟫.
Proof.
  unfold caseArrA; eauto using caseArr_pctxA_T with typing uval_typing.
Qed.

Lemma caseArr_pctx_ectx {n τ τ'} : ECtx (caseArr_pctx n τ τ').
Proof. simpl; trivial. Qed.

Lemma eraseAnnot_caseArrA {n t τ₁ τ₂} :
  eraseAnnot (caseArrA n t τ₁ τ₂) = caseArr n (eraseAnnot t) τ₁ τ₂.
Proof.
  now cbn.
Qed.

Lemma caseRec_pctx_T {Γ n τ} :
  ⟪ ⊢ caseRec_pctx n τ : Γ, UValFI (S n) (I.trec τ) → Γ, UValFI n τ[beta1 (I.trec τ)] ⟫.
Proof.
  unfold caseRec_pctx, caseUVal_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseRec_T {Γ n t τ} :
  ⟪ Γ ⊢ t : UValFI (S n) (I.trec τ) ⟫ →
  ⟪ Γ ⊢ caseRec n t τ : UValFI n τ[beta1 (I.trec τ)] ⟫.
Proof.
  unfold caseRec; eauto using caseRec_pctx_T with typing uval_typing.
Qed.

Lemma caseRec_pctxA_T {Γ n τ} :
  ⟪ a⊢ caseRec_pctxA n τ : Γ, UValFI (S n) (I.trec τ) → Γ, UValFI n τ[beta1 (I.trec τ)] ⟫.
Proof.
  unfold caseRec_pctxA, caseUVal_pctxA.
  repeat constructor.
Qed.

Lemma caseRecA_T {Γ n t τ} :
  ⟪ Γ a⊢ t : UValFI (S n) (I.trec τ) ⟫ →
  ⟪ Γ a⊢ caseRecA n t τ : UValFI n τ[beta1 (I.trec τ)] ⟫.
Proof.
  unfold caseRecA; eauto using caseRec_pctxA_T with typing uval_typing.
Qed.

Lemma caseRec_pctx_ectx {n τ} : ECtx (caseRec_pctx n τ).
Proof. simpl; trivial. Qed.

Lemma eraseAnnot_caseRecA {n t τ} :
  eraseAnnot (caseRecA n t τ) = caseRec n (eraseAnnot t) τ.
Proof.
  now cbn.
Qed.

#[export]
Hint Resolve caseUnit_T : uval_typing.
#[export]
Hint Resolve caseSum_T : uval_typing.
#[export]
Hint Resolve caseArr_T : uval_typing.
#[export]
Hint Resolve caseRec_T : uval_typing.
#[export]
Hint Resolve caseUnitA_T : uval_typing.
#[export]
Hint Resolve caseSumA_T : uval_typing.
#[export]
Hint Resolve caseArrA_T : uval_typing.
#[export]
Hint Resolve caseRecA_T : uval_typing.

(* Lemma caseUVal_eval_bool {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inBool n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcbool [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inBool; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_pctx_T {Γ n tunk tcunit tcbool tcprod tcsum tcarr τ} : *)
(*   ⟪ Γ ⊢ tunk : τ ⟫ → *)
(*   ⟪ Γ ▻ tunit ⊢ tcunit : τ ⟫ → *)
(*   ⟪ Γ ▻ tbool ⊢ tcbool : τ ⟫ → *)
(*   (* ⟪ Γ ▻ (UVal n × UVal n) ⊢ tcprod : τ ⟫ → *) *)
(*   ⟪ Γ ▻ (UVal n ⊎ UVal n) ⊢ tcsum : τ ⟫ → *)
(*   ⟪ Γ ▻ (UVal n ⇒ UVal n) ⊢ tcarr : τ ⟫ → *)
(*   ⟪ ⊢ caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr : Γ , UVal (S n) → Γ , τ ⟫. *)
(* Proof. *)
(*   unfold caseUVal_pctx.  *)
(*   crushTyping. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseUVal_T {Γ n tscrut tunk tcunit tcbool tcprod tcsum tcarr τ} : *)
(*   ⟪ Γ ⊢ tscrut : UVal (S n) ⟫ → *)
(*   ⟪ Γ ⊢ tunk : τ ⟫ → *)
(*   ⟪ Γ ▻ tunit ⊢ tcunit : τ ⟫ → *)
(*   ⟪ Γ ▻ tbool ⊢ tcbool : τ ⟫ → *)
(*   ⟪ Γ ▻ (UVal n × UVal n) ⊢ tcprod : τ ⟫ → *)
(*   ⟪ Γ ▻ (UVal n ⊎ UVal n) ⊢ tcsum : τ ⟫ → *)
(*   ⟪ Γ ▻ (UVal n ⇒ UVal n) ⊢ tcarr : τ ⟫ → *)
(*   ⟪ Γ ⊢ caseUVal tscrut tunk tcunit tcbool tcprod tcsum tcarr : τ ⟫. *)
(* Proof. *)
(*   unfold caseUVal.  *)
(*   eauto using caseUVal_pctx_T with typing. *)
(* Qed. *)

Arguments UValFI n : simpl never.
#[export]
Hint Resolve unkUValT : uval_typing.
#[export]
Hint Resolve inUnitT : uval_typing.
#[export]
Hint Resolve inBoolT : uval_typing.
#[export]
Hint Resolve inProd_T : uval_typing.
#[export]
Hint Resolve inSum_T : uval_typing.
#[export]
Hint Resolve inArr_T : uval_typing.
(* #[export]
Hint Resolve inUnit_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve inBool_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve inProd_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve inSum_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve inArr_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve caseUVal_pctx_T : uval_typing. *)
(* #[export]
Hint Resolve caseUVal_T : uval_typing. *)

Local Ltac crush :=
  repeat (subst*;
          repeat rewrite
          (*   ?protect_wkm_beta1, ?protect_wkm2_beta1, *)
          (*   ?confine_wkm_beta1, ?confine_wkm2_beta1, *)
           ?apply_wkm_beta1_up_cancel;
          (*   ?apply_up_def_S; *)
          repeat crushDbLemmasMatchH;
          repeat crushDbSyntaxMatchH;
          repeat crushStlcSyntaxMatchH;
          repeat crushTypingMatchH2;
          repeat crushTypingMatchH;
          repeat match goal with
                     [ |- _ ∧ _ ] => split
                 end;
          trivial;
          eauto with ws typing uval_typing eval
         ).

Lemma caseV0_eval_inl {v case₁ case₂ : F.Tm}:
  F.Value v →
  F.eval (caseV0 case₁ case₂)[beta1 (F.inl v)] (case₁ [beta1 v]).
Proof.
  intros vv.
  unfold caseV0; apply F.eval₀_to_eval; crush.
  change ((F.caseof (F.var 0) case₁[wkm↑] case₂ [wkm↑])[beta1 (F.inl v)]) with
  (F.caseof (F.inl v) (case₁[wkm↑][(beta1 (F.inl v))↑]) (case₂[wkm↑][(beta1 (F.inl v))↑])).
  crush.
Qed.

Lemma caseV0_eval_inr {v case₁ case₂ : F.Tm}:
  F.Value v →
  F.eval (caseV0 case₁ case₂)[beta1 (F.inr v)] (case₂ [beta1 v]).
Proof.
  intros vv.
  unfold caseV0; apply F.eval₀_to_eval; crush.
  change ((F.caseof (F.var 0) case₁[wkm↑] case₂ [wkm↑])[beta1 (F.inr v)]) with
  (F.caseof (F.inr v) (case₁[wkm↑][(beta1 (F.inr v))↑]) (case₂[wkm↑][(beta1 (F.inr v))↑])).
  crush.
Qed.

Lemma caseV0_eval {v τ₁ τ₂ case₁ case₂}:
  F.Value v → F.Typing F.empty v (F.tsum τ₁ τ₂) →
  (exists v', v = F.inl v' ∧ F.eval (caseV0 case₁ case₂)[beta1 v] case₁[beta1 v']) ∨
  (exists v', v = F.inr v' ∧ F.eval (caseV0 case₁ case₂)[beta1 v] case₂[beta1 v']).
Proof.
  intros vv ty.
  F.stlcCanForm; [left|right]; exists x;
  crush; eauto using caseV0_eval_inl, caseV0_eval_inr.
Qed.

Local Ltac crushEvalsInCaseUVal :=
  repeat
    (match goal with
         [ |- (F.evalStar (F.caseof (F.inl _) _ _) _) ] => (eapply (evalStepStar _); [eapply F.eval₀_to_eval; crush|])
       | [ |- (F.evalStar (F.caseof (F.inr _) _ _) _) ] => (eapply (evalStepStar _); [eapply F.eval₀_to_eval; crush|])
       | [ |- (F.evalStar ((caseV0 _ _) [beta1 (F.inl _)]) _) ] => (eapply (evalStepStar _); [eapply caseV0_eval_inl; crush|])
       | [ |- (F.evalStar ((caseV0 _ _) [beta1 (F.inr _)]) _) ] => (eapply (evalStepStar _); [eapply caseV0_eval_inr; crush|])
       | [ |- (F.evalStar ?t ?t) ] => eauto with *
     end;
     try rewrite -> apply_wkm_beta1_cancel
    ).

Lemma caseUVal_eval_unk_diverges {n τ} :
  not (F.Terminating (caseUVal τ (unkUVal (S n)))).
Proof.
  unfold caseUVal, unkUVal; simpl.
  eapply F.divergence_closed_under_eval.
  apply F.eval₀_to_eval.
  apply F.eval_case_inr.
  simpl; trivial.
  apply stlcOmega_div.
Qed.

Lemma caseUnit_eval_unk_diverges {n} :
  (caseUnit (unkUVal (S n)))⇑.
Proof.
  unfold caseUnit, unkUVal; simpl.
  eapply F.divergence_closed_under_eval.
  apply F.eval₀_to_eval.
  apply F.eval_case_inr.
  simpl; trivial.
  apply stlcOmega_div.
Qed.

Lemma caseArr_eval_unk_diverges {n τ1 τ2} :
  (caseArr n (unkUVal (S n)) τ1 τ2)⇑.
Proof.
  unfold caseArr, unkUVal; simpl.
  eapply F.divergence_closed_under_eval.
  apply F.eval₀_to_eval.
  apply F.eval_case_inr.
  simpl; trivial.
  apply stlcOmega_div.
Qed.

Lemma caseSum_eval_unk_diverges {n τ1 τ2} :
  (caseSum n (unkUVal (S n)) τ1 τ2)⇑.
Proof.
  unfold caseSum, unkUVal; simpl.
  eapply F.divergence_closed_under_eval.
  apply F.eval₀_to_eval.
  apply F.eval_case_inr.
  simpl; trivial.
  apply stlcOmega_div.
Qed.

Lemma caseRec_eval_unk_diverges {n τ} :
  (caseRec n (unkUVal (S n)) τ)⇑.
Proof.
  unfold caseRec, unkUVal; simpl.
  eapply F.divergence_closed_under_eval.
  apply F.eval₀_to_eval.
  apply F.eval_case_inr.
  simpl; trivial.
  apply stlcOmega_div.
Qed.

Lemma caseUVal_eval_left {v τ}:
  Value v →
  caseUVal τ (F.inl v) -->* v.
Proof.
  intro vv.
  unfold caseUVal; simpl.
  eapply (evalStepStar _).
  apply eval₀_to_eval.
  apply eval_case_inl.
  simpl; trivial.
  eauto with eval.
Qed.

Lemma canonUValS_Unit {n v} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) I.tunit ⟫ →
  (v = F.inl F.unit) ∨ (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros.
  destruct (F.can_form_tsum H H0) as [(? & ? & ?) | (? & ? & ?)];
  [left | right];
  assert (F.Value x) by (
    subst;
    cbn in H;
    assumption);
  pose proof (F.can_form_tunit H3 H2);
  rewrite H4 in H1;
  assumption.
Qed.

Lemma canonUValS_Bool {n v} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) I.tbool ⟫ →
  (v = F.inl F.true) ∨ (v = F.inl F.false) ∨ (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros.
  destruct (F.can_form_tsum H H0) as [(? & ? & ?) | (? & ? & ?)];
  subst; cbn in H; F.stlcCanForm.
  - now left.
  - now right; left.
  - now right; right.
Qed.

Lemma canonUValS_Arr {n v τ τ'} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) (I.tarr τ τ') ⟫ →
  (exists v', F.Value v' ∧ (v = F.inl v') ∧ ⟪ F.empty ⊢ v' : F.tarr (UValFI n τ) (UValFI n τ')⟫) ∨ (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros vv ty.
  destruct (F.can_form_tsum vv ty) as [(? & ? & ?) | (? & ? & ?)];
  [left | right].

  exists x.
  split.
  subst.
  cbn in vv.
  assumption.
  split.
  assumption.
  assumption.

  assert (F.Value x) by (
                         subst;
                         cbn in vv;
                         assumption
                         ).

  pose proof (F.can_form_tunit H1 H0).
  rewrite H2 in H.
  assumption.
Qed.

Lemma canonUValS_Sum {n v τ τ'} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) (I.tsum τ τ') ⟫ →
  (exists v', F.Value v' ∧ (v = F.inl v') ∧ ⟪ F.empty ⊢ v' : F.tsum (UValFI n τ) (UValFI n τ')⟫) ∨ (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros vv ty.
  destruct (F.can_form_tsum vv ty) as [(? & ? & ?) | (? & ? & ?)];
  [left | right].

  exists x.
  split.
  subst.
  cbn in vv.
  assumption.
  split.
  assumption.
  assumption.

  assert (F.Value x) by (
                         subst;
                         cbn in vv;
                         assumption
                       ).

  pose proof (F.can_form_tunit H1 H0).
  rewrite H2 in H.
  assumption.
Qed.

Lemma canonUValS_Prod {n v τ τ'} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) (I.tprod τ τ') ⟫ →
  (exists v', F.Value v' ∧ (v = F.inl v') ∧ ⟪ F.empty ⊢ v' : F.tprod (UValFI n τ) (UValFI n τ')⟫) ∨
  (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros vv ty.
  cbn in *.
  stlcCanForm.
  - left. exists (F.pair x0 x1).
    crush.
  - now right.
Qed.

Lemma canonUValS_Rec {n v τ} :
  F.Value v →
  ⟪ F.empty ⊢ v : UValFI (S n) (I.trec τ) ⟫ →
  (exists v', F.Value v' ∧ (v = F.inl v') ∧ ⟪ F.empty ⊢ v' : UValFI n τ[beta1 (I.trec τ)] ⟫) ∨ (v = F.inr F.unit).
Proof.
  unfold UValFI.
  intros vv ty.
  destruct (F.can_form_tsum vv ty) as [(? & ? & ?) | (? & ? & ?)];
  [left | right].
  exists x.
  split.
  subst.
  cbn in vv.
  assumption.
  split.
  assumption.
  assumption.

  assert (F.Value x) by (
                         subst;
                         cbn in vv;
                         assumption
                       ).
  pose proof (F.can_form_tunit H1 H0).
  rewrite H2 in H.
  assumption.
Qed.

(* Lemma canonUVal_Arr {n v τ τ'} : *)
(*   F.Value v → *)
(*   ⟪ F.empty ⊢ v : UValFI n (I.tarr τ τ') ⟫ → *)
(*   (v = F.unit) ∨ (exists v', F.Value v' ∧ (v = F.inl v') ∧ ⟪ F.empty ⊢ v' : F.tarr (UValFI n τ) (UValFI n τ')⟫) ∨ (v = F.inr F.unit). *)
(* Proof. *)
(*   intros. *)
(*   destruct n as [? | ?]. *)
(*   left. *)
(*   unfold UValFI in H0. *)
(*   F.stlcCanForm. *)
(*   reflexivity. *)

(*   right. *)
(*   apply (canonUValS_Arr H). *)

(* NOTE: for compatibility lemmas, we might need a UVal context and accompanying lemmas *)

(* Lemma canonUValS {n v} : *)
(*   ⟪ empty ⊢ v : UVal (S n) ⟫ → Value v → *)
(*   (v = unkUVal (S n)) ∨ *)
(*   (∃ v', v = inUnit n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tunit ⟫) ∨ *)
(*   (∃ v', v = inBool n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tbool ⟫) ∨ *)
(*   (∃ v', v = inProd n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n × UVal n ⟫) ∨ *)
(*   (∃ v', v = inSum n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n ⊎ UVal n ⟫) ∨ *)
(*   (∃ v', v = inArr n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n ⇒ UVal n ⟫). *)
(* Proof. *)
(*   intros ty vv. *)
(*   unfold UVal in ty; simpl. *)
(*   (* Apply canonical form lemmas but only as far as we need. *) *)
(*   stlcCanForm1; *)
(*     [left|right;stlcCanForm1; *)
(*        [left|right;stlcCanForm1; *)
(*           [left|right;stlcCanForm1; *)
(*                 [left|right;stlcCanForm1; *)
(*                       [right|left]]]]]. *)
(*   - stlcCanForm; crush. *)
(*   - exists x0; crush. *)
(*   - exists x; crush. *)
(*   - exists x0; crush. *)
(*   - exists x; crush. *)
(*   - exists x; crush. *)
(* Qed. *)

(* Lemma canonUVal {n v} : *)
(*   ⟪ empty ⊢ v : UVal n ⟫ → Value v → *)
(*   (v = unkUVal n) ∨ *)
(*   ∃ n', n = S n' ∧  *)
(*         ((∃ v', v = inUnit n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tunit ⟫) ∨ *)
(*          (∃ v', v = inBool n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tbool ⟫) ∨ *)
(*          (∃ v', v = inProd n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' × UVal n' ⟫) ∨ *)
(*          (∃ v', v = inSum n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' ⊎ UVal n' ⟫) ∨ *)
(*          (∃ v', v = inArr n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' ⇒ UVal n' ⟫)). *)
(* Proof. *)
(*   intros ty vv. *)
(*   destruct n. *)
(*   - left. unfold UVal, unkUVal in *. stlcCanForm. trivial. *)
(*   - destruct (canonUValS ty vv) as [? | ?]. *)
(*     + left; crush. *)
(*     + right; crush.  *)
(* Qed. *)

(* Ltac canonUVal := *)
(*   match goal with *)
(*       [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal 0 ⟫ |- _ ] => *)
(*       (unfold UVal in H'; stlcCanForm; subst) *)
(*     | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal (S _) ⟫ |- _ ] => *)
(*       (destruct (canonUValS H' H) as  *)
(*           [?| [(? & ? & ? & ?) *)
(*               |[(? & ? & ? & ?) *)
(*                |[(? & ? & ? & ?) *)
(*                 |[(? & ? & ? & ?) *)
(*                  |(? & ? & ? & ?)]]]]]; subst) *)
(*     | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal (S _ + _) ⟫ |- _ ] => *)
(*       (destruct (canonUValS H' H) as  *)
(*           [?| [(? & ? & ? & ?) *)
(*               |[(? & ? & ? & ?) *)
(*                |[(? & ? & ? & ?) *)
(*                 |[(? & ? & ? & ?) *)
(*                  |(? & ? & ? & ?)]]]]]; subst) *)
(*     | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal _ ⟫ |- _ ] => *)
(*       (destruct (canonUVal H' H) as  *)
(*           [?| (? & ? & [(? & ? & ? & ?) *)
(*                        |[(? & ? & ? & ?) *)
(*                         |[(? & ? & ? & ?) *)
(*                          |[(? & ? & ? & ?) *)
(*                           |(? & ? & ? & ?)]]]])]; subst) *)
(*   end. *)

(* Lemma caseUVal_eval_unk {n : nat} {tunk tcunit tcbool tcprod tcsum tcarr : F.Tm} : *)
(*   F.evalStar (caseUVal (F.inr F.unit) tunk tcunit tcbool tcprod tcsum tcarr) tunk. *)
(* Proof. *)
(*   unfold caseUVal, unkUVal; simpl. *)
(*   (* why doesn't crush do the following? *) *)
(*   assert (Value (inl unit)) by (simpl; trivial). *)
(*   crushEvalsInCaseUVal. *)
(*   eauto with *. *)
(* Qed. *)

(* Lemma caseUVal_eval_unit {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inUnit n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcunit [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inUnit; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_eval_bool {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inBool n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcbool [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inBool; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_eval_prod {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inProd n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcprod [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inProd; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_eval_sum {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inSum n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcsum [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inSum; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_eval_arr {n tunk tcunit tcbool tcprod tcsum tcarr v} : *)
(*   Value v → *)
(*   caseUVal (inArr n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcarr [beta1 v]. *)
(* Proof. *)
(*   intros vv. *)
(*   unfold caseUVal, inArr; simpl. *)
(*   crushEvalsInCaseUVal. *)
(* Qed. *)

(* Lemma caseUVal_sub {t tunk tcunit tcbool tcprod tcsum tcarr} γ : *)
(*   (caseUVal t tunk tcunit tcbool tcprod tcsum tcarr)[γ] = *)
(*   caseUVal (t[γ]) (tunk[γ]) (tcunit[γ↑]) (tcbool[γ↑]) (tcprod[γ↑]) (tcsum[γ↑]) (tcarr[γ↑]). *)
(* Proof. *)
(*   unfold caseUVal, caseUVal_pctx, caseV0. cbn.  *)
(*   crush;  *)
(*     rewrite <- ?apply_wkm_comm, <- ?(apply_wkm_up_comm);  *)
(*     reflexivity. *)
(* Qed. *)

(* Arguments caseUVal tscrut tunk tcunit tcbool tcprod tcsum tcarr : simpl never. *)
(* Arguments caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr : simpl never. *)

(* Lemma caseUVal_pctx_ECtx {tunk tcunit tcbool tcprod tcsum tcarr} : *)
(*   ECtx (caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Definition caseUVal (n : nat) (tscrut tunk tcunit tcbool tcprod tcsum tcarr : Tm) := *)

(* Definition caseUnit_pctx := caseUVal_pctx (stlcOmega tunit) (var 0) (stlcOmega tunit) (stlcOmega tunit) (stlcOmega tunit) (stlcOmega tunit). *)
(* Definition caseBool_pctx := caseUVal_pctx (stlcOmega tbool) (stlcOmega tbool) (var 0) (stlcOmega tbool) (stlcOmega tbool) (stlcOmega tbool). *)
(* Definition caseProd_pctx n := caseUVal_pctx (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)) (var 0) (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)). *)
(* Definition caseSum_pctx n := caseUVal_pctx (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (var 0) (stlcOmega (UVal n ⊎ UVal n)). *)
(* Definition caseArr_pctx n := caseUVal_pctx (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (var 0). *)
(* Definition caseUnit t := pctx_app t caseUnit_pctx. *)
(* Definition caseBool t := pctx_app t caseBool_pctx. *)
(* Definition caseProd n t := pctx_app t (caseProd_pctx n). *)
(* Definition caseSum n t := pctx_app t (caseSum_pctx n). *)
(* Definition caseArr n t := pctx_app t (caseArr_pctx n). *)

(* Lemma caseUnit_pctx_ECtx : ECtx caseUnit_pctx. *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Lemma caseBool_pctx_ECtx : ECtx caseBool_pctx. *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Lemma caseProd_pctx_ECtx {n}: ECtx (caseProd_pctx n). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Lemma caseSum_pctx_ECtx {n}: ECtx (caseSum_pctx n). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

(* Lemma caseArr_pctx_ECtx {n}: ECtx (caseArr_pctx n). *)
(* Proof. *)
(*   simpl; trivial. *)
(* Qed. *)

Lemma caseUnit_sub {t γ} :
  (caseUnit t) [γ] = caseUnit (t [γ]).
Proof.
  unfold caseUnit; crush.
Qed.

(* Lemma caseBool_sub {t γ} : *)
(*   caseBool t [γ] = caseBool (t [γ]). *)
(* Proof. *)
(*   unfold caseBool; crush. *)
(* Qed. *)

(* Lemma caseProd_sub {n t γ} : *)
(*   caseProd n t [γ] = caseProd n (t [γ]). *)
(* Proof. *)
(*   unfold caseProd; crush. *)
(* Qed. *)

Lemma caseSum_sub {n t τ τ' γ} :
  (caseSum n t τ τ') [γ] = caseSum n (t [γ]) τ τ'.
Proof.
  unfold caseSum; crush.
Qed.

Lemma caseArr_sub {n t τ τ' γ} :
  (caseArr n t τ τ') [γ] = caseArr n (t [γ]) τ τ'.
Proof.
  unfold caseArr; crush.
Qed.

Lemma caseRec_sub {n t τ γ} :
  (caseRec n t τ) [γ] = caseRec n (t [γ]) τ.
Proof.
  unfold caseRec; crush.
Qed.

Arguments caseUnit t : simpl never.
Arguments caseSum n t τ1 τ2 : simpl never.
Arguments caseArr n t τ1 τ2 : simpl never.
Arguments caseRec n t τ : simpl never.

Arguments caseUnitA n t : simpl never.
Arguments caseSumA n t τ1 τ2 : simpl never.
Arguments caseArrA n t τ1 τ2 : simpl never.
Arguments caseRecA n t τ : simpl never.

(* Lemma caseUnit_pctx_T {Γ n} :  *)
(*   ⟪ ⊢ caseUnit_pctx : Γ , UVal (S n) → Γ , tunit ⟫. *)
(* Proof. *)
(*   unfold caseUnit_pctx. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseUnit_T {Γ n t} :  *)
(*   ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseUnit t : tunit ⟫. *)
(* Proof. *)
(*   unfold caseUnit. *)
(*   eauto using caseUnit_pctx_T with typing. *)
(* Qed. *)

(* Lemma caseBool_pctx_T {Γ n} :  *)
(*   ⟪ ⊢ caseBool_pctx : Γ , UVal (S n) → Γ , tbool ⟫. *)
(* Proof. *)
(*   unfold caseBool_pctx. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseBool_T {Γ n t} :  *)
(*   ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseBool t : tbool ⟫. *)
(* Proof. *)
(*   unfold caseBool. *)
(*   eauto using caseBool_pctx_T with typing. *)
(* Qed. *)

(* Lemma caseProd_pctx_T {Γ n} :  *)
(*   ⟪ ⊢ caseProd_pctx n : Γ , UVal (S n) → Γ , UVal n × UVal n ⟫. *)
(* Proof. *)
(*   unfold caseProd_pctx. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseProd_T {Γ n t} :  *)
(*   ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseProd n t : UVal n × UVal n ⟫. *)
(* Proof. *)
(*   unfold caseProd. *)
(*   eauto using caseProd_pctx_T with typing. *)
(* Qed. *)

(* Lemma caseSum_pctx_T {Γ n} :  *)
(*   ⟪ ⊢ caseSum_pctx n : Γ , UVal (S n) → Γ , UVal n ⊎ UVal n ⟫. *)
(* Proof. *)
(*   unfold caseSum_pctx. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseSum_T {Γ n t} :  *)
(*   ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseSum n t : UVal n ⊎ UVal n ⟫. *)
(* Proof. *)
(*   unfold caseSum. *)
(*   eauto using caseSum_pctx_T with typing. *)
(* Qed. *)

(* Lemma caseArr_pctx_T {Γ n} :  *)
(*   ⟪ ⊢ caseArr_pctx n : Γ , UVal (S n) → Γ , UVal n ⇒ UVal n ⟫. *)
(* Proof. *)
(*   unfold caseArr_pctx. *)
(*   eauto with typing uval_typing. *)
(* Qed. *)

(* Lemma caseArr_T {Γ n t} :  *)
(*   ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseArr n t : UVal n ⇒ UVal n ⟫. *)
(* Proof. *)
(*   unfold caseArr. *)
(*   eauto using caseArr_pctx_T with typing. *)
(* Qed. *)


(** This file provides a construction to lift a PROP-level binary relation to
its reflexive transitive closure. *)
From iris.bi.lib Require Export fixpoint.
From iris.proofmode Require Import tactics.
From iris Require Import options.

(* The sections add extra BI assumptions, which is only picked up with "Type"*. *)
Set Default Proof Using "Type*".

Definition bi_rtc_pre `{!BiInternalEq PROP}
    {A : ofeT} (R : A → A → PROP)
    (x2 : A) (rec : A → PROP) (x1 : A) : PROP :=
  (<affine> (x1 ≡ x2) ∨ ∃ x', R x1 x' ∗ rec x')%I.

Instance bi_rtc_pre_mono `{!BiInternalEq PROP}
    {A : ofeT} (R : A → A → PROP) `{NonExpansive2 R} (x : A) :
  BiMonoPred (bi_rtc_pre R x).
Proof.
  constructor; [|solve_proper].
  iIntros (rec1 rec2) "#H". iIntros (x1) "[Hrec | Hrec]".
  { by iLeft. }
  iRight.
  iDestruct "Hrec" as (x') "[HP Hrec]".
  iDestruct ("H" with "Hrec") as "Hrec". eauto with iFrame.
Qed.

Definition bi_rtc `{!BiInternalEq PROP}
    {A : ofeT} (R : A → A → PROP) (x1 x2 : A) : PROP :=
  bi_least_fixpoint (bi_rtc_pre R x2) x1.

Instance: Params (@bi_rtc) 3 := {}.
Typeclasses Opaque bi_rtc.

Instance bi_rtc_ne `{!BiInternalEq PROP} {A : ofeT} (R : A → A → PROP) :
  NonExpansive2 (bi_rtc R).
Proof.
  intros n x1 x2 Hx y1 y2 Hy. rewrite /bi_rtc Hx. f_equiv=> rec z.
  solve_proper.
Qed.

Instance bi_rtc_proper `{!BiInternalEq PROP} {A : ofeT} (R : A → A → PROP)
  : Proper ((≡) ==> (≡) ==> (⊣⊢)) (bi_rtc R).
Proof. apply ne_proper_2. apply _. Qed.

Section bi_rtc.
  Context `{!BiInternalEq PROP}.
  Context {A : ofeT}.
  Context (R : A → A → PROP) `{NonExpansive2 R}.

  Lemma bi_rtc_unfold (x1 x2 : A) :
    bi_rtc R x1 x2 ≡ bi_rtc_pre R x2 (λ x1, bi_rtc R x1 x2) x1.
  Proof. by rewrite /bi_rtc; rewrite -least_fixpoint_unfold. Qed.

  Lemma bi_rtc_strong_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ (Φ x' ∧ bi_rtc R x' x2)) -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
 Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_strong_ind (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_ind_l x2 Φ :
    NonExpansive Φ →
    □ (∀ x1, <affine> (x1 ≡ x2) ∨ (∃ x', R x1 x' ∗ Φ x') -∗ Φ x1) -∗
    ∀ x1, bi_rtc R x1 x2 -∗ Φ x1.
  Proof.
    iIntros (?) "#IH". rewrite /bi_rtc.
    by iApply (least_fixpoint_ind (bi_rtc_pre R x2) with "IH").
  Qed.

  Lemma bi_rtc_refl x : ⊢ bi_rtc R x x.
  Proof. rewrite bi_rtc_unfold. by iLeft. Qed.

  Lemma bi_rtc_l x1 x2 x3 : R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iIntros "H1 H2".
    iEval (rewrite bi_rtc_unfold /bi_rtc_pre). iRight.
    iExists x2. iFrame.
  Qed.

  Lemma bi_rtc_once x1 x2 : R x1 x2 -∗ bi_rtc R x1 x2.
  Proof. iIntros "H". iApply (bi_rtc_l with "H"). iApply bi_rtc_refl. Qed.

  Lemma bi_rtc_trans x1 x2 x3 : bi_rtc R x1 x2 -∗ bi_rtc R x2 x3 -∗ bi_rtc R x1 x3.
  Proof.
    iRevert (x1).
    iApply bi_rtc_ind_l.
    { solve_proper. }
    iIntros "!>" (x1) "[H | H] H2".
    { by iRewrite "H". }
    iDestruct "H" as (x') "[H IH]".
    iApply (bi_rtc_l with "H").
    by iApply "IH".
  Qed.

End bi_rtc.