(********************************************************************************
* Formalization of lambda ex_lab         				        *
*									        *
* Flavio L. C. de Moura & Daniel L. Ventura, & Washington R. Segundo, 2014	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Equation_C Lambda Lambda_Ex LambdaESLab_Defs.
Require Import Basic_Prop_lex.

(* [=] equivalence *)
(*
Lemma Equal_eq : Equivalence VarSet.Equal.
Proof.
 split; intros_all.
 split; intros; trivial.
 split; intros; apply H; trivial.
 split; intros. apply H0. apply H; trivial.
 apply H. apply H0. trivial.
Qed.

Lemma rw_in : forall x, Proper (VarSet.Equal ==> iff) (VarSet.In x).
Proof.
 intros_all; apply H.
Qed.

Lemma rw_union : Proper (VarSet.Equal ++> VarSet.Equal ++> VarSet.Equal) VarSet.union.
Proof.
 intros_all; split; intros.
 apply in_union in H1; apply in_union. destruct H1.
 left. apply H; trivial. right; apply H0; trivial.
 apply in_union in H1; apply in_union. destruct H1.
 left. apply H; trivial. right; apply H0; trivial.
Qed.

Lemma rw_subset : Proper (VarSet.Equal ==> VarSet.Equal ==> iff) VarSet.Subset.
Proof.
 intros_all. split; unfold VarSet.Subset; intros.
 apply H0. apply H1. apply H; trivial.
 apply H0. apply H1. apply H; trivial.
Qed.
*)

(** Properties of labelled terms. *)

(*
Lemma lab_term_subset : forall (S S' : VarSet.t) (t : pterm),
                        S << S' -> lab_term S t -> lab_term S' t.
Proof.
 intros S S' t H0 H1. generalize S' H0; clear S' H0.
 induction H1; intros. apply lab_term_var.
 intros. apply lab_term_app;
 [apply IHlab_term1; trivial | apply IHlab_term2; trivial].
 apply lab_term_abs with (L := L); intros. apply H0; trivial.
 intros y Hy. apply in_union in Hy. apply in_union.
 destruct Hy. left; apply H1; trivial. right; trivial.
 apply lab_term_sub with (L := L);
 intros; [apply H0; trivial | apply IHlab_term]; trivial.
 intros y Hy. apply in_union in Hy. apply in_union.
 destruct Hy. left; apply H2; trivial. right; trivial.
 apply lab_term_sub' with (L := L); trivial. intros.
 apply H0; trivial. intros y Hy. apply in_union in Hy. apply in_union.
 destruct Hy. left; apply H4; trivial. right; trivial.
 apply subset_trans with (F := S); trivial.
Qed.

Lemma lab_body_subset : forall (S S' : VarSet.t) (t : pterm),
                        S << S' -> lab_body S t -> lab_body S' t.
Proof.
 intros S S' t H0 H1. unfold lab_body in *|-*. case H1; clear H1; intros L H1.
 exists L. intros y Hy. apply lab_term_subset with (S := S \u {{y}}).
 apply subset_union_trans_l with (F := S); trivial. apply H1; trivial.
Qed.
 *)

(*
Lemma term_to_lab_term : forall S t, term t -> lab_term S t.
Proof.
 intros. induction H.
 apply lab_term_var.
 apply lab_term_app; trivial.
 apply lab_term_abs with (L := L); intros.
 apply lab_term_subset with (S := S).
 apply subset_union_weak_l. apply H0; trivial.
 apply lab_term_sub with (L := L); trivial; intros.
 apply lab_term_subset with (S := S).
 apply subset_union_weak_l. apply H0; trivial.
Qed.
 *)

(** Every term is also a labelled term because the grammar with labels
extends the term grammar. *)

Lemma term_is_lab_term: forall t, term t -> lab_term t.
Proof.
  intros t Ht.
  apply term_size_induction.
  intro x. apply lab_term_var.
  intros t1 Hbody Hind.
  apply lab_term_abs with (L := fv t1).
  intros x Hfv.
  apply Hind. assumption. trivial.
  apply body_to_term; assumption.
  intros t1 t2 Ht1 Hlab1 Ht2 Hlab2.
  apply lab_term_app; assumption.
  intros t1 t3 Ht3 Hlab3 Hb1 Hind.
  apply lab_term_sub with (L := fv t1).
  intros x Hfvt1.
  apply Hind. assumption. trivial.
  apply body_to_term; assumption. assumption. assumption.
Qed.

Lemma lab_body_to_body : forall t, body t -> lab_body t.
Proof.
 intros. case H; clear H; intros L H; exists L.
 intros. apply term_is_lab_term. apply H; trivial.
Qed.

Lemma open_lab_term : forall t x k, lab_term t -> ({k ~> pterm_fvar x}t) = t.
Proof.
 intros t x k H. generalize k; clear k.
 induction H; intros; simpl; trivial.
 rewrite IHlab_term1; rewrite IHlab_term2; trivial.
 case var_fresh with (L := L \u (fv t1) \u fv ({Datatypes.S k ~> pterm_fvar x}t1)). intros z Hz.
 apply notin_union in Hz. destruct Hz. apply notin_union in H1. destruct H1.
 assert (Q : {Datatypes.S k ~> pterm_fvar x}t1 ^ z = t1 ^ z). apply H0; trivial.
 unfold open in Q. rewrite subst_com in Q; try omega; trivial.
 apply open_var_inj in Q; trivial. rewrite Q; trivial.
 rewrite IHlab_term.
 case var_fresh with (L := L \u (fv t1) \u fv ({Datatypes.S k ~> pterm_fvar x}t1)). intros z Hz.
 apply notin_union in Hz. destruct Hz. apply notin_union in H2. destruct H2.
 assert (Q : {Datatypes.S k ~> pterm_fvar x}t1 ^ z = t1 ^ z). apply H0; trivial.
 unfold open in Q. rewrite subst_com in Q; try omega; trivial.
 apply open_var_inj in Q; trivial. rewrite Q; trivial.
 rewrite <- open_rec_term with (t := t2); trivial.
 case var_fresh with (L := L \u (fv t1) \u fv ({Datatypes.S k ~> pterm_fvar x}t1)). intros z Hz.
 apply notin_union in Hz. destruct Hz. apply notin_union in H3. destruct H3.
 assert (Q : {Datatypes.S k ~> pterm_fvar x}t1 ^ z = t1 ^ z).
 apply H0; trivial.
 unfold open in Q. rewrite subst_com in Q; try omega; trivial.
 apply open_var_inj in Q; trivial.
 rewrite Q; trivial.
Qed.

(** Parei aqui (Flávio) *)

(* Lemma swap_lab_term : forall x y S t, x \in S -> y \in S -> *)
(*                       lab_term S t -> lab_term S ([(x,y)]t). *)
(* Proof. *)
(*  intros x y S t Hx Hy H. induction H; simpl. *)
(*  case (x0 == x); case (x0 == y); intros; apply lab_term_var. *)
(*  apply lab_term_app; [apply IHlab_term1; trivial | apply IHlab_term2; trivial]. *)
(*  apply lab_term_abs with (L := L \u {{x}} \u {{y}}). intros z Hz.  *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H1. destruct H1. *)
(*  apply notin_singleton in H2. apply notin_singleton in H3.  *)
(*  rewrite open_swap; trivial. apply H0; trivial; apply in_union; left; trivial. *)
(*  apply lab_term_sub with (L := L \u {{x}} \u {{y}});  *)
(*  try apply  IHlab_term; trivial; intros z Hz.  *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H2. destruct H2. *)
(*  apply notin_singleton in H3. apply notin_singleton in H4.  *)
(*  rewrite open_swap; trivial. apply H0; trivial; apply in_union; left; trivial. *)
(*  apply lab_term_sub' with (L := L \u {{x}} \u {{y}}); trivial. intros z Hz.  *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H4. destruct H4. *)
(*  apply notin_singleton in H5. apply notin_singleton in H6.  *)
(*  rewrite open_swap; trivial. apply H0; trivial; apply in_union; left; trivial. *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. *)
(*  apply swap_fvar; trivial. *)
(* Qed. *)

(* Lemma swap_lab_term' : forall x y S t, x \in S -> y \in S -> *)
(*                                        x \notin fv t -> y \notin fv t -> *)
(*                                        lab_term S (t ^ x) -> lab_term S (t ^ y). *)
(* Proof. *)
(*  intros. replace (t^y) with ([(x,y)](t^x)). apply swap_lab_term; trivial. *)
(*  unfold open. rewrite open_swap_comm. rewrite swap_var_l. *)
(*  rewrite swap_fresh; trivial. *)
(* Qed. *)

(* Lemma swap_lab_body : forall x y S t, x \in S -> y \in S -> *)
(*                       lab_body S t -> lab_body S ([(x,y)]t). *)
(* Proof. *)
(*  intros. unfold lab_body in *|-*. case H1; clear H1; intros L H1. *)
(*  exists (L \u {{x}} \u {{y}}). intros z Hz. *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H2. destruct H2. *)
(*  apply notin_singleton in H3. apply notin_singleton in H4. rewrite open_swap; trivial. *)
(*  apply swap_lab_term. apply in_union. left; trivial. apply in_union. left; trivial. *)
(*  apply H1; trivial. *)
(* Qed. *)

(* Lemma bswap_rec_open : forall x k t, bswap_rec (S k) (t ^ x) = (bswap_rec (S k) t) ^ x.  *)
(* Proof. *)
(*  intros. *)
(*  case var_fresh with (L := fv t \u {{x}}). intros y Fry. *)
(*  case var_fresh with (L := fv t \u {{x}} \u {{y}}). intros z Frz. *)
(*  apply notin_union in Fry. destruct Fry. apply notin_singleton in H0. *)
(*  apply notin_union in Frz. destruct Frz. apply notin_union in H1.  *)
(*  destruct H1. apply notin_singleton in H2. apply notin_singleton in H3. *)
(*  rewrite <- bswap_eq_openclose with (x := y) (y := z). unfold open.  *)
(*  rewrite subst_com with (i := S k) (j := 0); try omega; trivial. *)
(*  rewrite subst_com with (i := S (S k)) (j := 0) ; try omega; trivial.  *)
(*  rewrite <- openclose_com; try omega; trivial. *)
(*  rewrite <- openclose_com; try omega; trivial. *)
(*  rewrite bswap_eq_openclose with (x := y) (y := z); trivial. *)
(*  apply notin_union. split; trivial. apply notin_singleton; trivial.  *)
(*  intro; apply H0; rewrite H4; trivial. intro; apply H3; rewrite H4; trivial. *)
(*  unfold open. rewrite fv_open_; trivial. apply notin_union. *)
(*  split. unfold open. rewrite fv_open_; trivial. apply notin_singleton; trivial. *)
(* Qed. *)

(* (** Open a labeled locally closed term is the identity *) *)
(* Lemma open_rec_lab_term : forall S t u,  lab_term S t -> forall k, t = {k ~> u}t. *)
(* Proof. *)
(*   induction 1; intros; simpl; fequals*; unfolds open ; *)
(*   case var_fresh with (L := L); intros x Fr;  *)
(*   try apply* (@open_rec_term_core t1 0 (pterm_fvar x)); try omega; *)
(*   try apply H0; trivial. apply open_rec_term; trivial. *)
(* Qed.   *)

(* Lemma red_regular_lab_x : forall t t', lab_sys_x t t' -> (exists S, lab_term S t /\ lab_term S t').    *)
(* Proof. *)
(*  intros t t' H. induction H; exists S. *)
(*  inversion H. split; trivial. apply term_to_lab_term; trivial.  *)
(*  split; trivial. *)
(*  split. inversion H0. inversion H. apply lab_term_sub' with (L := L \u x); trivial.  *)
(*  intros z Fr; apply notin_union in Fr;  destruct Fr. *)
(*  unfold open. simpl. apply lab_term_app. apply H7; trivial. apply H3; trivial. *)
(*  inversion H0. inversion H. apply lab_term_app. *)
(*  apply lab_term_sub' with (L := x); trivial. apply lab_term_sub' with (L := L); trivial.  *)
(*  split; trivial.  inversion H. clear H H0 H1 t1 t2.  *)
(*  apply lab_term_abs with (L := L \u (fv t)); intros x Hx. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term (S \u {{x}}) (pterm_abs t ^ x)). apply H2; trivial. clear H2 H L. *)
(*  unfold open in *|-*. simpl. rewrite <- open_rec_term with (t := u); trivial. *)
(*  inversion Q. clear Q H t1. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term (S \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}t))).  *)
(*    apply H1; trivial. clear H1 H L.  *)
(*  rewrite <- open_bswap; trivial. rewrite subst_com in Q; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply subset_trans with (F := S); trivial. *)
(*  apply subset_union_weak_l. *)
(*  split; trivial. inversion H. clear H H1 H2 t1 t2. *)
(*  apply lab_term_sub with (L := L \u (fv t)). intros x Hx. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term (S \u {{x}}) ((t [u]) ^ x)). apply H3; trivial. clear H3 H L. *)
(*  unfold open in *|-*. simpl in *|-*. rewrite <- open_rec_term with (t := v); trivial. *)
(*  inversion Q. clear Q H H2 t1 t2. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term (S \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}t))).  *)
(*    apply H3; trivial. clear H3 H L.  *)
(*  rewrite <- open_bswap; trivial. rewrite subst_com in Q; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply subset_trans with (F := S); trivial. *)
(*  apply subset_union_weak_l. *)
(*  apply lab_term_sub' with (L := L); trivial; intros x Hx. *)
(*  assert (Q : lab_term (S \u {{x}}) ((t [u]) ^ x)). apply H3; trivial. clear H3. *)
(*  unfold open in Q. simpl in Q.  inversion Q; trivial. *)
(* Qed. *)

(* Lemma red_regular_lab_Bx : forall t t', lab_sys_Bx t t' -> (exists S, lab_term S t /\ lab_term S t'). *)
(* Proof. *)
(*  intros t t' H. induction H. destruct H; exists S. inversion H. *)
(*  split; [apply lab_term_app; trivial | apply lab_term_sub' with (L := x); trivial].  *)
(*  apply lab_term_abs with (L := x); trivial. apply term_to_lab_term; trivial. *)
(*  apply red_regular_lab_x; trivial. *)
(* Qed. *)

(* Lemma red_regular'_lab_eqc : forall t t', lab_eqc t t' -> (exists S, lab_term S t <-> lab_term S t'). *)
(* Proof. *)
(*  intros t t' H. induction H. exists {}. split; intros; trivial. *)
(*  exists S. split; intros. *)
(*  inversion H1. clear H1 H2 H3 t1 t2. *)
(*  apply lab_term_sub with (L := L \u (fv t)); trivial. intros x Hx. unfold open in *|-*. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term (S \u {{x}}) ((t [u]) ^ x)). apply H4; trivial. clear H4 H1 L. *)
(*  inversion Q. clear Q H0 H1 H3 t1 t2. simpl. rewrite <- open_rec_term with (t := v); trivial. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term (S \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}t))).  *)
(*    apply H4; trivial. clear H4 H0 L.  *)
(*  rewrite <- open_bswap; trivial. rewrite subst_com in Q; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply subset_trans with (F := S); trivial. *)
(*  apply subset_union_weak_l.  *)
(*  inversion H1. clear H1 H2 H3 t1 t2. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros x Hx. unfold open in *|-*. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term (S \u {{x}}) ((& t [[v]]) ^ x)). apply H4; trivial. clear H4 H1 L. *)
(*  unfold open in Q. simpl in Q. rewrite <- open_rec_term with (t := v) in Q; trivial. *)
(*  inversion Q. clear Q H1 H3 H5 H6 t1 t2. simpl. rewrite open_lab_term with (t := u) (S := S); trivial. *)
(*  apply lab_term_sub with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term (S \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}&t))).  *)
(*    apply H4; trivial. clear H4 H1 L.  *)
(*  rewrite <- open_bswap in Q; trivial. rewrite subst_com; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_term_subset with (S := S); trivial. apply subset_union_weak_l. *)
(*  case var_fresh with (L := L). intros x Hx. *)
(*  assert (Q :  lab_term (S \u {{x}}) (({1 ~> pterm_fvar x}(& t)[[v]]))). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := v) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 Hx L. inversion Q; trivial. *)
(*  case var_fresh with (L := L \u fv v). intros x Hx. apply notin_union in Hx. destruct Hx. *)
(*  assert (Q :  lab_term (S \u {{x}}) (({1 ~> pterm_fvar x}(& t)[[v]]))). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := v) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 H1 L. inversion Q. clear Q H H0 H1 H3 H4 H5 H6 H7 u L t1 t2.    *)
(*  unfold VarSet.Subset in H8. setoid_rewrite in_union in H8. *)
(*  intros y Hy.  assert (Q : y \in S \/ y \in {{x}}). apply H8; trivial. clear H8. *)
(*  destruct Q; trivial. apply in_singleton in H. rewrite H in Hy. contradiction. *)
(*  exists {}. split; intros. *)
(*  inversion H1. clear H1 H2 H3 t1 t2. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros x Hx. unfold open in *|-*. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term ({} \u {{x}}) (t [[u]] ^ x)). apply H4; trivial. clear H4 H1 L. *)
(*  unfold open in Q. simpl in Q. rewrite <- open_rec_term with (t := u) in Q; trivial. *)
(*  inversion Q. clear Q H1 H3 H5 H8 t1 t2. simpl. rewrite <- open_rec_term with (t := v); trivial. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term ({} \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}t))).  *)
(*    apply H4; trivial. clear H4 H1 L.  *)
(*  rewrite <- open_bswap; trivial. rewrite subst_com in Q; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. left. left. trivial.  *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply subset_trans with (F := {}); trivial. apply subset_union_weak_l. *)
(*  case var_fresh with (L := L). intros x Hx. *)
(*  assert (Q :  lab_term ({} \u {{x}}) (({1 ~> pterm_fvar x}t)[[u]])). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := u) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 Hx L. inversion Q; trivial.  *)
(*  case var_fresh with (L := L \u fv u). intros x Hx. apply notin_union in Hx. destruct Hx. *)
(*  assert (Q :  lab_term ({} \u {{x}}) (({1 ~> pterm_fvar x}t)[[u]])). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := u) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 H1 L. inversion Q. clear Q H H0 H1 H3 H4 H5 H6 H7 H8 H9 L t1 t2.    *)
(*  unfold VarSet.Subset in H10. setoid_rewrite in_union in H10. *)
(*  intros y Hy.  assert (Q : y \in {} \/ y \in {{x}}). apply H10; trivial. clear H10. *)
(*  destruct Q; trivial. apply in_singleton in H. rewrite H in Hy. contradiction. *)
(*  inversion H1. clear H1 H2 H3 t1 t2. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros x Hx. unfold open in *|-*. *)
(*  apply notin_union in Hx. destruct Hx. *)
(*  assert (Q : lab_term ({} \u {{x}}) ((& t)[[v]] ^ x)). apply H4; trivial. clear H4 H1 L. *)
(*  unfold open in Q. simpl in Q. rewrite <- open_rec_term with (t := v) in Q; trivial. *)
(*  inversion Q. clear Q H1 H3 H5 H8 t1 t2. simpl. rewrite <- open_rec_term with (t := u); trivial. *)
(*  apply lab_term_sub' with (L := L \u (fv t)); trivial. intros y Hy. unfold open in *|-*. *)
(*  apply notin_union in Hy. destruct Hy. *)
(*  assert (Q : lab_term ({} \u {{x}} \u {{y}}) ({0 ~> pterm_fvar y}({1 ~> pterm_fvar x}(& t)))).  *)
(*    apply H4; trivial. clear H4 H1 L.  *)
(*  rewrite <- open_bswap in Q; trivial. rewrite subst_com; try omega; trivial. *)
(*  rewrite swap_eq_open; trivial. apply swap_lab_term; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply subset_trans with (F := {}); trivial. apply subset_union_weak_l. *)
(*  case var_fresh with (L := L). intros x Hx. *)
(*  assert (Q :  lab_term ({} \u {{x}}) (({1 ~> pterm_fvar x}(& t))[[v]])). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := v) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 Hx L. inversion Q; trivial.  *)
(*  case var_fresh with (L := L \u fv v). intros x Hx. apply notin_union in Hx. destruct Hx. *)
(*  assert (Q :  lab_term ({} \u {{x}}) (({1 ~> pterm_fvar x}(&t))[[v]])). *)
(*    unfold open in H4. simpl in H4.  *)
(*    rewrite open_rec_term with (t := v) (k := 0) (u := pterm_fvar x); trivial. *)
(*    apply H4; trivial. *)
(*  clear H4 H1 L. inversion Q. clear Q H H0 H1 H3 H4 H5 H6 H7 H8 H9 L t1 t2.    *)
(*  unfold VarSet.Subset in H10. setoid_rewrite in_union in H10. *)
(*  intros y Hy.  assert (Q : y \in {} \/ y \in {{x}}). apply H10; trivial. clear H10. *)
(*  destruct Q; trivial. apply in_singleton in H. rewrite H in Hy. contradiction. *)
(* Qed. *)

(* Lemma red_swap_Lab_sys_x : red_swap lab_sys_x. *)
(* Proof.  *)
(*  intros_all. induction H; simpl. *)
(*  (* lab_reg_rule_var *) *)
(*  apply lab_reg_rule_var with (S := S \u {{x}} \u {{y}}). *)
(*  apply lab_term_sub' with (L := {}); inversion H; clear H H0 H1 t1 t2.  *)
(*  intros z Hz. unfold open. simpl. apply lab_term_var.  *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. *)
(*  apply fv_subset_swap; trivial. *)
(*  (* lab_reg_rule_gc *) *)
(*  apply lab_reg_rule_gc with (S := S \u {{x}} \u {{y}}); simpl. *)
(*  apply swap_lab_term.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_term_subset with (S := S); trivial. *)
(*  apply subset_trans with (F := S \u {{x}}); apply subset_union_weak_l. *)
(*  inversion H0. clear H0 H1 H2 t1 t2. apply lab_term_sub' with (L := L \u {{x}} \u {{y}}). *)
(*  intros z Hz. apply notin_union in Hz. destruct Hz. apply notin_union in H0. destruct H0. *)
(*  apply notin_singleton in H1. apply notin_singleton in H2. rewrite open_swap; trivial. *)
(*  apply swap_lab_term. apply in_union. left. apply in_union. left. apply in_union. right. *)
(*  apply in_singleton; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_term_subset with (S := S \u {{z}}).  *)
(*  rewrite union_comm with (E := S \u {{x}} \u {{y}}) (F := {{z}}).  *)
(*  rewrite union_assoc. rewrite union_assoc. rewrite union_comm with (E := {{z}}). *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. apply H3; trivial. *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. apply swap_fvar. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial.  *)
(*  apply subset_trans with (F := S); trivial. rewrite <- union_assoc. *)
(*  apply subset_union_weak_l. *)
(*  (* lab_reg_rule_app *) *)
(*  apply lab_reg_rule_app with (S := S \u {{x}} \u {{y}}). apply swap_lab_body. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_body_subset with (S := S); trivial. rewrite <- union_assoc. apply subset_union_weak_l.   *)
(*  inversion H0. clear H0 H1 H2 t0 t3. *)
(*  apply lab_term_sub' with (L := L \u {{x}} \u {{y}}). intros z Hz. *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H0. destruct H0. *)
(*  apply notin_singleton in H1. apply notin_singleton in H2. rewrite open_swap; trivial. *)
(*  apply swap_lab_term. apply in_union. left. apply in_union. left. apply in_union. right. *)
(*  apply in_singleton; trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_term_subset with (S := S \u {{z}}).  *)
(*  rewrite union_comm with (E := S \u {{x}} \u {{y}}) (F := {{z}}).  *)
(*  rewrite union_assoc. rewrite union_assoc. rewrite union_comm with (E := {{z}}). *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. apply H3; trivial. *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. apply swap_fvar. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial.  *)
(*  apply subset_trans with (F := S); trivial. rewrite <- union_assoc. *)
(*  apply subset_union_weak_l. *)
(*  (* lab_reg_rule_lamb *) *)
(*  inversion H. clear H H0 H1 t1 t2. unfold bswap. rewrite bswap_swap_comm. *)
(*  apply lab_reg_rule_lamb with (S := S \u {{x}} \u {{y}}). *)
(*  apply lab_term_sub' with (L := L \u {{x}} \u {{y}}). intros z Hz. *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H. destruct H. *)
(*  apply notin_singleton in H0. apply notin_singleton in H1. unfold open. simpl. *)
(*  assert (Q :  lab_term (S \u {{z}}) (pterm_abs t ^ z)). apply H2; trivial. *)
(*  clear H2 H L. inversion Q. clear Q H t1.  *)
(*  apply lab_term_abs with (L := L \u {{x}} \u {{y}} \u {{z}}). intros w Hw. *)
(*  apply notin_union in Hw. destruct Hw. apply notin_union in H. destruct H. *)
(*  apply notin_union in H. destruct H.  apply notin_singleton in H6.  *)
(*  apply notin_singleton in H7. apply notin_singleton in H8. unfold open.  *)
(*  rewrite <- swap_var_id with (x := x) (y := y) (z := z); trivial. *)
(*  rewrite <- swap_var_id with (x := x) (y := y) (z := w); trivial. *)
(*  rewrite <- open_swap_comm. rewrite <- open_swap_comm. apply swap_lab_term.   *)
(*  apply in_union. left. apply in_union. left.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply in_union. left. apply in_union. left.  *)
(*  apply in_union. right. apply in_singleton. trivial. *)
(*  apply lab_term_subset with (S := S \u {{z}} \u {{w}}).  *)
(*  rewrite <- union_assoc with (E :=  S \u {{x}} \u {{y}}). *)
(*  rewrite union_comm with (F := {{z}} \u {{w}}).   *)
(*  rewrite union_assoc with (E := {{z}} \u {{w}}). *)
(*  rewrite union_assoc with (E := {{z}} \u {{w}}). *)
(*  rewrite union_comm with (F := S). rewrite union_assoc.  *)
(*  rewrite <-  union_assoc with (E :=  S \u {{z}} \u {{w}}). *)
(*  apply subset_union_weak_l. apply H2; trivial.  *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. apply swap_fvar.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply in_union. right. apply in_singleton. trivial. *)
(*  apply subset_trans with (F := S); trivial. rewrite <- union_assoc. *)
(*  apply subset_union_weak_l.   *)
(*  (* lab_reg_rule_comp *) *)
(*  unfold bswap. rewrite bswap_swap_comm.  *)
(*  apply lab_reg_rule_comp with (S := S \u {{x}} \u {{y}}). *)
(*  inversion H. clear H H1 H2 t1 t2. *)
(*  apply lab_term_sub' with (L := L \u {{x}} \u {{y}}). intros z Hz. *)
(*  apply notin_union in Hz. destruct Hz. apply notin_union in H. destruct H. *)
(*  apply notin_singleton in H1. apply notin_singleton in H2. unfold open. simpl. *)
(*  assert (Q :  lab_term (S \u {{z}}) ((t[u]) ^ z)). apply H3; trivial. *)
(*  clear H3 H L. inversion Q. clear Q H H3 t1 t2.  *)
(*  apply lab_term_sub with (L := L \u {{x}} \u {{y}} \u {{z}}). intros w Hw. *)
(*  apply notin_union in Hw. destruct Hw. apply notin_union in H. destruct H. *)
(*  apply notin_union in H. destruct H.  apply notin_singleton in H3.  *)
(*  apply notin_singleton in H9. apply notin_singleton in H10. unfold open.  *)
(*  rewrite <- swap_var_id with (x := x) (y := y) (z := z); trivial. *)
(*  rewrite <- swap_var_id with (x := x) (y := y) (z := w); trivial. *)
(*  rewrite <- open_swap_comm. rewrite <- open_swap_comm. apply swap_lab_term.   *)
(*  apply in_union. left. apply in_union. left.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply in_union. left. apply in_union. left.  *)
(*  apply in_union. right. apply in_singleton. trivial. *)
(*  apply lab_term_subset with (S := S \u {{z}} \u {{w}}).  *)
(*  rewrite <- union_assoc with (E :=  S \u {{x}} \u {{y}}). *)
(*  rewrite union_comm with (F := {{z}} \u {{w}}).   *)
(*  rewrite union_assoc with (E := {{z}} \u {{w}}). *)
(*  rewrite union_assoc with (E := {{z}} \u {{w}}). *)
(*  rewrite union_comm with (F := S). rewrite union_assoc.  *)
(*  rewrite <-  union_assoc with (E :=  S \u {{z}} \u {{w}}). *)
(*  apply subset_union_weak_l. apply H7; trivial.  *)
(*  rewrite <- swap_var_id with (x := x) (y := y) (z := z); trivial. *)
(*  rewrite <- open_swap_comm. apply swap_lab_term. *)
(*  apply in_union. left. apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply lab_term_subset with (S := S \u {{z}}); trivial. *)
(*  rewrite union_comm with (E := S \u {{x}} \u {{y}}) (F := {{z}}).  *)
(*  rewrite union_assoc. rewrite union_assoc. rewrite union_comm with (E := {{z}}). *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply swap_term; trivial. apply lex_SN_swap; trivial. apply swap_fvar.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton. trivial. *)
(*  apply in_union. right. apply in_singleton. trivial. *)
(*  apply subset_trans with (F := S); trivial. rewrite <- union_assoc. apply subset_union_weak_l.   *)
(*  intro H'. apply H0. apply swap_term with (x := x) (y := y) in H'. *)
(*  rewrite swap_inv in H'; trivial. *)
(* Qed. *)

(* Lemma red_swap_Lab_sys_Bx : red_swap lab_sys_Bx. *)
(* Proof.  *)
(*  intros_all. destruct H; simpl. destruct H; simpl. *)
(*  apply lab_B_lx. apply lab_reg_rule_b with (S := S \u {{x}} \u {{y}}). apply swap_lab_body.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial.  *)
(*  apply lab_body_subset with (S := S); trivial. rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply swap_term; trivial. apply swap_fvar.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial.  *)
(*  apply in_union. right. apply in_singleton; trivial.  *)
(*  apply subset_trans with (F := S); trivial. rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply lex_SN_swap; trivial. *)
(*  apply lab_sys_x_lx. apply red_swap_Lab_sys_x; trivial. *)
(* Qed. *)

(* Lemma red_swap_lab_eqc : red_swap lab_eqc. *)
(* Proof.  *)
(*  intros_all. destruct H; unfold bswap; simpl; try rewrite bswap_swap_comm. *)
(*  apply lab_eqc_rf. apply lab_eqc_rx1 with (S := S \u {{x}} \u {{y}}). apply swap_lab_term.  *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  apply lab_term_subset with (S := S); trivial. rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply swap_term; trivial. *)
(*  apply lab_eqc_rx2; apply swap_term; trivial. *)
(* Qed. *)

(* Lemma ctx_lab_regular : forall R, red_lab_regular R -> red_lab_regular (lab_contextual_closure R). *)
(* Proof. *)
(*  intros_all. induction H0. apply H; trivial. *)
(*  case IHlab_contextual_closure; clear IHlab_contextual_closure; intros S' H2. *)
(*  exists (S \u S'). destruct H2. split; apply lab_term_app; trivial.  *)
(*  apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  apply lab_term_subset with (S := S); trivial. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  apply lab_term_subset with (S := S); trivial. apply subset_union_weak_l. *)
(*  case IHlab_contextual_closure; clear IHlab_contextual_closure; intros S' H2. *)
(*  exists (S \u S'). destruct H2. split; apply lab_term_app; trivial.  *)
(*  apply lab_term_subset with (S := S); trivial. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  apply lab_term_subset with (S := S); trivial. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  pick_fresh x. apply notin_union in Fr. destruct Fr. apply notin_union in H2. destruct H2. *)
(*  assert (Q:  exist S, lab_term S (t ^ x) /\ lab_term S (t' ^ x)). apply H1; trivial. *)
(*  clear H0 H1 H2 L. case Q; clear Q. intros S Q. destruct Q. exists (S \u {{x}}). *)
(*  split; apply lab_term_abs with (L := (fv t) \u (fv t')); intros y Hy; *)
(*  apply notin_union in Hy; destruct Hy.  *)
(*  apply lab_term_subset with (S' := S \u {{x}} \u {{y}}) in H0.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S' := S \u {{x}} \u {{y}}) in H1.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  case var_fresh with (L := L \u (fv t) \u (fv t')). intros x Fr. *)
(*  apply notin_union in Fr. destruct Fr. apply notin_union in H3. destruct H3. *)
(*  assert (Q:  exist S, lab_term S (t ^ x) /\ lab_term S (t' ^ x)). apply H2; trivial. *)
(*  clear H1 H2 H3 L. case Q; clear Q. intros S' Q. destruct Q. exists (S' \u S \u {{x}}). *)
(*  split; apply lab_term_sub with (L := (fv t) \u (fv t')); try intros y Hy; *)
(*  try apply notin_union in Hy; try destruct Hy.  *)
(*  apply lab_term_subset with (S' := S' \u S \u {{x}} \u {{y}}) in H1.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc.  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S := S); trivial. rewrite union_comm with (E := S'). *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S' := S' \u S \u {{x}} \u {{y}}) in H2.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc.  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  apply lab_term_subset with (S := S); trivial. rewrite union_comm with (E := S'). *)
(*  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  case IHlab_contextual_closure; clear IHlab_contextual_closure; intros S' H2. *)
(*  exists (S \u S'). destruct H2. inversion H0. clear H0. *)
(*  split; apply lab_term_sub with (L := x); try intros y Hy. *)
(*  apply lab_term_subset with (S := S \u {{y}}). rewrite <- union_assoc. *)
(*  rewrite union_comm with (E := S'). rewrite union_assoc. apply subset_union_weak_l. *)
(*  apply H4; trivial. apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  apply lab_term_subset with (S := S \u {{y}}). rewrite <- union_assoc. *)
(*  rewrite union_comm with (E := S'). rewrite union_assoc. apply subset_union_weak_l. *)
(*  apply H4; trivial. apply lab_term_subset with (S := S'); trivial. apply subset_union_weak_r. *)
(*  case var_fresh with (L := L \u (fv t) \u (fv t')). intros x Fr. *)
(*  apply notin_union in Fr. destruct Fr. apply notin_union in H4. destruct H4. *)
(*  assert (Q:  exist S, lab_term S (t ^ x) /\ lab_term S (t' ^ x)). apply H3; trivial. *)
(*  clear H2 H3 H4 L. case Q; clear Q. intros S Q. destruct Q. exists (S \u (fv u) \u {{x}}). *)
(*  split; apply lab_term_sub' with (L := (fv t) \u (fv t')); trivial.  *)
(*  intros y Hy. apply notin_union in Hy. destruct Hy. *)
(*  apply lab_term_subset with (S' := S \u (fv u) \u {{x}} \u {{y}}) in H2.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc.  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  rewrite union_comm with (E := S). rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  intros y Hy. apply notin_union in Hy. destruct Hy. *)
(*  apply lab_term_subset with (S' := S \u (fv u) \u {{x}} \u {{y}}) in H3.  *)
(*  apply swap_lab_term' with (x := x); trivial. *)
(*  apply in_union. left. apply in_union. right. apply in_singleton; trivial. *)
(*  apply in_union. right. apply in_singleton; trivial. *)
(*  rewrite <- union_assoc.  rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  rewrite union_comm with (E := S). rewrite <- union_assoc. apply subset_union_weak_l. *)
(*  exists S. inversion H0. clear H0. generalize H3. intro H5. apply ctx_sys_Bex_regular in H5.  *)
(*  destruct H5. split; apply lab_term_sub' with (L := x); trivial. *)
(*  case H1; clear H1; intros n H1. inversion H1; clear H1. case (H6 u'); trivial; clear H6. *)
(*  intros k H1. exists k. apply H1. intros a H6. unfold VarSet.Subset in H2. apply H2. *)
(*  apply basic_prop1 with (t' := u'); trivial. right; trivial. *)
(* Qed. *)

(*
Lemma ctx_lab_regular' : forall R, red_lab_regular' R ->
                                    red_lab_regular' (lab_contextual_closure R).
Proof.
 intros R H. unfold red_lab_regular' in *|-*. intros t t' H'. induction H'.
 case (H t s); trivial.  intros S H1. exists S; trivial.
 case IHH'; clear IHH'; intros S' H1. exists (S \u S'). split.
 intro H2. inversion H2. clear H2 H3 H4 t1 t2. apply lab_term_app.

case IHH'2; clear IHH'2; intros S' H2.
 exists (S \u S'). split; intro H3. inversion H3. clear H0 H3 H4 t1 t2.
 apply lab_term_app. destruct H1. apply lab_term_subset with (S := S).

 apply lab_term_subset with (S := S).
 apply lab_term_subset with (S := S'); try apply H2; trivial].

 skip. skip. skip. skip.
 Admitted.
*)


(* Matching mu logic *)
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Require Import Lib.KnasterTarski.
Require Import Coq.Relations.Relation_Definitions.

Record Signature : Type :=
  { sort: Set;
    sort_eq_dec: forall s1 s2 : sort, {s1 = s2} + {s1 <> s2};
    evar : Set;
    evar_eq_dec : forall v1 v2 : evar, {v1 = v2} + {v1 <> v2};
    svar : Set;
    svar_eq_dec : forall v1 v2 : svar, {v1 = v2} + {v1 <> v2};
    symbol : Set;
    sort_of_evar : evar -> sort;
    sort_of_svar : svar -> sort;
    sort_of_symbol : symbol -> list sort * sort;

    evar_idx : sort -> nat -> evar;
    svar_idx : sort -> nat -> svar;

    evar_idx_sort : forall (s:sort) (n:nat),
        sort_of_evar (evar_idx s n) = s;
    svar_idx_sort : forall (s:sort) (n:nat),
        sort_of_svar (svar_idx s n) = s;

    evar_idx_inj: forall (x y : nat) (s1 s2 : sort),
        evar_idx s1 x = evar_idx s2 y -> s1 = s2 /\ x = y;
    svar_idx_inj: forall (x y : nat) (s1 s2 : sort),
        svar_idx s1 x = svar_idx s2 y -> s1 = s2 /\ x = y;
  }.

Parameter sigma : Signature.

Definition sorts_of_symbol_args (sym : symbol sigma) : list (sort sigma) :=
  fst (sort_of_symbol sigma sym).

Definition sort_of_symbol_result (sym : symbol sigma) : sort sigma :=
  snd (sort_of_symbol sigma sym).

(* List of set variables that are not allowed to be used positively or negatively. *)
Record SVarBlacklist : Set :=
  { blacklistNegative : list (svar sigma);
    blacklistPositive : list (svar sigma);
  }.

Definition SVB_empty : SVarBlacklist :=
  {| blacklistNegative := nil;
     blacklistPositive := nil;
  |}.

Definition SVB_add (v : svar sigma) (b : SVarBlacklist) : SVarBlacklist :=
  {| blacklistNegative := cons v (blacklistNegative b);
     blacklistPositive := blacklistPositive b;
  |}.

Definition SVB_swap (b : SVarBlacklist) : SVarBlacklist :=
  {| blacklistNegative := blacklistPositive b;
     blacklistPositive := blacklistNegative b;
  |}.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.
  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls)
  .

  Definition hhead (x : A) (xs : list A) (l : hlist (cons x xs)) : B x :=
    match l with
    | HCons _ _ h _ => h
    end.

  Definition htail x xs (l : hlist (cons x xs)) : hlist xs :=
    match l with
    | HCons _ _ _ tl => tl
    end.

  Variable P : forall a : A, B a -> Prop.
  Inductive Forall : forall (ts : list A), hlist ts -> Prop :=
  | Forall_nil : Forall nil HNil
  | Forall_cons : forall (t : A) (ts : list A) (x : B t) (xs : hlist ts),
      P t x -> Forall ts xs -> Forall (cons t ts) (HCons t ts x xs)
  .
End hlist.

Section hlist_hmap.
  Variable A : Type.
  Variable B C : A -> Type.
  Variable F : forall a : A, B a -> C a.
(*
  Fixpoint hmap (ts : list A) : hlist A B ts -> hlist A C ts :=
    match ts with
    | nil => fun _ => HNil A C
    | cons x xs =>
      fun l =>
        HCons A C x xs (F x (hhead A B x xs l)) (hmap xs (htail A B x xs l))
    end.
 *)
  (* This version of hmap is uglier than the above one, but it does explicit
     matching on its second argument, and therefore can be used when reasoning
     about termination of `Valuation_ext`. *)
  Fixpoint hmap (ts : list A) (l : hlist A B ts) : hlist A C ts :=
    match ts with
    | nil => fun _ => HNil A C
    | cons x xs =>
      fun l : hlist A B (cons x xs) =>
        match l with
        | HCons _ _ x xs h t =>
          HCons A C x xs (F x h) (hmap xs t)
        end
    end l.
End hlist_hmap.

Inductive Pattern : SVarBlacklist -> sort sigma -> Type :=
| EVar : forall (v : evar sigma)(b : SVarBlacklist),
    Pattern b (sort_of_evar sigma v)
| SVar : forall (v : svar sigma)(b : SVarBlacklist),
    ~List.In v (blacklistPositive b) -> Pattern b (sort_of_svar sigma v)
| And : forall (s : sort sigma)(b : SVarBlacklist),
    Pattern b s -> Pattern b s -> Pattern b s
| Neg : forall (s : sort sigma)(b : SVarBlacklist),
    Pattern (SVB_swap b) s -> Pattern b s
| Sym : forall (sym : symbol sigma)(b : SVarBlacklist),
    hlist (sort sigma) (Pattern b) (sorts_of_symbol_args sym) -> Pattern b (sort_of_symbol_result sym)
| Ex : forall (s : sort sigma)(b : SVarBlacklist),
    evar sigma -> Pattern b s -> Pattern b s
| Mu : forall (s : sort sigma)(b : SVarBlacklist) (v : svar sigma),
    Pattern (SVB_add v b) s -> Pattern b s
.
(*
Locate "+".
Locate sum.
Check Nat.add.
Check Sym.
Fixpoint Pattern_measure b s (p : Pattern b s) : nat :=
  match p with
  | EVar _ _ => 0
  | SVar _ _ _ => 0
  | And s b p1 p2 => S (Nat.add (Pattern_measure b s p1) (Pattern_measure b s p2))
  | Neg s b p => S (Pattern_measure (SVB_swap b) s p)
  | Sym sym b args
    => S (
           (fix f (ts : list (sort sigma)) (args : hlist (sort sigma) (Pattern b) ts) : nat :=
              match ts with
              | nil => 0
              | cons x xs => Nat.add () ()
             0
           ) (sorts_of_symbol_args sym) args
         )
  | Ex s b v p => S (Pattern_measure b s p)
  | Mu s b v p => S (Pattern_measure (SVB_add v b) s p)
  end.
*)

(* A custom induction principle.
   https://stackoverflow.com/q/47097928/6209703
 *)
Section Pattern_nested_ind.
  Variable P : forall (b : SVarBlacklist) (s : sort sigma), Pattern b s -> Prop.
  Hypothesis EVar_case : forall (v : evar sigma)(b : SVarBlacklist), P b (sort_of_evar sigma v) (EVar v b).
  Hypothesis SVar_case : forall (v : svar sigma)(b : SVarBlacklist)(pf : ~ In v (blacklistPositive b)), P b (sort_of_svar sigma v) (SVar v b pf).
  Hypothesis And_case : forall (s : sort sigma) (b : SVarBlacklist) (p1 p2 : Pattern b s), P b s p1 -> P b s p2 -> P b s (And s b p1 p2).
  Hypothesis Neg_case : forall (s : sort sigma)(b : SVarBlacklist)(p : Pattern (SVB_swap b) s), P (SVB_swap b) s p -> P b s (Neg s b p).
  Hypothesis Sym_case :
    forall (sym : symbol sigma)(b : SVarBlacklist)
           (args : hlist (sort sigma) (Pattern b) (sorts_of_symbol_args sym)),
      Forall (sort sigma) (Pattern b) (P b) (sorts_of_symbol_args sym) args ->
      P b (sort_of_symbol_result sym) (Sym sym b args).
  Hypothesis Ex_case : forall (s : sort sigma)(b : SVarBlacklist) (v : evar sigma)(p : Pattern b s),
      P b s p -> P b s (Ex s b v p).
  Hypothesis Mu_case : forall (s : sort sigma)(b : SVarBlacklist)(v : svar sigma)
                              (p : Pattern (SVB_add v b) s), P (SVB_add v b) s p -> P b s (Mu s b v p).

  Fixpoint Pattern_nested_ind (s : sort sigma) (b : SVarBlacklist) (p : Pattern b s) : P b s p :=
    match p with
    | EVar v b => EVar_case v b
    | SVar v b pf => SVar_case v b pf
    | And s b p1 p2 => And_case s b p1 p2 (Pattern_nested_ind s b p1) (Pattern_nested_ind s b p2)
    | Neg s b p' => Neg_case s b p' (Pattern_nested_ind s (SVB_swap b) p')
    | Sym sym b args =>
      let H := (fix f (ss : list (sort sigma))
                    (xs : hlist (sort sigma) (Pattern b) ss) : Forall (sort sigma) (Pattern b) (P b) ss xs :=
                  match xs with
                  | HNil _ _ => Forall_nil (sort sigma) (Pattern b) (P b)
                  | HCons _ _ s ss x xs => Forall_cons (sort sigma) (Pattern b) (P b) s ss x xs (Pattern_nested_ind s b x) (f ss xs)
                  end
               ) (sorts_of_symbol_args sym) args in
      Sym_case sym b args H
    | Ex s b v p' => Ex_case s b v p' (Pattern_nested_ind s b p')
    | Mu s b v p' => Mu_case s b v p' (Pattern_nested_ind s (SVB_add v b) p')
    end.
End Pattern_nested_ind.

Fixpoint zipWith {A B C : Type}(f: A -> B -> C)(xs : list A)(ys : list B) : list C :=
  match xs,ys with
  | nil, nil => nil
  | cons _ _, nil => nil
  | nil, cons _ _ => nil
  | cons x xs, cons y ys => cons (f x y) (zipWith f xs ys)
  end.

Record Model : Type :=
  { mod_carrier : sort sigma -> Set;

    mod_carrier_nonempty : forall (s : sort sigma), mod_carrier s;

    mod_interpretation : forall sym : symbol sigma,
        hlist (sort sigma) mod_carrier (sorts_of_symbol_args sym) ->
        Ensemble (mod_carrier (sort_of_symbol_result sym));
  }.

Program Instance ModelOrderedSet {M : Model} {s : sort sigma} : OrderedSet (Ensemble (mod_carrier M s)) :=
  {| leq := Ensembles.Included (mod_carrier M s);
  |}.
Next Obligation.
  constructor.
  * unfold reflexive. unfold Included. auto.
  * unfold transitive. unfold Included. auto.
  * unfold antisymmetric. intros.
    apply Extensionality_Ensembles. split; auto.
Qed.

Definition Meet {M : Model} {s : sort sigma} (ee : Ensemble (Ensemble (mod_carrier M s))) : Ensemble (mod_carrier M s) :=
  fun m => forall e : Ensemble (mod_carrier M s),
      Ensembles.In (Ensemble (mod_carrier M s)) ee e -> Ensembles.In (mod_carrier M s) e m.

(* TODO lemma that Meet behaves like a meet. We will use the lemma in the two obligations
   from the following definition: *)
Program Instance ModelCompleteLattice
        {M : Model} {s : sort sigma} : CompleteLattice (Ensemble (mod_carrier M s)) :=
  {| meet := Meet;
     join := joinFromMeet Meet;
  |}.
Next Obligation.
Admitted.
Next Obligation.
Admitted.

(* https://stackoverflow.com/a/62679065/6209703 *)
Fixpoint hlist_in_ensemble_hlist {A : Type}{B : A -> Type}(types : list A)
        (sets : hlist A (fun a => Ensemble (B a)) types) (elems : hlist A B types) : Prop :=
  match types with
  | nil => fun _ _ => True
  | cons t ts =>
    fun sets elems =>
      Ensembles.In (B t) (hhead A (fun a => Ensemble (B a)) t ts sets) (hhead A B t ts elems)
      /\ hlist_in_ensemble_hlist ts (htail A (fun a => Ensemble (B a)) t ts sets) (htail A B t ts elems)
  end sets elems.

(* Pointwise extension of the interpretation *)
Definition interpretation_ex
        {M : Model}
        (sym : symbol sigma)
        (args : hlist (sort sigma) (fun s => Ensemble (mod_carrier M s)) (sorts_of_symbol_args sym))
  : Ensemble (mod_carrier M (sort_of_symbol_result sym)) :=
  fun m =>
    exists (args' : hlist (sort sigma) (mod_carrier M) (sorts_of_symbol_args sym)),
    hlist_in_ensemble_hlist (sorts_of_symbol_args sym) args args' /\
    Ensembles.In (mod_carrier M (sort_of_symbol_result sym)) (mod_interpretation M sym args') m
.

Record Valuation {M : Model} : Type :=
  {
  val_evar : forall v : evar sigma, mod_carrier M (sort_of_evar sigma v);
  val_svar : forall v : svar sigma, Ensemble (mod_carrier M (sort_of_svar sigma v));
  }.

Definition Valuation_update_evar
           {M : Model}
           (V : @Valuation M)
           (v : evar sigma)
           (m : mod_carrier M (sort_of_evar sigma v))
  : Valuation :=
  {| val_evar := fun v' =>
                   match evar_eq_dec sigma v v' with
                   | left e =>
                     match e with
                     | eq_refl _ => fun m => m
                     end
                   | right _ => fun _ => val_evar V v'
                   end m;
     val_svar := val_svar V;
  |}.

Definition Valuation_update_svar
           {M : Model}
           (V : @Valuation M)
           (v : svar sigma)
           (m : Ensemble (mod_carrier M (sort_of_svar sigma v)))
  : Valuation :=
  {| val_evar := val_evar V;
     val_svar := fun v' =>
                   match svar_eq_dec sigma v v' with
                   | left e =>
                     match e with
                     | eq_refl _ => m
                     end
                   | right _ => val_svar V v'
                   end;
  |}.

Check Ex.
Fixpoint Valuation_ext {M : Model} (val : @Valuation M)
         (b : SVarBlacklist) (s : sort sigma) (p : Pattern b s) {struct p}
  : Ensemble (mod_carrier M s) :=
  match p with
  | EVar v _ => Singleton (mod_carrier M (sort_of_evar sigma v)) (val_evar val v)
  | Neg s b p' => Complement (mod_carrier M s) (Valuation_ext val (SVB_swap b) s p')
  | Sym sym b args =>
    interpretation_ex sym (hmap (sort sigma)
                                (Pattern b)
                                (fun s => Ensemble (mod_carrier M s))
                                (Valuation_ext val b)
                                (sorts_of_symbol_args sym)
                                args
                          )

  | Ex s b v p =>
    fun m =>
      exists m' : mod_carrier M (sort_of_evar sigma v),
          Ensembles.In
            (mod_carrier M s)
            (Valuation_ext (Valuation_update_evar val v m') b s p)
            m
  | _ => fun m => False
  end.


Require Import GHC.Base.
Import GHC.Base.Notations.
Require Import Proofs.GHC.Base.
Require Import Data.Map.Internal.
Import GHC.Num.Notations.
Require Import OrdTactic.
Require Import Psatz.
Require Import Tactics.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.InsertProofs.
Require Import MapProofs.DeleteUpdateProofs.

Section WF.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [split] *)

Lemma split_Desc :
  forall x (s: Map e a) lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * Map e a -> Prop),
  (forall s1 s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    size s = size s1 + size s2 + (if isSome (sem s x) then 1%Z else 0%Z) ->
    (forall i, sem s i = (if i == x then sem s i else sem s1 i ||| sem s2 i)) ->
    P (s1, s2)) ->
  P (split x s) : Prop.
Proof.
  intros ?? ?? HB.
  Ltac solveThis e := intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e| |f_solver e].
  induction HB.
  - solveThis e. reflexivity.
  - simpl.
    destruct (compare x x0) eqn:?.
  + solveThis e. replace (x == x0) with true by order e.
    simpl_options. lia.
  + apply IHHB1; intros s1_2 s1_3 HB1_2 HB1_3 Hsz Hsems1; clear IHHB1 IHHB2.
    applyDesc e (@link_Desc e a).
    solveThis e. destruct (sem s1 x); cbn -[Z.add] in *.
    * simpl. lia.
    * replace (x == x0) with false by order e. simpl.
      rewrite (sem_outside_below HB2) by solve_Bounds e. simpl. lia.
  + apply IHHB2; intros s2_2 s2_3 HB2_2 HB2_3 Hsz Hsems2; clear IHHB1 IHHB2.
    applyDesc e (@link_Desc e a).
    solveThis e. destruct (sem s2 x); cbn -[Z.add] in *.
    * simpl_options. lia.
    * replace (x == x0) with false by order e. simpl.
      rewrite (sem_outside_above HB1) by solve_Bounds e. simpl. lia.
Qed.

(** ** Verification of [union] *)

(* The [union] uses some nested pattern match that expand to a very large
   number of patterns in Coq. So let’s take them apart here *)
Lemma union_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertR x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insert x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match split x s2 with
      | pair l2 r2 =>
      match union r1 r2 with
      | r1r2 =>
      match union l1 l2 with
      | l1l2 => if andb  (PtrEquality.ptrEq l1l2 l1)
                         (PtrEquality.ptrEq r1r2 r1) : bool
                then s1 else link x vx l1l2 r1r2
      end end end)) ->
  P (union s1 s2).
Proof.
  intros P s1 s2 HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma union_Desc :
  forall (s1: Map e a) s2 lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (union s1 s2) lb ub (fun i => sem s1 i ||| sem s2 i).
(* We use [Desc'] here, because the result of [union] is passed to [link], which
   does a full rebalance, and hence does not need to know anything about the size.
   If it turns out we need [size (union s1 s2)], we can still add it.
*)
Proof.
  intros ???? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply union_destruct; intros; subst; try congruence.
    + solve_Desc e. intros. reflexivity.
    + solve_Desc e. intros. reflexivity.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      applyDesc e (@insertR_Desc e a).
      solve_Desc e. f_solver e.
  * apply union_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      applyDesc e (@insertR_Desc e a).
      solve_Desc e. f_solver e.
    + inversion H3; subst; clear H3.
      applyDesc e (@insert_Desc e a). solve_Desc e. f_solver e.
    + inversion H3; subst; clear H3.
      eapply split_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct_ptrEq.
      - solve_Desc e. f_solver e.
      - applyDesc e (@link_Desc e a).
        solve_Desc e. f_solver e.
Qed.

(** ** Verification of [unions] *)

(* This is a bit of a lazy specification, but goes a long way *)

Lemma Forall_rev:
  forall A P (l : list A), Forall P (rev l) <-> Forall P l.
Proof. intros. rewrite !Forall_forall. setoid_rewrite <- in_rev. reflexivity. Qed.

Lemma oro_assoc : forall {a} (o1 o2 o3: option a),
  (o1 ||| o2) ||| o3 = o1 ||| (o2 ||| o3).
Proof.
  intros. destruct o1. simpl. reflexivity. simpl. reflexivity.
Qed.

Lemma oro_app: forall o l1 l2 (i : e),
  (fold_right (fun (h: Map e a) t => sem h i ||| t) o (l1 ++ l2)) =
  (fold_right (fun h t => sem h i ||| t) None l1) |||
  (fold_right (fun h t => sem h i ||| t) o l2).
Proof.
  intros. generalize dependent o. generalize dependent l2. induction l1; intros.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. rewrite oro_assoc. reflexivity.
Qed.

Require Proofs.Data.Foldable.

Lemma unions_Desc:
  forall (ss: list (Map e a)) lb ub,
  Forall (fun s => Bounded s lb ub) ss ->
  Desc' (unions ss) lb ub (fun i => fold_right (fun h t => sem h i ||| t) None ss).
Proof.
  intros.
  unfold unions.
  (* Switch to a fold right *)
  rewrite Proofs.Data.Foldable.hs_coq_foldl'_list.
  rewrite <- fold_left_rev_right.
  rewrite <- (rev_involutive ss).
  rewrite <- (rev_involutive ss), Forall_rev in H.
  generalize dependent (rev ss). intros.
  rewrite rev_involutive.

  induction H.
  * simpl. applyDesc e (@empty_Desc e a). solve_Desc e. f_solver e.
  * simpl fold_right.
    applyDesc e IHForall.
    applyDesc e union_Desc.
    solve_Desc e.
    intro i.
    rewrite Hsem0, Hsem. rewrite oro_app. simpl. rewrite oro_None_r. reflexivity.
Qed.

(** ** Verification of [insertWithR] *)
Lemma insertWithR_Desc:
  forall (f: a -> a -> a) y v s lb ub,
  Bounded s lb ub ->
  isLB lb y = true ->
  isUB ub y = true ->
  Desc (insertWithR f y v s) lb ub (if isSome (sem s y) then size s else (1 + size s)%Z)
      (fun i => (if i == y then match (sem s y) with
                                | None => Some v
                                | Some x => Some (f x v)
                                end  else None ||| sem s i )).
Proof.
  intros ?????? HB HLB HUB.
  induction HB; intros.
  * simpl.
    applyDesc e (@singleton_Desc e a); try eassumption; solve_Desc e.
  * subst; cbn -[Z.add].
    destruct (compare y x) eqn:?.
    + rewrite compare_Eq in Heqc.
      rewrite Heqc.
      rewrite ?isSome_oro, ?isSome_Some, ?orb_true_r, ?orb_true_l.
      solve_Desc e.
    + clear IHHB2.
      applyDesc e IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s1 y) eqn:?; simpl isSome in *; try lia;
      applyDesc e (@balanceL_Desc e a); solve_Desc e.
    + clear IHHB1.
      applyDesc e IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s2 y) eqn:?; simpl_options; try lia; applyDesc e (@balanceR_Desc e a);
      solve_Desc e.
Qed.

(** ** Verification of [splitLookup] *)

(* Rewrite to avoid local [go] and StrictTriple *)
Fixpoint splitLookup' (k : e) (s : Map e a) : (Map e a * option a * Map e a) :=
  match s with
   | Tip => (Tip, None, Tip)
   | Bin _ kx x l r => match GHC.Base.compare k kx with
     | Lt => match splitLookup' k l with
               | (lt, z, gt) => match link kx x gt r with
                                              | gt' => (lt, z, gt')
                                            end
             end
     | Gt => match splitLookup' k r with
               | (lt, z, gt) => match link kx x l lt with
                                              | lt' => (lt', z, gt)
                                            end
             end
     | Eq => (l, Some x, r)
    end
 end.

Lemma splitLookup_splitLookup' : forall x map, splitLookup x map  = splitLookup' x map.
Proof.
  intros.
  unfold splitLookup.
  induction map.
  * simpl.
    rewrite <- IHmap1. clear IHmap1.
    rewrite <- IHmap2. clear IHmap2.
    destruct (compare x k).
    + reflexivity.
    + destruct (_ x map1); reflexivity.
    + destruct (_ x map2); reflexivity.
  * reflexivity.
Qed.

Lemma splitLookup_Desc:
  forall x s lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * option a * Map e a -> Prop),
  (forall s1 b s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    b = sem s x ->
    (forall i, sem s i =
          (if i == x then sem s i
           else  (sem s1 i ||| sem s2 i))) ->
    P (s1, b, s2)) ->
  P (splitLookup x s) : Prop.
Proof.
  intros ?? ?? HB.
  rewrite splitLookup_splitLookup'.
  induction HB.
  Ltac solveThis e ::= intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e|try reflexivity |f_solver e].
  * solveThis e.
  * simpl.
    destruct (compare x x0) eqn:?.
    + solveThis e.
      replace (x == x0) with true by order_Bounds e.
      simpl_options.
      assert (sem s1 x = None). { eapply sem_outside_above. apply HB1. solve_Bounds e. }
      rewrite H3. simpl. reflexivity.
    + apply IHHB1.
      intros s1_2 b s1_3 HB1_2 HB1_3 Hb Hsems1.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options. assumption.
    + apply IHHB2.
      intros s2_2 b s2_3 HB2_2 HB2_3 Hb Hsems2.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options. assumption.
Qed.

(** ** Verification of [unionWith_Desc] *)
Lemma unionWith_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2 f,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertWithR f x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insertWith f x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match splitLookup x s2 with
      | (l2, mb, r2) =>
      match unionWith f r1 r2 with
      | r1r2 =>
      match unionWith f l1 l2 with
      | l1l2 => match mb with
                |None => link x vx l1l2 r1r2
                | Some y => link x (f vx y) l1l2 r1r2
                end
      end end end)) ->
  P (unionWith f s1 s2).
Proof.
  intros P s1 s2 f HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma unionWith_Desc :
  forall (s1: Map e a) s2 lb ub f,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (unionWith f s1 s2) lb ub (fun i => match sem s1 i, sem s2 i with
                                            |Some x, Some y => Some (f x y)
                                            | Some x, _ => Some x
                                            | _, Some y => Some y
                                            | _, _ => None
                                            end).
Proof.
intros ????? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply unionWith_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      applyDesc e insertWithR_Desc.
      solve_Desc e. f_solver e.
  * apply unionWith_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      applyDesc e insertWithR_Desc.
      solve_Desc e. f_solver e.
      assert (sem s1 x0 = sem s1 i). apply sem_resp_eq. order e. rewrite H1 in Hsem.
      rewrite Heqo0 in Hsem. simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = sem s1 i) by (apply sem_resp_eq; order e). rewrite H1 in Hsem.
      rewrite Heqo0 in Hsem. assert (x0 == x = true) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s2 i = sem s2 x0) by (apply sem_resp_eq; order e).
      rewrite <- H1 in Hsem. rewrite Heqo1 in Hsem.
      assert (sem s1 x0 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H3 in Hsem. assert (x0 == x = false) by (order e). rewrite H4 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. assert (x0 == x = false) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. assert (sem s2 x0 = None). erewrite sem_resp_eq.
      apply Heqo1. order e. rewrite H4 in Hsem. symmetry. assumption.
      assert (sem s1 x0 = Some a0). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H1 in Hsem. assert (x0 == x = true) by (order e). rewrite H3 in Hsem.
      simpl in Hsem. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      assert (x0 == x = false) by (order e). rewrite H1 in Hsem. rewrite H3 in Hsem.
      simpl in Hsem. assert (sem s2 x0 = Some a0). erewrite sem_resp_eq. apply Heqo1.
      order e. rewrite H4 in Hsem. symmetry. assumption.
      destruct (sem s1 x0); simpl in Hsem. inversion Hsem. destruct (x0 == x); simpl in Hsem.
      inversion Hsem. destruct (sem s2 x0); simpl in Hsem; inversion Hsem.
    + inversion H3; subst; clear H3.
      applyDesc e (@insertWith_Desc e a). solve_Desc e. f_solver e;
      assert (sem s3 x0 = sem s3 i) by (apply sem_resp_eq; order e); rewrite <- H1 in Heqo0;
      rewrite Heqo0 in Hsem; symmetry; assumption.
    + inversion H3; subst; clear H3.
      eapply splitLookup_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2. destruct b.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        (*Not using solve_Desc because it was very slow*)
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0;
        rewrite <- Hsem1; assumption.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0; rewrite <-Hsem1; assumption.
Qed.

Require Import Coq.Classes.Morphisms.
(** ** Verification of [insertWithKeyR] *)
(*Need to add assumption that f is proper*)
Lemma insertWithKeyR_Desc:
  forall (f: e -> a -> a -> a) y v (s: Map e a) lb ub,
  Bounded s lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  isLB lb y = true ->
  isUB ub y = true ->
  Desc (insertWithKeyR f y v s) lb ub (if isSome (sem s y) then size s else (1 + size s)%Z)
      (fun i => (if i == y then match (sem s y) with
                                | None => Some v
                                | Some x => Some (f i x v)
                                end  else None ||| sem s i )).
Proof.
  intros ?????? HB HP HLB HUB.
  induction HB; intros.
  * simpl.
    applyDesc e (@singleton_Desc e a); try eassumption; solve_Desc e.
  * subst; cbn -[Z.add].
    destruct (compare y x) eqn:?.
    + rewrite compare_Eq in Heqc.
      rewrite Heqc.
      rewrite ?isSome_oro, ?isSome_Some, ?orb_true_r, ?orb_true_l.
      solve_Desc e. f_solver e. assert (f x v0 v = f i v0 v). apply equal_f.
      apply equal_f. apply HP. order e. rewrite H1. reflexivity.
    + clear IHHB2.
      applyDesc e IHHB1.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s1 y) eqn:?; simpl isSome in *; try lia;
      applyDesc e (@balanceL_Desc e a); solve_Desc e.
    + clear IHHB1.
      applyDesc e IHHB2.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      replace (y == x) with false by order_Bounds e.
      simpl_options. destruct (sem s2 y) eqn:?; simpl_options; try lia; applyDesc e (@balanceR_Desc e a);
      solve_Desc e.
Qed.

(** ** Verification of [unionWithKey] *)

Lemma unionWithKey_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2 f,
  (s2 = Tip -> P s1) ->
  (s1 = Tip -> P s2) ->
  (forall sz2 x vx, (s2 = Bin sz2 x vx Tip Tip) -> P (insertWithKeyR f x vx s1)) ->
  (forall sz1 x vx, (s1 = Bin sz1 x vx Tip Tip) -> P (insertWithKey f x vx s2)) ->
  (forall sz1 x vx l1 r1, (s1 = Bin sz1 x vx l1 r1) ->
    P (
      match splitLookup x s2 with
      | (l2, mb, r2) =>
      match unionWithKey f r1 r2 with
      | r1r2 =>
      match unionWithKey f l1 l2 with
      | l1l2 => match mb with
                |None => link x vx l1l2 r1r2
                | Some y => link x (f x vx y) l1l2 r1r2
                end
      end end end)) ->
  P (unionWithKey f s1 s2).
Proof.
  intros P s1 s2 f HTipR HTipL HSingletonR HSingletonL HBins.
  destruct s1, s2; simpl union;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HSingletonL; reflexivity
        | eapply HSingletonR; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Lemma unionWithKey_Desc :
  forall (s1: Map e a) s2 lb ub f,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  Desc' (unionWithKey f s1 s2) lb ub (fun i => match sem s1 i, sem s2 i with
                                            |Some x, Some y => Some (f i x y)
                                            | Some x, _ => Some x
                                            | _, Some y => Some y
                                            | _, _ => None
                                            end).
Proof.
intros ????? HB1 HB2 HP.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  * apply unionWithKey_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      clear H4 H5.
      (* We need to give [applyDesc] a hint about the bounds that we care about: *)
      assert (Bounded (@Tip e a) lb ub) by constructor.
      eapply insertWithKeyR_Desc. apply H. apply HP. assumption. assumption. intros.
      solve_Desc e. f_solver e.
  * apply unionWithKey_destruct; intros; subst; try congruence.
    + solve_Desc e. f_solver e.
    + inversion HB3; subst; clear HB3.
      eapply insertWithKeyR_Desc. solve_Bounded e. apply HP. assumption. assumption. intros.
      solve_Desc e. f_solver e.
      assert (sem s1 x0 = sem s1 i). apply sem_resp_eq. order e. rewrite H5 in H4.
      rewrite Heqo0 in H4. simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = sem s1 i) by (apply sem_resp_eq; order e). rewrite H5 in H4.
      rewrite Heqo0 in H4. assert (x0 == x = true) by (order e). rewrite H6 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s2 i = sem s2 x0) by (apply sem_resp_eq; order e).
      rewrite <- H5 in H4. rewrite Heqo1 in H4.
      assert (sem s1 x0 = None). eapply sem_outside_above. eassumption. solve_Bounds e.
      rewrite H6 in H4. assert (x0 == x = false) by (order e). rewrite H9 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. assert (x0 == x = false) by (order e). rewrite H6 in H4.
      simpl in H4. assert (sem s2 x0 = None). erewrite sem_resp_eq.
      apply Heqo1. order e. rewrite H9 in H4. symmetry. assumption.
      assert (sem s1 x0 = Some a0). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      rewrite H5 in H4. assert (x0 == x = true) by (order e). rewrite H6 in H4.
      simpl in H4. symmetry. assumption.
      assert (sem s1 x0 = None). erewrite sem_resp_eq. apply Heqo0. order e.
      assert (x0 == x = false) by (order e). rewrite H6 in H4. rewrite H5 in H4.
      simpl in H4. assert (sem s2 x0 = Some a0). erewrite sem_resp_eq. apply Heqo1.
      order e. rewrite H9 in H4. symmetry. assumption.
      destruct (sem s1 x0); simpl in H4. inversion H4. destruct (x0 == x); simpl in H4.
      inversion H4. destruct (sem s2 x0); simpl in H4; inversion H4.
    + inversion H3; subst; clear H3.
      applyDesc e (@insertWithKey_Desc e a). solve_Desc e. f_solver e;
      assert (sem s3 x0 = sem s3 i) by (apply sem_resp_eq; order e); rewrite <- H1 in Heqo0.
      destruct (sem s3 x0). assert (f x0 vx a2 = f i vx a2). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. symmetry. assumption.
      rewrite <- Hsem. assumption.
      destruct (sem s3 x0). assert (f x0 vx a1 = f i vx a1). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. inversion Hsem.
      rewrite Heqo0 in Hsem. inversion Hsem.
      destruct (sem s3 x0). assert (f x0 vx a1 = f i vx a1). apply equal_f. apply equal_f.
      apply HP. order e. rewrite H3 in Hsem. rewrite Heqo0 in Hsem. inversion Hsem.
      rewrite Heqo0 in Hsem. inversion Hsem.
    + inversion H3; subst; clear H3.
      eapply splitLookup_Desc; try eassumption.
      intros.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2. destruct b.
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        (*Not using solve_Desc because it was very slow*)
        solve_Bounded e. f_solver e.
        assert (f x0 vx a0 = f i vx a0). apply equal_f. apply equal_f. apply HP. order e.
        rewrite H4. reflexivity.
        all : (rewrite H5 in Hsem0; rewrite <- Hsem1; assumption).
      - applyDesc e (@link_Desc e a). apply showDesc'. split.
        solve_Bounded e. f_solver e; rewrite H5 in Hsem0; rewrite <-Hsem1; assumption.
Qed.

(** ** Verification of [unionsWith] *)
Lemma unionsWith_Desc:
  forall (ss: list (Map e a)) f lb ub,
  Forall (fun s => Bounded s lb ub) ss ->
  Desc' (unionsWith f ss) lb ub (fun i => fold_left (fun t h => match t with
                                                                 | Some y =>
                                                                   match (sem h i) with
                                                                    | Some x => Some (f y x)
                                                                    | _ => t
                                                                   end
                                                                  | _ => (sem h i)
                                                                  end) ss None).
Proof.
  intros.
  unfold unionsWith.
  (* Switch to a fold right *)
  rewrite Proofs.Data.Foldable.hs_coq_foldl'_list.
  rewrite <- fold_left_rev_right.
  rewrite <- (rev_involutive ss).
  rewrite <- (rev_involutive ss), Forall_rev in H.
  generalize dependent (rev ss). intros.
  rewrite rev_involutive.

  induction H.
  * simpl. applyDesc e (@empty_Desc e a). solve_Desc e. f_solver e.
  * simpl fold_right.
    applyDesc e IHForall.
    applyDesc e unionWith_Desc.
    solve_Desc e.
    intro i.
    rewrite Hsem0, Hsem. simpl. rewrite fold_left_app. simpl. destruct (fold_left
    (fun (t : option a) (h : Map e a) =>
     match t with
     | Some y => match sem h i with
                 | Some x0 => Some (f  y x0)
                 | None => t
                 end
     | None => sem h i
     end) (rev l) None); destruct (sem x i ) eqn : ?; reflexivity.
Qed.

(** ** Verification of [link2] *)

(** This is called  [merge] for Set *)

Lemma link2_eq: forall (l r: Map e a), link2 l r =
  match l, r with
  | Tip, r => r
  | l, Tip => l
  | (Bin sizeL x vx lx rx as l), (Bin sizeR y vy ly ry as r) =>
    if Sumbool.sumbool_of_bool
         ((delta GHC.Num.* sizeL) GHC.Base.< sizeR)
    then balanceL y vy (link2 l ly) ry
    else if Sumbool.sumbool_of_bool
              ((delta GHC.Num.* sizeR) GHC.Base.< sizeL)
         then balanceR x vx lx (link2 rx r)
         else glue l r
  end.
Proof.
  intros l r.
  destruct l; [|auto].
  destruct r; [|auto].
  unfold link2 at 1, link2_func at 1;
  lazymatch goal with
    |- Wf.Fix_sub ?A ?R ?Rwf ?P ?F_sub ?x = ?rhs =>
    apply (@Wf.WfExtensionality.fix_sub_eq_ext A R Rwf P F_sub x)
  end.
Qed.

Program Fixpoint link2_Desc (s1: Map e a)  (s2: Map e a)
  {measure (map_size s1 + map_size s2)} :
    forall x lb ub,
      Bounded s1 lb (Some x) ->
      Bounded s2 (Some x) ub  ->
      isLB lb x = true ->
      isUB ub x = true->
      Desc (link2 s1 s2) lb ub (size s1 + size s2)
           (fun i => sem s1 i ||| sem s2 i)
  := _.
Next Obligation.
  intros.
  rewrite link2_eq.
  inversion H; subst; clear H;
    inversion H0; subst; clear H0;
      try solve [solve_Desc e].
  destruct (Sumbool.sumbool_of_bool _);
    only 2: destruct (Sumbool.sumbool_of_bool _);
    rewrite ?Z.ltb_lt, ?Z.ltb_ge in *.
  - applyDesc e link2_Desc.
    applyDesc e (@balanceL_Desc e a). rewrite size_Bin in Hsz. solve_size.
    solve_Desc e.
  - applyDesc e link2_Desc.
    applyDesc e (@balanceR_Desc e a). rewrite size_Bin in Hsz. solve_size.
    solve_Desc e.
  - applyDesc e (@glue_Desc e a).
    solve_Desc e.
Qed.

(** ** Verification of [splitMember] *)

(* Rewrite to avoid local [go] and StrictTriple *)
Fixpoint splitMember' (k : e) (s : Map e a) : (Map e a * bool * Map e a)%type :=
  match s with
   | Tip => (Tip, false, Tip)
   | Bin _ kx x l r => match GHC.Base.compare k kx with
     | Lt => match splitMember' k l with
               | (lt, z, gt) => match link kx x gt r with
                                              | gt' => (lt, z, gt')
                                            end
             end
     | Gt => match splitMember' k r with
               | (lt, z, gt) => match link kx x l lt with
                                              | lt' => (lt', z, gt)
                                            end
             end
     | Eq => (l, true, r)
    end
 end.

Lemma splitMember_splitMember' : forall x s, splitMember x s  = splitMember' x s.
Proof.
  intros.
  unfold splitMember.
  induction s.
  * simpl.
    rewrite <- IHs1. clear IHs1.
    rewrite <- IHs2. clear IHs2.
    destruct (compare x k).
    + reflexivity.
    + destruct (_ x s2); reflexivity.
    + destruct (_ x s3); reflexivity.
  * reflexivity.
Qed.

Lemma splitMember_Desc:
  forall x s lb ub,
  Bounded s lb ub ->
  forall (P : Map e a * bool * Map e a -> Prop),
  (forall s1 b s2,
    Bounded s1 lb (Some x) ->
    Bounded s2 (Some x) ub ->
    b = isSome (sem s x) ->
    (forall i, sem s i =
          (if i == x then sem s i
           else  (sem s1 i ||| sem s2 i))) ->
    P (s1, b, s2)) ->
  P (splitMember x s) : Prop.
Proof.
  intros ?? ?? HB.
  rewrite splitMember_splitMember'.
  induction HB.
  Ltac solveThis e ::= intros X HX; apply HX; clear X HX; [solve_Bounded e|solve_Bounded e|try reflexivity |f_solver e].
  * solveThis e.
  * simpl.
    destruct (compare x x0) eqn:?.
    + solveThis e.
      replace (x == x0) with true by order_Bounds e.
      simpl_options.
      reflexivity.
    + apply IHHB1.
      intros s1_2 b s1_3 HB1_2 HB1_3 Hb Hsems1.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_below HB2) by order_Bounds e.
      simpl_options. assumption.
    + apply IHHB2.
      intros s2_2 b s2_3 HB2_2 HB2_3 Hb Hsems2.
      clear IHHB1 IHHB2.
      applyDesc e (@link_Desc e a).
      solveThis e.
      replace (x == x0) with false by order_Bounds e.
      rewrite (sem_outside_above HB1) by order_Bounds e.
      simpl_options. assumption.
Qed.

(** ** Verification of [intersection] *)

Lemma intersection_Desc:
  forall (s1: Map e a) s2 lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (intersection s1 s2) lb ub
        (fun i => sem s1 i &&& sem s2 i).
Proof.
  intros ???? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. f_solver e.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 a0 m1 m2.
      eapply splitMember_Desc;
        only 1: eassumption.
      intros s4' b s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct b.
      * destruct_ptrEq.
        -- solve_Desc e. f_solver e.
        -- applyDesc e (@link_Desc e a).
           solve_Desc e. f_solver e.
      * applyDesc e link2_Desc.
        solve_Desc e. f_solver e.
    + solve_Desc e. f_solver e.
Qed.

(** Verificataion of [intersectionWith] *)
Lemma intersectionWith_Desc:
  forall (s1: Map e a) (s2: Map e a) (f: a -> a -> a) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Desc' (intersectionWith f s1 s2) lb ub
        (fun i => match (sem s1 i), (sem s2 i) with
                  | Some x, Some b => Some (f x b)
                  | _, _ => None end).

Proof.
  intros ????? HB1 HB2.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. f_solver e.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 a0 m1 m2.
      eapply splitLookup_Desc;
        only 1: eassumption.
      intros s4' b s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct b.
      applyDesc e (@link_Desc e a).
      (*Also taking long see*)
      apply showDesc'. split. solve_Bounded e. f_solver e; rewrite Hi in Hsem0;
      rewrite <- Hsem1; assumption.
      applyDesc e link2_Desc.
      apply showDesc'. split. solve_Bounded e. f_solver e; rewrite Hi in Hsem0;
      rewrite <-Hsem1; assumption.
    + solve_Desc e. f_solver e.
Qed.

(** ** Veritication of [intersectionWithKey] *)

(*Had to add assumption that f is Proper*)

Lemma intersectionWithKey_Desc:
  forall (s1: Map e a) s2 (f: e -> a -> a -> a) lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f ->
  Desc' (intersectionWithKey f s1 s2) lb ub
        (fun i => match (sem s1 i), (sem s2 i) with
                  | Some a, Some b => Some (f i a b)
                  | _, _ => None end).

Proof.
  intros ????? HB1 HB2 HP.
  revert s2 HB2.
  induction HB1; intros s3 HB3.
  - simpl. solve_Desc e. reflexivity.
  - simpl.
    destruct s3 eqn:Hs3.
    + rewrite <- Hs3 in *.
      clear Hs3 s e0 a0 m1 m2.
      eapply splitLookup_Desc;
        only 1: eassumption.
      intros s4' b s5' HB1 HB2 Hb Hi.
      applyDesc e IHHB1_1.
      applyDesc e IHHB1_2.
      destruct b.
      applyDesc e (@link_Desc e a).
      (*Also taking long see*)
      apply showDesc'. split. solve_Bounded e. f_solver e.
      assert (f x v a0 = f i v a0). apply equal_f. apply equal_f. apply HP. order e.
      rewrite H1. reflexivity.
      all :( try (rewrite Hi in Hsem0;
      rewrite <- Hsem1; assumption)).
      applyDesc e link2_Desc.
      apply showDesc'. split. solve_Bounded e. f_solver e; rewrite Hi in Hsem0;
      rewrite <-Hsem1; assumption.
    + solve_Desc e. f_solver e.
Qed.

(** ** Verification of [difference] *)

(** A wart: Because we are in a section that fixes [a],
we get this proof only for invocations of [difference] where
boths maps have the same element type. This does not
affect the proof, but requires some Coq proof structure engineering
to fix. *)

Lemma difference_destruct :
  forall (P : Map e a -> Prop),
  forall s1 s2,
  (s1 = Tip -> P Tip) ->
  (s2 = Tip -> P s1) ->
  (forall sz2 x vx l2 r2, (s2 = Bin sz2 x vx l2 r2) ->
    P (
      match split x s1 with
      | pair l1 r1 =>
      match difference r1 r2 with
      | r1r2 =>
      match difference l1 l2 with
      | l1l2 => if size l1l2 + size r1r2 == size s1
                then s1 else link2 l1l2 r1r2
      end end end)) ->
  P (@difference e a a _ _ s1 s2).
Proof.
  intros P s1 s2 HTipL HTipR HBins.
  destruct s1, s2; simpl difference;
  try destruct s1_1, s1_2;
  try destruct s2_1, s2_2;
  first [ eapply HBins; reflexivity
        | eapply HTipL; reflexivity
        | eapply HTipR; reflexivity
        | idtac
        ].
Qed.

Require Import Coq.Program.Tactics.

Open Scope Z_scope.

Lemma difference_Desc :
  forall (s1: Map e a) s2 lb ub,
  Bounded s1 lb ub ->
  Bounded s2 lb ub ->
  forall (P : Map e a -> Prop),
  (forall s,
    Bounded s lb ub ->
    size s <= size s1 ->
    (size s = size s1 -> forall i, sem s i = sem s1 i) ->
    (forall i, sem s i = diffo (sem s1 i) (sem s2 i)) ->
    P s) ->
  P (difference s1 s2).
Proof.
  intros s1 s2 lb ub Hb1 Hb2.
  revert s1 Hb1. induction Hb2; intros sl Hb1; apply hide.
  Ltac showP := apply unhide; intros X HX; apply HX; clear X HX; only 3: intro.
  - simpl.
    destruct sl; (showP; [assumption | reflexivity | reflexivity | f_solver e]).
  - apply difference_destruct; intros; subst.
    + (showP; [assumption | order Z | reflexivity | f_solver e]).
    + (showP; [assumption | order Z | reflexivity | f_solver e]).
    + eapply split_Desc; try eassumption.
      intros sl1 sl2 HBsl1 HBsl2 Hsz Hsem. inversion H3; subst; clear H3.
      eapply IHHb2_1. solve_Bounded e. intros sil ????. clear IHHb2_1.
      eapply IHHb2_2. solve_Bounded e. intros sir ????. clear IHHb2_2.
      destruct (_ == _) eqn:Hcomp.
      * showP; [assumption | reflexivity | reflexivity | ].
        assert (size sl1 + size sl2 <= size sl) by (destruct (sem sl x0); simpl in *;  lia).
        change (size sil + size sir =? size sl = true) in Hcomp.
        rewrite Z.eqb_eq in Hcomp.
        lapply H4; [intro; subst; clear H4|lia].
        lapply H8; [intro; subst; clear H8|lia].
        assert (sem sl x0 = None) by (destruct (sem sl x0); simpl in *; try reflexivity; lia).
        f_solver e. (* TODO: More stuff that [f_solver] should do *)
      * applyDesc e link2_Desc.
        showP.
        -- assumption.
        -- destruct (sem sl x0); simpl in *; lia.
        -- assert (sem sl x0 = None) by (destruct (sem sl x0); simpl in *; try reflexivity; lia).
           rewrite H11 in Hsz.
           simpl in Hsz.
           lapply H4; [intro; subst|lia].
           lapply H8; [intro; subst|lia].
           clear H4 H8.
           f_solver e.
        -- f_solver e.
Qed.

End WF.


(* An example showing that prop-extensionality is incompatible with
   powerful extensions of the guard condition.
   This is a variation on the example in subterm2, exploiting
   missing typing constraints in the commutative cut subterm rule
   (subterm2 is using the same flaw but for the match rule).

   Example due to Cristóbal Camarero on Coq-Club.
 *)

Axiom prop_ext: forall P Q, (P <-> Q) -> P=Q.

Inductive True2 : Prop := I3 : (False -> True2) -> True2.

Theorem T3T: True2 = True.
Proof.
apply prop_ext; split; auto.
intros; constructor; apply False_rect.
Qed.

Theorem T3F_FT3F : (True2 -> False) = ((False -> True2) -> False).
Proof.
rewrite T3T.
apply prop_ext; split; auto.
Qed.

Fail Fixpoint loop (x : True2) : False :=
match x with
I3 f => (match T3F_FT3F in _=T return T with eq_refl=> loop end) f
end.


From MonadicEffect Require Import Typ Heap.
From mathcomp Require Import ssrbool ssrnat eqtype ssreflect.

From ExtLib Require Import Structures.Monads Data.Monads.StateMonad.
Import MonadNotation.
Open Scope monad_scope.

Require Coq.Program.Wf.

Set Implicit Arguments.

Program Fixpoint sum_up (r : ref Int)
         (from : const Int)
         (to : {t : const Int | from <= t})
         { measure (to - from) } : Heap (const Int) :=
  match from < to with
  | true =>
    v <- #r;;
    r ::= v + from;;
    sum_up r from.+1 to
  | _ => #r
  end.
Next Obligation.
  apply /ltP. apply ltn_sub2l =>//.
Qed.

Program Fixpoint sum_dn (r : ref Int)
         (from : const Int)
         (to : {t : const Int | from <= t})
         { measure (to - from) } : Heap (const Int) :=
  match from < to with
  | true =>
    v <- #r;;
    r ::= v + to.-1;;
    sum_up r from to.-1
  | _ => #r
  end.
Next Obligation.
  rewrite -ltnS /= prednK =>//.
  induction to. discriminate. auto.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e140m27_3limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Cover.
Require Import Pred.
Require Import Trace.

Require Import MemoryProps.
Require Import Mapping.

Set Implicit Arguments.

Section GOODFUTURE.

  Record good_future (tm: TimeMap.t) (mem0 mem1: Memory.t): Prop :=
    {
      good_future_future: Memory.future_weak mem0 mem1;
      good_future_cover:
        forall loc ts (COVERED: covered loc ts mem1),
          (<<COVERED: covered loc ts mem0>>) \/
          (<<TS: Time.lt (tm loc) ts>>);
    }.

  Lemma good_future_mon tm0 tm1
        (TM: TimeMap.le tm0 tm1)
    :
      good_future tm1 <2= good_future tm0.
  Proof.
    ii. econs.
    { eapply PR. }
    { i. eapply PR in COVERED. des; auto.
      right. eapply TimeFacts.le_lt_lt; eauto.
    }
  Qed.

  Global Program Instance good_future_PreOrder tm: PreOrder (good_future tm).
  Next Obligation.
    ii. econs; eauto. refl.
  Qed.
  Next Obligation.
    ii. econs.
    { etrans.
      { eapply H. }
      { eapply H0. }
    }
    { i. eapply H0 in COVERED. des; auto.
      eapply H in COVERED0. auto. }
  Qed.

  Record good_future_map (max tm: TimeMap.t)
         (times: Loc.t -> list Time.t)
         (f: Loc.t -> Time.t -> Time.t -> Prop): Prop :=
    {
      good_future_map_map_lt:
        mapping_map_lt_iff f;
      good_future_map_map_bot:
        mapping_map_bot f;
      good_future_map_ident:
        forall loc ts (TS: Time.le ts (max loc)),
          f loc ts ts;
      good_future_map_bound:
        forall loc ts fts
               (MAP: f loc ts fts),
          Time.lt fts (tm loc);
      good_future_map_complete:
        forall loc ts (IN: List.In ts (times loc)),
          mappable_time f loc ts;
    }.

  Lemma good_future_map_exists max tm times
        (TM: forall loc, Time.lt (max loc) (tm loc))
    :
      exists f,
        (<<MAP: good_future_map max tm times f>>).
  Proof.
    hexploit (@choice
                Loc.t (Time.t -> Time.t -> Prop)
                (fun loc f =>
                   (<<MAPLT: mapping_map_lt_iff_loc f>>) /\
                   (<<IDENT: forall ts (TS: Time.le ts (max loc)),
                       f ts ts>>) /\
                   (<<MAX: forall ts fts
                                  (MAP: f ts fts),
                       Time.lt fts (tm loc)>>) /\
                   (<<COMPLETE: forall ts (IN: List.In ts (times loc)),
                       exists fts, (<<MAP: f ts fts>>)>>))).
    { intros loc.
      hexploit (@shift_map_exists
                  (max loc) (max loc) (tm loc)
                  (times loc)); ss.
      { refl. } intros [f SPEC]. exists f. des. splits; auto.
      { i. destruct (Time.le_lt_dec ts (max loc)).
        { exploit mapping_map_lt_iff_loc_map_eq.
          { eapply MAPLT. }
          { eapply MAP. }
          { eapply SAME; eauto. }
          i. subst. eapply TimeFacts.le_lt_lt; eauto.
        }
        { eapply BOUND in MAP; auto. des. auto. }
      }
    }
    intros [f SPEC]. exists f. econs.
    { eapply mapping_map_lt_iff_locwise.
      i. specialize (SPEC loc). des. auto. }
    { ii. specialize (SPEC loc). des.
      eapply IDENT. eapply Time.bot_spec. }
    { i. specialize (SPEC loc). des. auto. }
    { i. specialize (SPEC loc). des. eauto. }
    { i. specialize (SPEC loc). des.
      exploit COMPLETE; eauto. }
  Qed.

  Lemma good_future_memory_map mem0 mem1 tm times f
        (FUTURE: good_future tm mem0 mem1)
        (MEM: Memory.closed mem0)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem0) (tm loc))
        (MAP: good_future_map (Memory.max_timemap mem0) tm times f)
    :
      memory_map f mem0 mem1.
  Proof.
    econs.
    { i. destruct (classic (msg = Message.reserve)); auto. right.
      exploit Memory.future_weak_get1; try eapply FUTURE; eauto. i. des.
      exists to, from', msg, msg'. splits; auto.
      { eapply good_future_map_ident; eauto.
        eapply Memory.max_ts_spec in GET. des. eauto. }
      { eapply map_ident_in_memory_closed_message.
        { ii. eapply (good_future_map_ident MAP). eapply TS. }
        { eapply MEM in GET. des. auto. }
      }
    }
    { i. destruct (Time.le_lt_dec fto (Memory.max_ts loc mem0)).
      { left. exists fto, ffrom, fto, ffrom. splits; auto.
        { eapply (good_future_map_ident MAP); eauto. }
        { refl. }
        { refl. }
        { eapply (good_future_map_ident MAP); eauto.
          eapply memory_get_ts_le in GET. etrans; eauto.
        }
        { i. exploit (good_future_cover FUTURE).
          { econs; eauto. }
          i. des; auto.
          exfalso. inv ITV. ss.
          eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply TS. } etrans.
          { eapply TO. } etrans.
          { eapply l. }
          { left. auto. }
        }
      }
      { right. destruct (Time.le_lt_dec (tm loc) ffrom).
        { ii. eapply (good_future_map_bound MAP) in MAP0.
          eapply TimeFacts.lt_le_lt; eauto. }
        { exfalso. exploit (good_future_cover FUTURE).
          { econs; try apply GET.
            instantiate (1:=Time.meet (tm loc) fto). econs; ss.
            { unfold Time.meet. des_ifs.
              apply memory_get_ts_strong in GET. des; auto.
              subst. inv l. }
            { eapply Time.meet_r. }
          }
          { i. des.
            { inv COVERED. inv ITV; ss.
              apply Memory.max_ts_spec in GET0. des.
              eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply TO. } eapply TimeFacts.le_lt_lt.
              { eapply MAX. }
              unfold Time.meet. des_ifs.
            }
            { eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
              { eapply TS. }
              { eapply Time.meet_l. }
            }
          }
        }
      }
    }
  Qed.

  Lemma step_write_not_in_good_future P lang (th0 th1: Thread.t lang) tm e
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: pred_step P e th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: P <1= write_not_in (fun loc ts =>
                                      (<<TS: Time.le ts (tm loc)>>) /\
                                      (<<PROM: ~ covered loc ts (Thread.memory th0)>>)))
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      inv STEPS. inv STEP.
      exploit Thread.step_future; eauto. i. des. auto. }
    { i. inv STEPS. inv STEP.
      eapply step_write_not_in_covered in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma steps_write_not_in_good_future P lang (th0 th1: Thread.t lang) tm
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: rtc (tau (@pred_step P lang)) th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: P <1= write_not_in (fun loc ts =>
                                      (<<TS: Time.le ts (tm loc)>>) /\
                                      (<<PROM: ~ covered loc ts (Thread.memory th0)>>)))
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      eapply thread_steps_pred_steps in STEPS.
      exploit Thread.rtc_tau_step_future; eauto. i. des. auto. }
    { i. eapply steps_write_not_in_covered in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma write_not_in_good_future_traced lang (th0 th1: Thread.t lang) tr tm
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: Trace.steps tr th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: List.Forall (fun em =>
                               write_not_in (fun loc ts =>
                                               (<<TS: Time.le ts (tm loc)>>) /\
                                               (<<PROM: ~ covered loc ts (Thread.memory th0)>>)) (snd em)) tr)
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      eapply Trace.steps_future; eauto. }
    { i. eapply write_not_in_covered_traced in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma max_good_future_map (mem mem_good: Memory.t) (tm: TimeMap.t)
        (FUTURE: good_future tm mem mem_good)
        (CLOSED: Memory.closed mem)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem) (tm loc))
    :
      memory_map
        (fun loc ts fts => ts = fts /\ Time.lt ts (tm loc))
        mem
        mem_good.
  Proof.
    assert (IDENT: map_ident_in_memory (fun loc ts fts => ts = fts /\ Time.lt ts (tm loc)) mem).
    { ii. split; auto. eapply TimeFacts.le_lt_lt; eauto. }
    econs.
    { i. destruct (classic (msg = Message.reserve)); auto.
      exploit Memory.max_ts_spec; try apply GET; eauto. i. des. dup GET.
      eapply (good_future_future FUTURE) in GET; eauto.
      destruct GET as [from' [msg' [GET [FROM MSG]]]]. guardH MSG.
      right. esplits.
      { ss. }
      { eapply TimeFacts.le_lt_lt; eauto. }
      { eapply map_ident_in_memory_closed_message; eauto.
        eapply CLOSED; eauto. }
      { instantiate (1:=msg'). unguard. des; auto. subst. refl. }
      { eauto. }
    }
    { i. destruct (Time.le_lt_dec (tm loc) ffrom).
      { right. ii. des. subst. eapply TimeFacts.lt_le_lt; eauto.  }
      { assert (TS: Time.lt fto (tm loc)).
        { destruct (Time.le_lt_dec (tm loc) fto); auto. exfalso.
          exploit (good_future_cover FUTURE).
          { instantiate (1:=Time.middle (Time.join (Memory.max_ts loc mem) ffrom) (tm loc)).
            instantiate (1:=loc).
            econs; eauto. econs; ss.
            { eapply TimeFacts.le_lt_lt.
              { eapply Time.join_r. }
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
            { transitivity (tm loc); auto. left. eapply Time.middle_spec.
              unfold Time.join. des_ifs. }
          }
          { i. des.
            { inv COVERED. inv ITV. ss.
              eapply Memory.max_ts_spec in GET0. des.
              exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply TO. } eapply TimeFacts.le_lt_lt.
              { eapply MAX. } eapply TimeFacts.le_lt_lt.
              { eapply Time.join_l. }
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
            { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
              { eapply TS. } left.
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
          }
        }
        left. exists fto, ffrom, fto, ffrom. splits; auto; try refl.
        i. exploit (good_future_cover FUTURE).
        { econs; eauto. }
        i. des; auto. inv ITV. ss.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply TS. } etrans.
        { left. eapply TS0. }
        auto.
      }
    }
  Qed.

End GOODFUTURE.


Require Problem.
Require Solution.

Theorem checker : Problem.task.
Proof.
  exact (Solution.solution).
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^222 - 117
Base: 22.2
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 22 + 1/5;
    bitwidth := 32;
    s := 2^222;
    c := [(1, 117)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.