Require Import FloydSeq.base2.
Require Import FloydSeq.canon.
Require Import FloydSeq.entailer.
Require Import Coq.Lists.List.
Export ListNotations.
Require Import FloydSeq.client_lemmas.
Require Import CSplit.strong.

Local Open Scope logic.

Module ZOrder <: Orders.TotalLeBool.
  Definition t := Z.
  Definition leb := Z.leb.
  Theorem leb_total : forall a1 a2, Z.leb a1 a2 = true \/ Z.leb a2 a1 = true.
  Proof.  intros. destruct (Zle_bool_total a1 a2); auto. Qed.
End ZOrder.
Module SortZ := Mergesort.Sort(ZOrder).

Module NatOrder <: Orders.TotalLeBool.
  Definition t := nat.
  Definition leb := Nat.leb.
  Theorem leb_total : forall a1 a2, Nat.leb a1 a2 = true \/ Nat.leb a2 a1 = true.
  Proof.  intros.
    pose proof (Nat.leb_spec a1 a2).
    pose proof (Nat.leb_spec a2 a1).
    inv H; inv H0; auto; omega.
  Qed.
End NatOrder.
Module SortNat := Mergesort.Sort(NatOrder).

Module Type FREEZER.
Parameter FRZ : mpred -> mpred.
Parameter FRZ1: forall p, p |-- FRZ p.
Parameter FRZ2: forall p, FRZ p |-- p.

Parameter FRZL : list mpred -> mpred.
Parameter FRZL1: forall ps, fold_right sepcon emp ps |-- FRZL ps.
Parameter FRZL2: forall ps, FRZL ps |-- fold_right sepcon emp ps.

Parameter FRZRw : list mpred -> list mpred -> Type.
Parameter FRZRw_constr : forall {L1 G1: list mpred} {F: mpred},
    (fold_right sepcon emp G1) |-- fold_right sepcon emp L1 * F -> FRZRw L1 G1.
Parameter FRZR : forall L1 G1 {w: FRZRw L1 G1}, mpred.
Parameter FRZR1: forall L1 G1 (w: FRZRw L1 G1), fold_right sepcon emp G1 |-- fold_right sepcon emp L1 * @FRZR L1 G1 w.
Parameter FRZR2: forall L1 G1 L2 G2 F H, F |-- fold_right sepcon emp L2 -* fold_right sepcon emp G2 -> fold_right sepcon emp L2  * @FRZR L1 G1 (@FRZRw_constr L1 G1 F H) |-- fold_right sepcon emp G2.

End FREEZER.

Module Freezer : FREEZER.
Definition FRZ (p: mpred) := p.
Lemma FRZ1 p: p |-- FRZ p. apply derives_refl. Qed.
Lemma FRZ2 p: FRZ p |-- p. apply derives_refl. Qed.

Definition FRZL (ps:list mpred): mpred := fold_right sepcon emp ps.
Lemma FRZL1 ps: (fold_right_sepcon ps) |-- FRZL ps. apply derives_refl. Qed.
Lemma FRZL2 ps: FRZL ps |-- fold_right_sepcon ps. apply derives_refl. Qed.

Inductive FRZRw' (L1 G1: list mpred): Type :=
| FRZRw'_constr: forall F: mpred,
    (fold_right sepcon emp G1) |-- fold_right sepcon emp L1 * F -> FRZRw' L1 G1.

Definition FRZRw := FRZRw'.
Definition FRZRw_constr:= FRZRw'_constr.

Definition FRZR (L1 G1: list mpred) {w: FRZRw L1 G1}: mpred :=
  match w with
  | FRZRw'_constr F _ => F
  end.

Lemma FRZR1: forall L1 G1 (w: FRZRw L1 G1), fold_right sepcon emp G1 |-- fold_right sepcon emp L1 * @FRZR L1 G1 w.
Proof. intros ? ? [? ?]. auto. Qed.

Lemma FRZR2: forall L1 G1 L2 G2 F H, F |-- fold_right sepcon emp L2 -* fold_right sepcon emp G2 -> fold_right sepcon emp L2 * @FRZR L1 G1 (@FRZRw_constr L1 G1 F H) |-- fold_right sepcon emp G2.
Proof. intros ? ? ? ? ? ? ?. rewrite sepcon_comm. apply wand_sepcon_adjoint; auto. Qed.

End Freezer.

Notation FRZ := Freezer.FRZ.
Notation FRZL := Freezer.FRZL.
Notation FRZR := Freezer.FRZR.
Notation FRZRw := Freezer.FRZRw.

(************************ Freezing a single mpred ************************)
Lemma FRZ_ax:forall p, FRZ p = p.
Proof. intros. apply pred_ext. apply Freezer.FRZ2. apply Freezer.FRZ1. Qed.

Fixpoint freeze_nth (n: nat) (al: list mpred) {struct n}: list mpred :=
 match n, al with
 | O , a::al => (FRZ a) ::al
 | S n', a::al' => a :: freeze_nth n' al'
 | _, nil => nil
 end.

Lemma freeze1_SEP':
 forall n Espec {cs: compspecs} Delta P Q R c Post,
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (freeze_nth n R)))) c Post ->
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
intros. subst.
eapply semax_pre; try apply H.
apply andp_left2.
go_lowerx; entailer!.  clear.
generalize dependent R.
induction n; destruct R; simpl; cancel. apply Freezer.FRZ1.
Qed.
Tactic Notation "freeze1_SEP" constr(n) :=
  eapply (freeze1_SEP' (Z.to_nat n)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) :=
  (gather_SEP' (n::m::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k)  :=
  (gather_SEP' (n::m::k::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k)  constr(p) :=
  (gather_SEP' (n::m::k::p::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.
Tactic Notation "freeze1_SEP" constr(n) constr(m) constr(k) constr(p) constr(q) :=
  (gather_SEP' (n::m::k::p::q::nil)); eapply (freeze1_SEP' (Z.to_nat 0)); simpl.

(*******************freezing a list of mpreds ******************************)

Fixpoint delete_list {A: Type} (ns: list nat) (xs: list A) : list A :=
 (* ns must already be sorted *)
 match ns with
 | nil => xs
 | n::ns' => delete_nth n (delete_list ns' xs)
 end.

Definition freezelist_nth (ns: list nat) (al: list mpred) : list mpred * list mpred :=
  (map (fun i => my_nth i al emp) ns,
   delete_list (SortNat.sort ns) al).

Lemma my_nth_delete_nth_permutation:
  forall al a,
   (a < length al)%nat -> Permutation al (my_nth a al emp :: delete_nth a al).
Proof.
induction al; simpl; intros.
omega.
destruct a0; simpl.
apply Permutation_refl.
eapply Permutation_trans; [ | apply perm_swap].
apply perm_skip.
apply IHal.
omega.
Qed.

Function is_increasing (ns: list nat) (last: nat) {measure length ns}: bool  :=
 match ns with
 | nil => true
 | a::nil => Nat.ltb a last
 | a::b::ns' => andb (Nat.ltb a b) (is_increasing (b::ns') last)
 end.
Proof. intros. subst. simpl. omega.
Defined.

(*
Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  induction 1; simpl; intros; auto.
  inv H0; constructor; auto.
  inv H. inv H3. constructor; auto.
Qed.
*)

Lemma delete_nth_length:
   forall {A} i (al: list A), (i < length al)%nat ->
     (S (length (delete_nth i al)) = length al)%nat.
Proof.
induction i; destruct al; simpl; intros; try omega.
apply f_equal.
apply IHi; omega.
Qed.

Lemma freezelist_nth_permutation: forall ns al,
  is_increasing (SortNat.sort ns) (length al) = true ->
  Permutation al (fst (freezelist_nth ns al) ++ snd (freezelist_nth ns al)).
Proof.
unfold freezelist_nth.
simpl.
intros.
apply Permutation_trans
 with
 (map (fun i : nat => my_nth i al emp) (SortNat.sort ns) ++
   delete_list (SortNat.sort ns) al).
2:{ apply Permutation_app_tail.
     apply Permutation_map.
     apply Permutation_sym.
     apply SortNat.Permuted_sort.
}
 forget (SortNat.sort ns) as ns'; clear ns; rename ns' into ns.
 revert al H; induction ns; simpl; intros.
 apply Permutation_refl.
 replace (my_nth a al emp) with (my_nth a (delete_list ns al) emp).
-
 eapply Permutation_trans; [ | apply Permutation_sym; apply Permutation_middle].
 eapply Permutation_trans; [ | apply Permutation_app_head; apply my_nth_delete_nth_permutation].
   apply IHns.
  rewrite is_increasing_equation in H. destruct ns; simpl; auto.
  rewrite andb_true_iff in H; destruct H; auto.
  rewrite is_increasing_equation in H. destruct ns; simpl; auto.
  apply Nat.ltb_lt; auto.
  rewrite andb_true_iff in H; destruct H; auto.
  apply Nat.ltb_lt in H.
  clear - H H0.
  change (delete_nth n (delete_list ns al)) with (delete_list (n::ns) al).
  revert n a al H H0; induction ns; intros;
  rewrite is_increasing_equation in H0.
  simpl.
  apply Nat.ltb_lt in H0.
  pose proof (delete_nth_length n al H0). omega.
 change (delete_list (n :: a :: ns) al)%nat with (delete_nth n (delete_list ( a :: ns) al))%nat.
  rewrite andb_true_iff in H0; destruct H0; auto.
  apply Nat.ltb_lt in H0.
 specialize (IHns a n al).
 spec IHns; [omega|]. specialize (IHns H1).
 pose proof (delete_nth_length n (delete_list (a::ns) al) IHns).
 assert (a0 <= S (Datatypes.length
   (delete_nth n (delete_list (a :: ns) al))))%nat; [ | omega].
  rewrite H2.
 omega.
-
 clear - H.
 revert a al H; induction ns; intros.
 simpl. auto.
 simpl.
 transitivity (my_nth a0 (delete_list ns al) emp).
 +
  rewrite is_increasing_equation in H.
  rewrite andb_true_iff in H; destruct H.
  apply Nat.ltb_lt in H.
  forget (delete_list ns al) as bl.
  clear - H.
  revert a0 bl H; induction a; destruct a0, bl; simpl; intros; auto; try omega.
  apply IHa. omega.
 +  apply IHns.
   clear - H.
  rewrite is_increasing_equation in H.
  rewrite andb_true_iff in H; destruct H.
  apply Nat.ltb_lt in H.
  rewrite is_increasing_equation in H0.
  rewrite is_increasing_equation.
  destruct ns.
  apply Nat.ltb_lt in H0.
  apply Nat.ltb_lt. omega.
  rewrite andb_true_iff in H0; destruct H0.
  rewrite andb_true_iff; split; auto.
  apply Nat.ltb_lt in H0.
  apply Nat.ltb_lt. omega.
Qed.

(* This older version of freezelist_nth didn't work when the l list was not sorted
Fixpoint freezelist_nth (l: list nat) (al: list mpred): (list mpred) * (list mpred) :=
 match l with
 | nil => (nil,al)
 | (n::l') => let (xs, ys) := freezelist_nth l' al
              in (nth n ys emp::xs, delete_nth n ys)
 end.
*)
Lemma FRZL_ax ps: FRZL ps = fold_right_sepcon ps.
Proof. intros. apply pred_ext. apply Freezer.FRZL2. apply Freezer.FRZL1. Qed.

Lemma fold_right_sepcon_deletenth: forall n (l: list mpred),
  fold_right_sepcon l = nth n l emp * fold_right_sepcon (delete_nth n l).
Proof.
  induction n; destruct l; simpl. rewrite sepcon_emp; trivial.
  reflexivity.
  rewrite sepcon_emp; trivial.
  rewrite IHn.
  do 2 rewrite <- sepcon_assoc. rewrite (sepcon_comm m). trivial.
Qed.
Lemma fold_right_sepcon_deletenth': forall n (l:list (LiftEnviron mpred)),
  @fold_right (environ -> mpred) (environ -> mpred) sepcon emp l =
  nth n l emp * fold_right sepcon emp (delete_nth n l).
Proof.
  induction n; destruct l; simpl. rewrite sepcon_emp; trivial.
  reflexivity.
  rewrite sepcon_emp; trivial.
  rewrite IHn; clear IHn. extensionality. simpl.
  do 2 rewrite <- sepcon_assoc. rewrite (sepcon_comm (l x)). trivial.
Qed.

Lemma fold_right_sepcon_permutation:
 forall al bl, Permutation al bl -> fold_right_sepcon al = fold_right_sepcon bl.
Proof.
intros.
induction H; simpl; auto.
congruence.
rewrite <- ! sepcon_assoc.
rewrite (sepcon_comm x).
auto.
congruence.
Qed.

Lemma freeze_SEP':
 forall l Espec {cs: compspecs} Delta P Q  R c Post xs ys,
  is_increasing (SortNat.sort l) (length R) = true ->
 (xs, ys) = freezelist_nth l R ->
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (FRZL xs:: ys)))) c Post ->
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
intros *. intro Hii; intros. subst.
eapply semax_pre; try eassumption.
apply andp_left2. unfold PROPx. normalize.
apply andp_derives; auto.
pose proof (freezelist_nth_permutation _ _ Hii).
rewrite <- H in H2.
simpl in H2.
clear - H2.
unfold SEPx.
intros _.
rewrite (fold_right_sepcon_permutation _ _ H2).
rewrite FRZL_ax.
clear.
induction xs; simpl.
rewrite emp_sepcon.
auto.
rewrite sepcon_assoc.
apply sepcon_derives; auto.
Qed.

Lemma freeze_SEP'entail:
 forall l Delta P Q  R Post xs ys,
  is_increasing (SortNat.sort l) (length R) = true ->
 (xs, ys) = freezelist_nth l R ->
 ENTAIL Delta, (PROPx P (LOCALx Q (SEPx (FRZL xs:: ys)))) |-- Post ->
 ENTAIL Delta, (PROPx P (LOCALx Q (SEPx R))) |-- Post.
Proof.
intros *. intro Hii; intros. subst.
eapply derives_trans; try apply H0.
unfold PROPx. normalize.
apply andp_derives; auto.
pose proof (freezelist_nth_permutation _ _ Hii).
rewrite <- H in H2.
simpl in H2.
clear - H2.
apply andp_derives; auto.
unfold SEPx.
intros _.
rewrite (fold_right_sepcon_permutation _ _ H2).
rewrite FRZL_ax.
clear.
induction xs; simpl.
rewrite emp_sepcon.
auto.
rewrite sepcon_assoc.
apply sepcon_derives; auto.
Qed.

Lemma map_delete_nth {A B} (f:A->B): forall n l, delete_nth n (map f l) = map f (delete_nth n l).
Proof.
  induction n; intros; destruct l; simpl; trivial.
  rewrite IHn. trivial.
Qed.

Fixpoint my_nth {A} (n : nat) (l : list A) (default : A) {struct l} : A :=
  match n with
  | 0%nat => match l with
             | [] => default
             | x :: _ => x
             end
  | S m => match l with
           | [] => default
           | _ :: t => my_nth m t default
           end
  end.

Lemma my_nth_nth {A}: forall n l (d:A), my_nth n l d = nth n l d.
Proof.
  induction n; destruct l; intros; simpl; trivial. Qed.

Fixpoint my_delete_nth {A} (n:nat) (xs:list A) : list A :=
 match n with
  | 0%nat => match xs with
             | [] => []
             | _ :: ys => ys
             end
  | S n' => match xs with
            | [] => []
            | y :: ys => y :: my_delete_nth n' ys
            end
  end.

Lemma my_delete_nth_delete_nth {A}: forall n (l:list A), my_delete_nth n l = delete_nth n l.
Proof. induction n; destruct l; intros; simpl; trivial. Qed.

Fixpoint my_delete_list {A: Type} (ns: list nat) (xs: list A) : list A :=
 (* ns must already be sorted *)
 match ns with
 | nil => xs
 | n::ns' => my_delete_nth n (my_delete_list ns' xs)
 end.

Definition my_freezelist_nth (ns: list nat) (al: list mpred) : list mpred * list mpred :=
  (map (fun i => my_nth i al emp) ns,
   my_delete_list (SortNat.sort ns) al).

Lemma my_freezelist_nth_freezelist_nth: forall l al,
  my_freezelist_nth l al = freezelist_nth l al.
Proof. (*unfold my_freezelist_nth, freezelist_nth. *)
 intros. unfold my_freezelist_nth, freezelist_nth.
 f_equal.
  induction l; simpl; intros; trivial.
  f_equal; auto.
  clear.
  revert al; induction a; destruct al; simpl; auto.
Qed.

(*Variant if l is monotonically decreasing
Fixpoint new_freezelist_nth (l: list nat) (al: list mpred): (list mpred) * (list mpred) :=
 match l with
 | nil => (nil,al)
 | (n::l') => let (xs, ys) := new_freezelist_nth l' (my_delete_nth n al)
              in (my_nth n al emp::xs, ys)
 end.*)

Lemma freeze_SEP'':
 forall l Espec {cs: compspecs} Delta P Q  R c Post xs ys,
  is_increasing (SortNat.sort l) (length R) = true ->
 (xs, ys) = my_freezelist_nth l R ->
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (FRZL xs:: ys)))) c Post ->
 @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof. intros. rewrite my_freezelist_nth_freezelist_nth in H0.
  eapply freeze_SEP'; eassumption.  Qed.

Lemma freeze_SEP''entail:
 forall l Delta P Q  R Post xs ys,
  is_increasing (SortNat.sort l) (length R) = true ->
 (xs, ys) = my_freezelist_nth l R ->
 ENTAIL Delta, (PROPx P (LOCALx Q (SEPx (FRZL xs:: ys)))) |-- Post ->
 ENTAIL Delta, (PROPx P (LOCALx Q (SEPx R))) |-- Post.
Proof. intros. rewrite my_freezelist_nth_freezelist_nth in H0.
  eapply freeze_SEP'entail; eassumption.  Qed.

Ltac solve_is_increasing :=
  reflexivity ||
  match goal with |- is_increasing (SortNat.sort ?L) ?K = true =>
   let L' := eval compute in L in
   let K' := eval compute in K in
   (unify (is_increasing L' (S (List.fold_right Nat.max O L'))) false;
           fail 1 "Your freeze-list" L' "has repeated indexes") ||
    fail "Your freeze-list" L' "contains an index >= the number of SEP conjuncts, which is" K'
  end.

Ltac freeze_tac L name :=
  eapply (freeze_SEP'' (map Z.to_nat L));
   [solve_is_increasing | reflexivity
   | match goal with
           | |- semax _ (PROPx _ (LOCALx _ (SEPx ((FRZL ?xs) :: my_delete_list ?A _)))) _ _ =>
           let D := fresh name in
           set (D:=xs);
           change xs with (@abbreviate (list mpred) xs) in D;
            let x := fresh "x" in
            set (x:=A); compute in x; subst x;
             unfold my_delete_list, my_delete_nth
         end].

Ltac freeze_tac_entail L name :=
  eapply (freeze_SEP''entail (map Z.to_nat L));
   [solve_is_increasing | reflexivity
   | match goal with
           | |- ENTAIL _, (PROPx _ (LOCALx _ (SEPx ((FRZL ?xs) :: my_delete_list ?A _)))) |-- _ =>
           let D := fresh name in
           set (D:=xs);
(*           hnf in D;*)
           change xs with (@abbreviate (list mpred) xs) in D;
            let x := fresh "x" in
            set (x:=A); compute in x; subst x;
             unfold my_delete_list, my_delete_nth
         end].

Function Zlist_complement'  (i: Z) (n: nat) (bl: list Z) : list Z :=
 match n with O => nil
 | S n' =>
   match bl with
   | nil => i :: Zlist_complement' (Z.succ i) n' bl
   | b::bl' => if Z.ltb i b then i :: Zlist_complement' (Z.succ i) n' bl
                    else Zlist_complement' (Z.succ i) n' bl'
   end
 end.

Definition Zlist_complement (n: nat) (al: list Z) : list Z :=
  let bl := SortZ.sort al
  in Zlist_complement' 0 n bl.

(* Compute Zlist_complement 9 [4;5;3]. *)

Ltac find_freeze1 comp id A :=
lazymatch goal with
| fr := @abbreviate mpred _ |- semax _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
  match R with context [fr :: ?R'] =>
    let L := constr:(Zlength R - (Z.succ (Zlength R'))) in
     let L := eval cbn in L in
      let A' := constr:(L::A) in
        unfold abbreviate in fr; subst fr; find_freeze1 comp id A'
   end
| |- semax _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
            let A' := constr:(if comp then Zlist_complement (length R) A
                                     else A) in
            let A' := eval compute in A' in
            freeze_tac A' id
| fr := @abbreviate mpred _ |- ENTAIL _, (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
  match R with context [fr :: ?R'] =>
    let L := constr:(Zlength R - (Z.succ (Zlength R'))) in
     let L := eval cbn in L in
      let A' := constr:(L::A) in
        unfold abbreviate in fr; subst fr; find_freeze1 comp id A'
   end
| |- ENTAIL _, (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
            let A' := constr:(if comp then Zlist_complement (length R) A
                                     else A) in
            let A' := eval compute in A' in
            freeze_tac_entail A' id
end.

Ltac freezer i := find_freeze1  false i (@nil Z).
Ltac complement_freezer i := find_freeze1 true i (@nil Z).

Tactic Notation "freeze" constr(L) ident(i) :=
  freeze_tac L i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) :=
  freeze1 a1; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) :=
  freeze1 a1; freeze1 a2; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) :=
  freeze1 a1; freeze1 a2; freeze1 a3; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) :=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) :=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8) uconstr(a9):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; freeze1 a9; freezer i.
Tactic Notation "freeze" ident(i) ":=" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8) uconstr(a9) uconstr(a10):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; freeze1 a9; freeze1 a10; freezer i.

Tactic Notation "freeze" ident(i) ":=" "-"  :=
    complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) :=
  freeze1 a1; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) :=
  freeze1 a1; freeze1 a2; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) :=
  freeze1 a1; freeze1 a2; freeze1 a3; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) :=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) :=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8) uconstr(a9):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; freeze1 a9; complement_freezer i.
Tactic Notation "freeze" ident(i) ":=" "-" uconstr(a1) uconstr(a2) uconstr(a3) uconstr(a4) uconstr(a5) uconstr(a6) uconstr(a7) uconstr(a8) uconstr(a9) uconstr(a10):=
  freeze1 a1; freeze1 a2; freeze1 a3; freeze1 a4; freeze1 a5; freeze1 a6; freeze1 a7; freeze1 a8; freeze1 a9; freeze1 a10; complement_freezer i.

(****************************************************************************)

Lemma flatten_emp_in_mpreds':
  forall n (R: list mpred),
   nth_error R n = Some emp ->
   SEPx R = SEPx (firstn n R ++ skipn (S n) R).
Proof.
unfold SEPx. intros. extensionality rho.
revert R H. clear.
induction n; destruct R; intros.
+ inv H.
+ simpl nth_error in H. inv H. simpl. apply emp_sepcon.
+ reflexivity.
+ inv H.
  specialize (IHn _ H1). clear H1. simpl firstn.
  change (m :: firstn n R) with (app (m::nil) (firstn n R)).
  rewrite app_ass. unfold app at 1.
  simpl; f_equal; auto.
Qed.

Lemma flatten_emp_in_SEP':
  forall n P Q (R: list mpred) R',
   nth_error R n = Some emp ->
   R' = firstn n R ++ skipn (S n) R ->
   PROPx P (LOCALx Q (SEPx R)) = PROPx P (LOCALx Q (SEPx R')).
Proof.
intros.
f_equal. f_equal. subst R'.
 apply flatten_emp_in_mpreds'. trivial.
Qed.
(*
Ltac flatten_emp_in_mpreds RR :=
 match RR with
 | (SEPx (?R)) =>
   match R with context [emp :: ?R'] =>
      let n := constr:(length R - Datatypes.S (length R'))%nat in
      let n' := eval lazy beta zeta iota delta in n in
      erewrite(@flatten_emp_in_mpreds' n' R _ (eq_refl _));
      [ |
        let RR := fresh "RR" in set (RR := R);
        unfold firstn, app, skipn; subst RR; cbv beta iota;
        apply eq_refl
      ]
   end
 end.

Ltac flatten_emp :=
  match goal with
  | |- semax _ ?PQR _ _ => flatten_emp_in_SEP PQR
  | |-  ?PQR |-- _ => first [flatten_emp_in_SEP PQR |
                             flatten_emp_in_mpreds PQR ]
end.*)

Ltac flatten_emp_in_SEP PQR :=
 match PQR with
 | PROPx ?P (LOCALx ?Q (SEPx (?R))) =>
   match R with context [emp :: ?R'] =>
      let n := constr:((length R - Datatypes.S (length R'))%nat) in
      let n' := eval lazy beta zeta iota delta in n in
      erewrite(@flatten_emp_in_SEP' n' P Q R _ (eq_refl _));
      [ |
        let RR := fresh "RR" in set (RR := R);
        unfold firstn, app, skipn; subst RR; cbv beta iota;
        apply eq_refl
      ]
   end
 end.

Ltac flatten_emp :=
  match goal with
  | |- semax _ ?PQR _ _ => flatten_emp_in_SEP PQR
  | |-  ?PQR |-- _ => flatten_emp_in_SEP PQR
end.

(*Thawing a freezer results in the sepcon product of the frozen items.*)

(*Tactic requires the resulting goal to be normalized manually.*)
Ltac thaw' name :=
  rewrite (FRZL_ax name); unfold name, abbreviate; clear name.

(*add simplification of the list operations inside the freezer,
   flatten the sepcon, and eliminate the emp term*)
Ltac thaw name :=
thaw' name;
let x := fresh "x" in let y := fresh "y" in let a := fresh "a" in
lazymatch goal with
|  |- context [fold_right_sepcon (map ?F ?A)] =>
  set (x:= fold_right_sepcon (map F A));
  set (y := F) in *;
  simpl in x
|  |- context [fold_right_sepcon ?A] =>
  set (x:= fold_right_sepcon A);
   unfold fold_right_sepcon in x
end;
pattern x;
match goal with |- ?A x => set (a:=A) end;
revert x;
rewrite <- ?sepcon_assoc, sepcon_emp;
intro x; subst a x; try subst y;
  unfold my_delete_list, my_delete_nth, my_nth, fold_right_sepcon;
  repeat flatten_sepcon_in_SEP; repeat flatten_emp.

(************************ Ramification ************************)

Inductive split_FRZ_in_SEP: list mpred -> list mpred -> list mpred -> Prop :=
| split_FRZ_in_SEP_nil: split_FRZ_in_SEP nil nil nil
| split_FRZ_in_SEP_FRZ: forall R R' RF F, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (FRZ F :: R) R' (FRZ F :: RF)
| split_FRZ_in_SEP_FRZL: forall R R' RF F, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (FRZL F :: R) R' (FRZL F :: RF)
| split_FRZ_in_SEP_FRZR: forall R R' RF L G w, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (@FRZR L G w :: R) R' (@FRZR L G w :: RF)
| split_FRZ_in_SEP_other: forall R R' RF R0, split_FRZ_in_SEP R R' RF -> split_FRZ_in_SEP (R0 :: R) (R0 :: R') RF.

Ltac prove_split_FRZ_in_SEP :=
  solve [
    repeat first
    [ simple apply split_FRZ_in_SEP_nil
    | simple apply split_FRZ_in_SEP_FRZ
    | simple apply split_FRZ_in_SEP_FRZL
    | simple apply split_FRZ_in_SEP_FRZR
    | simple apply split_FRZ_in_SEP_other]].

Lemma split_FRZ_in_SEP_spec: forall R R' RF,
  split_FRZ_in_SEP R R' RF ->
  fold_right_sepcon R = fold_right_sepcon R' * fold_right_sepcon RF.
Proof.
  intros.
  induction H.
  + simpl.
    rewrite sepcon_emp; auto.
  + simpl.
    rewrite IHsplit_FRZ_in_SEP.
    apply pred_ext; cancel.
  + simpl.
    rewrite IHsplit_FRZ_in_SEP.
    apply pred_ext; cancel.
  + simpl.
    rewrite IHsplit_FRZ_in_SEP.
    apply pred_ext; cancel.
  + simpl.
    rewrite IHsplit_FRZ_in_SEP.
    apply pred_ext; cancel.
Qed.

Lemma localize: forall R_L Espec {cs: compspecs} Delta P Q R R_FR R_G c Post,
  split_FRZ_in_SEP R R_G R_FR ->
  (let FR_L := @abbreviate _ R_L in
   let FR_G := @abbreviate _ R_G in
   exists  (w: FRZRw FR_L FR_G),
  @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (R_L ++ @FRZR FR_L FR_G w :: R_FR)))) c Post) ->
  @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
  intros.
  destruct H0 as [? ?].
  eapply semax_pre; [clear H0 | exact H0].
  apply split_FRZ_in_SEP_spec in H.
  apply andp_left2.
  apply andp_derives; auto.
  apply andp_derives; auto.
  unfold SEPx; intro.
  rewrite H.
  rewrite fold_right_sepcon_app.
  simpl.
  cancel.
  apply Freezer.FRZR1.
Qed.

Ltac unfold_app :=
change (@app mpred)
  with (fix app (l m : list mpred) {struct l} : list mpred :=
  match l with
  | nil => m
  | cons a l1 => cons a (app l1 m)
  end);
change (@app Prop)
  with (fix app (l m : list Prop) {struct l} : list Prop :=
  match l with
  | nil => m
  | cons a l1 => cons a (app l1 m)
  end);
cbv beta iota.

Ltac localize R_L :=
  eapply (localize R_L); [prove_split_FRZ_in_SEP |];
  let FR_L := fresh "RamL" in
  let FR_G := fresh "RamG" in
  intros FR_L FR_G;
  eexists;
  unfold_app.

Lemma unlocalize_aux: forall R_G2 R R_FR R_L1 R_G1 R_L2 F w,
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  (exists (H: (fold_right_sepcon R_G1) |-- fold_right_sepcon R_L1 * F), w = @Freezer.FRZRw_constr _ _ _ H) ->
  F |-- fold_right_sepcon R_L2 -* fold_right_sepcon R_G2 ->
  fold_right_sepcon R |-- fold_right_sepcon (R_G2 ++ R_FR).
Proof.
  intros.
  apply split_FRZ_in_SEP_spec in H.
  rewrite H.
  rewrite fold_right_sepcon_app.
  simpl.
  cancel.
  destruct H0 as [? ?]; subst.
  apply Freezer.FRZR2.
  auto.
Qed.

Lemma unlocalize_triple: forall R_G2 Espec {cs: compspecs} Delta P Q R R_FR R_L1 R_G1 R_L2 c Post w,
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  (exists (H: fold_right_sepcon R_G1 |-- fold_right_sepcon R_L1 * (fold_right_sepcon R_L2 -* fold_right_sepcon R_G2)), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (R_G2 ++ R_FR)))) c Post) ->
  @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
  intros.
  eapply semax_pre; [clear H1 | exact (H1 I)].
  apply andp_left2.
  apply andp_derives; auto.
  apply andp_derives; auto.
  unfold SEPx; intro.
  eapply unlocalize_aux; eauto.
Qed.

Lemma unlocalize_derives_canon: forall R_G2 Delta P Q R R_FR R_L1 R_G1 R_L2 Post w,
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  (exists (H: (fold_right_sepcon R_G1) |-- fold_right_sepcon R_L1 * (fold_right_sepcon R_L2 -* fold_right_sepcon R_G2)), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> local (tc_environ Delta) && PROPx P (LOCALx Q (SEPx (R_G2 ++ R_FR))) |-- Post) ->
  local (tc_environ Delta) && PROPx P (LOCALx Q (SEPx R)) |-- Post.
Proof.
  intros.
  eapply derives_trans; [clear H1 | exact (H1 I)].
  apply andp_derives; auto.
  apply andp_derives; auto.
  apply andp_derives; auto.
  unfold SEPx; intro.
  eapply unlocalize_aux; eauto.
Qed.

Lemma unlocalize_derives_unlift: forall R_G2 Pre R R_FR R_L1 R_G1 R_L2 Post w,
  construct_fold_right_sepcon Pre R ->
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  (exists (H: (fold_right_sepcon R_G1) |-- fold_right_sepcon R_L1 * (fold_right_sepcon R_L2 -* fold_right_sepcon R_G2)), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> fold_left_sepconx (R_G2 ++ R_FR) |-- Post) ->
  Pre |-- Post.
Proof.
  intros.
  apply construct_fold_right_sepcon_spec in H.
  subst Pre.
  eapply derives_trans; [clear H2 | exact (H2 I)].
  rewrite fold_left_sepconx_eq.
  eapply unlocalize_aux; eauto.
Qed.

Inductive ramif_frame_gen: mpred -> mpred -> Prop :=
| ramif_frame_gen_refl: forall P, ramif_frame_gen P P
| ramif_frame_gen_prop: forall (Pure: Prop) P Q, Pure -> ramif_frame_gen P (imp (prop Pure) Q) -> ramif_frame_gen P Q
| ramif_frame_gen_allp: forall {A: Type} (x: A) P Q, (forall x: A, ramif_frame_gen (P x) (Q x)) -> ramif_frame_gen (allp P) (Q x).

Ltac prove_ramif_frame_gen_rec wit :=
  match wit with
  | pair ?wit0 ?x =>
      prove_ramif_frame_gen_rec wit0;
      match goal with
      | |- ramif_frame_gen _ ?P => super_pattern P x
      end;
      apply (ramif_frame_gen_allp x);
      clear dependent x;
      intros x
  | _ =>
      match goal with
      | |- ramif_frame_gen _ ?P => super_pattern P wit
      end;
      apply (ramif_frame_gen_allp wit);
      clear dependent wit;
      intros wit
  end.

Ltac prove_ramif_frame_gen wit :=
  prove_ramif_frame_gen_rec wit;
  apply ramif_frame_gen_refl.

Ltac conj_gen assu :=
  match assu with
  | pair ?assu0 ?a => let r := conj_gen assu0 in constr:(conj r a)
  | _ => constr:(assu)
  end.

Ltac prove_ramif_frame_gen_prop assu :=
  let H := conj_gen assu in
  let Pure := type of H in
    apply (ramif_frame_gen_prop Pure _ _ H).

Lemma ramif_frame_gen_spec: forall P Q, ramif_frame_gen P Q -> P |-- Q.
Proof.
  intros.
  induction H.
  + apply derives_refl.
  + apply imp_andp_adjoint in IHramif_frame_gen.
    eapply derives_trans; [| apply IHramif_frame_gen].
    apply andp_right; auto.
    apply prop_right; auto.
  + apply (allp_left _ x).
    apply H0.
Qed.

Lemma unlocalizeQ_triple: forall R_G2 Espec {cs: compspecs} Delta P Q R R_FR R_L1 R_G1 R_L2 F c Post w,
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  ramif_frame_gen F (wand (fold_right_sepcon R_L2) (fold_right_sepcon R_G2)) ->
  (exists (H: (fold_right_sepcon R_G1) |-- sepcon (fold_right_sepcon R_L1) F), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (R_G2 ++ R_FR)))) c Post) ->
  @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
  intros.
  eapply semax_pre; [clear H2 | exact (H2 I)].
  apply andp_left2.
  apply andp_derives; auto.
  apply andp_derives; auto.
  unfold SEPx; intro.
  apply ramif_frame_gen_spec in H0; auto.
  eapply unlocalize_aux; eauto.
Qed.

Lemma unlocalizeQ_derives_canon: forall R_G2 Delta P Q R R_FR R_L1 R_G1 R_L2 F Post w,
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  ramif_frame_gen F (wand (fold_right_sepcon R_L2) (fold_right_sepcon R_G2)) ->
  (exists (H: (fold_right_sepcon R_G1) |-- sepcon (fold_right_sepcon R_L1) F), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> local (tc_environ Delta) && PROPx P (LOCALx Q (SEPx (R_G2 ++ R_FR))) |-- Post) ->
  local (tc_environ Delta) && PROPx P (LOCALx Q (SEPx R)) |-- Post.
Proof.
  intros.
  eapply derives_trans; [clear H2 | exact (H2 I)].
  apply andp_derives; auto.
  apply andp_derives; auto.
  apply andp_derives; auto.
  unfold SEPx; intro.
  apply ramif_frame_gen_spec in H0; auto.
  eapply unlocalize_aux; eauto.
Qed.

Lemma unlocalizeQ_derives_unlift: forall R_G2 Pre R R_FR R_L1 R_G1 R_L2 F Post w,
  construct_fold_right_sepcon Pre R ->
  split_FRZ_in_SEP R R_L2 (@FRZR R_L1 R_G1 w :: R_FR) ->
  ramif_frame_gen F (wand (fold_right_sepcon R_L2) (fold_right_sepcon R_G2)) ->
  (exists (H: (fold_right_sepcon R_G1) |-- sepcon (fold_right_sepcon R_L1) F), w = @Freezer.FRZRw_constr _ _ _ H) ->
  (@abbreviate _ (fun _ _ => True) R_L1 R_G1 -> fold_left_sepconx (R_G2 ++ R_FR) |-- Post) ->
  Pre |-- Post.
Proof.
  intros.
  apply construct_fold_right_sepcon_spec in H.
  subst Pre.
  eapply derives_trans; [clear H3 | exact (H3 I)].
  apply ramif_frame_gen_spec in H1; auto.
  rewrite fold_left_sepconx_eq.
  eapply unlocalize_aux; eauto.
Qed.

Ltac unlocalize_plain R_G2 :=
  match goal with
  | |- @semax _ _ _ _ _ _ =>
          eapply (unlocalize_triple R_G2)
  | |- local (tc_environ _) && _ |-- _ =>
          eapply (unlocalize_derives_canon R_G2)
  | |- @derives _ Nveric _ _ =>
          eapply (unlocalize_derives_unlift R_G2); [construct_fold_right_sepcon | ..]
  end;
  [ prove_split_FRZ_in_SEP
  | refine (ex_intro _ _ eq_refl);
    match goal with
    | |- fold_right_sepcon ?R_G1 |-- sepcon (fold_right_sepcon ?R_L1) _ =>
           unfold abbreviate in R_L1, R_G1; unfold R_L1, R_G1; clear R_L1 R_G1
    end;
    rewrite <- !fold_left_sepconx_eq;
    unfold fold_left_sepconx
  | match goal with
    | |- _ ?R_L1 ?R_G1 -> _ =>
      intros _;
      clear R_L1 R_G1;
      unfold_app
    end;
    try unfold fold_left_sepconx
  ].

Ltac unlocalize_wit R_G2 wit tac :=
  match goal with
  | |- @semax _ _ _ _ _ _ =>
          eapply (unlocalizeQ_triple R_G2)
  | |- local (tc_environ _) && _ |-- _ =>
          eapply (unlocalizeQ_derives_canon R_G2)
  | |- @derives _ Nveric _ _ =>
          eapply (unlocalizeQ_derives_unlift R_G2); [construct_fold_right_sepcon | ..]
  end;
  [ prove_split_FRZ_in_SEP
  | rewrite <- !fold_right_sepconx_eq;
    unfold fold_right_sepconx;
    tac;
    prove_ramif_frame_gen wit
  | refine (ex_intro _ _ eq_refl);
    match goal with
    | |- fold_right_sepcon ?R_G1 |-- sepcon (fold_right_sepcon ?R_L1) _ =>
           unfold abbreviate in R_L1, R_G1; unfold R_L1, R_G1; clear R_L1 R_G1
    end;
    rewrite <- !fold_right_sepconx_eq;
    unfold fold_right_sepconx
  | match goal with
    | |- _ ?R_L1 ?R_G1 -> _ =>
      intros _;
      clear R_L1 R_G1;
      unfold_app
    end;
    try unfold fold_left_sepconx
  ].

Tactic Notation "unlocalize" constr(R_G2) :=
  unlocalize_plain R_G2.

Tactic Notation "unlocalize" constr(R_G2) "using" constr(wit) :=
  unlocalize_wit R_G2 wit idtac.

Tactic Notation "unlocalize" constr(R_G2) "using" constr(wit) "assuming" constr(assu) :=
  let tac := prove_ramif_frame_gen_prop assu in
  unlocalize_wit R_G2 wit tac.

Ltac thaw'' i :=
thaw' i;
let x := fresh "x" in let y := fresh "y" in let a := fresh "a" in
match goal with |- context [fold_right_sepcon (map ?F ?A)] =>
  set (x:= fold_right_sepcon (map F A));
  set (y := F) in *;
  simpl in x
end;
pattern x;
match goal with |- ?A x => set (a:=A) end;
revert x;
rewrite <- ?sepcon_assoc, sepcon_emp;
intro x; subst a x y;
  unfold my_delete_list, my_delete_nth, my_nth, fold_right_sepcon.

Ltac gather_SEP'' L :=
 gather_SEP' L;
 idtac "Warning: gather_SEP with numeric arguments is deprecated".

Tactic Notation "gather_SEP" uconstr(a) :=
  gather_SEP'' (a::nil) ||  (let i := fresh "i" in freeze i := a; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) :=
  gather_SEP'' (a::b::nil) ||  (let i := fresh "i" in freeze i := a b; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) :=
  gather_SEP'' (a::b::c::nil) ||  (let i := fresh "i" in freeze i := a b c; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) :=
  gather_SEP'' (a::b::c::d::nil) ||  (let i := fresh "i" in freeze i := a b c d; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) :=
  gather_SEP'' (a::b::c::d::e::nil) ||  (let i := fresh "i" in freeze i := a b c d e; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) uconstr(f) :=
  gather_SEP'' (a::b::c::d::e::f::nil) ||  (let i := fresh "i" in freeze i := a b c d e f; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) uconstr(f) uconstr(g) :=
  gather_SEP'' (a::b::c::d::e::f::g::nil) ||  (let i := fresh "i" in freeze i := a b c d e f g; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) uconstr(f) uconstr(g) uconstr(h) :=
  gather_SEP'' (a::b::c::d::e::f::g::h::nil) ||  (let i := fresh "i" in freeze i := a b c d e f g h; thaw'' i).

Tactic Notation "gather_SEP" uconstr(a) uconstr(b) uconstr(c) uconstr(d) uconstr(e) uconstr(f) uconstr(g) uconstr(h) uconstr(i0) :=
  gather_SEP'' (a::b::c::d::e::f::g::h::i0::nil) ||  (let i := fresh "i" in freeze i := a b c d e f g h i0; thaw'' i).


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector
        Coq.ZArith.ZArith.

Require Import
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Automation.NormalizeFormats
        Fiat.Narcissus.Automation.AlignedAutomation.

Require Import Bedrock.Word.

Import Vectors.Vector.VectorNotations.
Open Scope format_scope.
Opaque pow2. (* Don't want to be evaluating this. *)
Opaque natToWord. (* Or this. *)

(* Start Example Derivation. *)

Record ARPPacket :=
  {HardType : EnumType ["Ethernet"; "802"; "Chaos"];
   ProtType : EnumType ["IPv4"; "IPv6"]; (* Overlaps with etherType. *)
   Operation : EnumType ["Request";
                           "Reply";
                           "RARP Request";
                           "RARP Reply"];
   SenderHardAddress : list (word 8);
   SenderProtAddress : list (word 8);
   TargetHardAddress : list (word 8);
   TargetProtAddress : list (word 8)}.

Definition HardTypeCodes : Vector.t (word 16) 3 :=
  [WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1;
   WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1~0;
   WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~0~1
  ].

Definition EtherTypeCodes : Vector.t (word 16) 2 :=
  [WO~0~0~0~0~1~0~0~0~0~0~0~0~0~0~0~0;
   WO~1~0~0~0~0~1~1~0~1~1~0~1~1~1~0~1
  ].

Definition HardSizeCodes : Vector.t (word 8) 3 :=
  [WO~0~0~0~0~0~1~1~0;
   WO~0~0~0~0~0~1~1~0;
   WO~0~0~0~0~0~0~1~0
  ].

Definition ProtSizeCodes : Vector.t (word 8) 2 :=
  [WO~0~0~0~0~0~1~0~0;
   WO~0~0~0~1~0~0~0~0 ].

Definition OperationCodes : Vector.t (word 16) 4 :=
  [WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1;
   WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~0;
   WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1~1;
   WO~0~0~0~0~0~0~0~0~0~0~0~0~0~1~0~0
  ].

Definition ARPPacket_Format
  : FormatM ARPPacket ByteString :=
  format_enum HardTypeCodes ◦ HardType
    ++ format_enum EtherTypeCodes ◦ ProtType
    ++ format_word ◦ (Basics.compose (Vector.nth HardSizeCodes) HardType)
    ++ format_word ◦ (Basics.compose (Vector.nth ProtSizeCodes) ProtType)
    ++ format_enum OperationCodes ◦ Operation
    ++ format_list format_word ◦ SenderHardAddress
    ++ format_list format_word ◦ SenderProtAddress
    ++ format_list format_word ◦ TargetHardAddress
    ++ format_list format_word ◦ TargetProtAddress.

Definition ARP_Packet_OK (arp : ARPPacket) :=
  (|arp.(SenderHardAddress)|) = wordToNat HardSizeCodes[@arp.(HardType)]
  /\ (|arp.(SenderProtAddress)|) = wordToNat ProtSizeCodes[@arp.(ProtType)]
  /\ (|arp.(TargetHardAddress)|) = wordToNat HardSizeCodes[@arp.(HardType)]
  /\ (|arp.(TargetProtAddress)|) = wordToNat ProtSizeCodes[@arp.(ProtType)].

Arguments Vector.nth : simpl never.

(* Step One: Synthesize an encoder and a proof that it is correct. *)
Definition ARP_encoder :
  CorrectAlignedEncoderFor ARPPacket_Format.
Proof.
  synthesize_aligned_encoder.
Defined.

(* Step Two: Extract the encoder function, and have it start encoding
 at the start of the provided ByteString [v]. *)
Definition ARP_encoder_impl {sz} v r :=
  Eval simpl in (projT1 ARP_encoder sz v 0 r tt).

(* Step Three: Synthesize a decoder and a proof that /it/ is correct. *)
Definition ARP_Packet_Header_decoder
  : CorrectAlignedDecoderFor ARP_Packet_OK ARPPacket_Format.
Proof.
  synthesize_aligned_decoder.
Defined.

(* Step Four: Extract the decoder function, and have /it/ start decoding
   at the start of the provided ByteString [v]. *)
Arguments GetCurrentBytes : simpl never.
Definition ARP_decoder_impl {sz} v :=
  Eval simpl in (projT1 ARP_Packet_Header_decoder sz v 0 ()).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A C U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ O O /\ (wd_ C O /\ (col_ O E A /\ (col_ O E O /\ (col_ O E C /\ (col_ O E O /\ col_ O E U))))))))))) -> col_ O U C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import VST.floyd.proofauto.
Require Import Core.Core Core.Notations.

Open Scope IntScope.

Fixpoint required_size_loop n z l :=
  match n with
  | O => l
  | S n => if z >> (Int.repr l) * (Int.repr 8) == 0
          then l
          else required_size_loop n z (l + 1)%Z
  end.

Definition required_size z := required_size_loop 3%nat z 1%Z.

Lemma required_size_spec:
         forall l : int, forall i : Z,
           i = 1%Z \/ i = 2 \/ i = 3 \/ i = 4 ->
           (forall j : Z, 0 <= j < i ->
               (l >> (Int.repr j) * (Int.repr 8)) == 0 = false) ->
                 l >> (Int.repr i) * (Int.repr 8) = 0 ->
           required_size l = i.
Proof.
  intros l i N B SH.
  repeat break_or_hyp.
  * unfold required_size.
      cbn in *.
      rewrite SH.
      replace (0 == 0) with true by reflexivity;
      auto.
  * unfold required_size.
      cbn.
    do 1 erewrite B.
    autorewrite with norm in *.
    cbn in *.
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    normalize.
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
     autorewrite with norm in *;
    cbn in *;
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    all: normalize;
    nia.
  * unfold required_size;
      cbn.
    erewrite B.
    erewrite B.
    erewrite B.
    all: nia.
 (*    autorewrite with norm in *;
    cbn in *;
    rewrite SH;
      replace (0 == 0) with true by reflexivity;
      auto.
    all: normalize;
    nia. *)
Qed.

Fixpoint serialize_length_loop i n l :=
  match n with
  | O => []
  | S n =>
    Int.zero_ext 8 (l >> i) :: serialize_length_loop (i - Int.repr 8) n l
  end.

Definition serialize_length l :=
  let s := required_size l in
  let n := Z.to_nat s in
  (Int.repr 128 or (Int.repr s)) :: serialize_length_loop (Int.repr ((s - 1) * 8)) n l.

Fixpoint serialize_length_loop_app s n l :=
  match n with
  | O => []
  | S n =>
     serialize_length_loop_app (s + 1)%Z n l
                               ++ [Int.zero_ext 8 (l >> Int.repr (s * 8))]
  end.

Definition serialize_length_app l :=
  let s := required_size l in
  let n := Z.to_nat s in
  (Int.zero_ext 8 (Int.repr 128 or (Int.repr s))) :: serialize_length_loop_app 0%Z n l.

Lemma loop_len_req_size : forall n l i,
    len (serialize_length_loop_app i n l) = Z.of_nat n.
Proof.
  induction n; intros.
  - reflexivity.
  - simpl.
    erewrite Zlength_app.
    erewrite IHn.
    cbn.
    nia.
Qed.

Open Scope Z.

Lemma req_size_32 : forall l, 1 <= required_size l <= 4.
Proof.
  intros.
  unfold required_size.
  cbn.
  repeat break_if; autorewrite with norm; nia.
Qed.

Definition length_serialize len size : list int * Z :=
   if (127 >=? Int.signed len)%Z then
    if eq_dec size 0%int
    then ([], 1%Z)
    else ([Int.zero_ext 8 len], 1%Z)
  else let r := required_size len in
       if (r <? Int.unsigned size)%Z
       then (serialize_length_app len, (r + 1)%Z)
       else ([], r + 1).

Lemma length_serialize_req_size : forall l s,
    Int.unsigned s <> 0 ->
    (required_size l < Int.unsigned s)%Z ->
    let (ls, z) := length_serialize l s in
    len ls = z.
Proof.
intros.
unfold length_serialize.
pose proof (req_size_32 (l)).
repeat break_if; autorewrite with sublist list; auto;  try list_solve; try congruence.
erewrite e in *.
Require Import Tactics.
strip_repr.
unfold serialize_length_app.
autorewrite with sublist.
setoid_rewrite loop_len_req_size.
erewrite Z2Nat.id; try nia.
Zbool_to_Prop. lia.
Qed.

Lemma length_serialize_req_size_gt0 : forall l s,
     0 < snd (length_serialize l s).
Proof.
intros l s.
unfold length_serialize.
pose proof (req_size_32 l).
repeat break_if; auto; unfold snd in *; try nia.
Qed.

Lemma shr_lt_zero_32:
  forall x, Int.shr x (Int.repr (Int.zwordsize))
       = if Int.lt x Int.zero then Int.mone else Int.zero.
Proof.
  intros. apply Int.same_bits_eq; intros.
  rewrite Int.bits_shr; auto.
  rewrite Int.unsigned_repr.
  transitivity (Int.testbit x (Int.zwordsize - 1)).
  f_equal. destruct (zlt (i + (Int.zwordsize)) Int.zwordsize); try omega.
  rewrite Int.sign_bit_of_unsigned.
  unfold Int.lt. rewrite Int.signed_zero. unfold Int.signed.
  destruct (zlt (Int.unsigned x) Int.half_modulus).
  rewrite zlt_false. rewrite Int.bits_zero; auto.
  generalize (Int.unsigned_range x); omega.
  rewrite zlt_true. rewrite Int.bits_mone; auto.
  generalize (Int.unsigned_range x); omega.
  generalize Int.wordsize_max_unsigned; omega.
Qed.


Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import VST.floyd.functional_base.
Require Import common.
Require Import DB.lemmas.

Require Import DB.functional.kv.
Require Import DB.functional.cursored_kv.

Module BTree (KeyType: UsualOrderedType) <: FLATTENABLE_TABLE KeyType.
  Definition key := KeyType.t.
  Parameter table: Type -> Type.
  Parameter cursor: Type -> Type.

  Module Flattened := SortedListTable KeyType.

  Section Types.
    Context {value: Type}.
    (* Predicate rather than variable because of possible addresses in the data type *)
    Parameter empty: table value -> Prop.

    (* Functions *)
    (* Sematics: cursor should point to a place where to the left, all keys are less than the key,
     * to the right, all keys are no less than the key *)
    (* Therefore [make_cursor] should always return one, but not always the expected one *)
    Parameter make_cursor: key -> table value -> cursor value.
    (* By [get] functions, we always access the first key to the right *)
    Parameter get: cursor value -> table value -> option (key * value).
    Definition get_key (c: cursor value) (t: table value): option key :=
      match get c t with
      | Some (k, _) => Some k
      | None => None
      end.

    Definition get_value (c: cursor value) (t: table value): option value :=
      match get c t with
      | Some (_, v) => Some v
      | None => None
      end.

    Definition get_exact (k: key) (t: table value): option value :=
      match get (make_cursor k t) t with
      | Some (k', v) => if KeyType.eq_dec k k' then Some v else None
      | None => None
      end.
    (* we do expect that the cursor is moved when insertion is performed,
     * but where it is afterwards remains to be discussed *)
    Parameter put: key -> value -> cursor value -> table value -> cursor value -> table value -> Prop.
    Parameter next_cursor: cursor value -> table value -> cursor value.
    Parameter prev_cursor: cursor value -> table value -> cursor value.
    Parameter first_cursor: table value -> cursor value.
    (* last cursor is defined to be one position past the table, which means maps to nothing *)
    Parameter last_cursor: table value -> cursor value.
    (* TODO: do we need a [move_cursor]?
     * From the client's view, it does not matter whether it is [make] or [move], but it might increase
     * difficulty in proof *)
    (* Parameter move_cursor: key -> cursor elt -> table elt -> cursor elt. *)

    (* Relations between keys, cursors and tables *)
    (* [abs_rel] means that the table and the cursor are binded together (might need better name) *)
    (* In implementation, it's translated to correct cursor with get tree from cursor works *)
    Parameter abs_rel: cursor value -> table value -> Prop.
    (* Do we need this? This just sounds like [abs_rel c t /\ get_key c t = Some k] *)
    (* Not true, in btree, the cursor created with non-existing keys will not return the key with [get_key],
     * but rather, a bunch of keys can still be associated with the cursor *)
    Parameter key_rel: key -> cursor value -> table value -> Prop.
    (* DO we need this again? What about [abs_rel c1 t /\ abs_rel c2 t /\ get_key c1 t = get_key c2 t] *)
    Parameter eq_cursor : cursor value -> cursor value -> table value -> Prop.
    (* Definition eq_cursor (c1 c2: cursor elt) (t: table elt) := *)
    (*   abs_rel c1 t /\ abs_rel c2 t /\ get_key c1 t = get_key c2 t. *)
    (* What do we need to ensure about the previous two definition? Should they be transitive? *)
    Parameter cursor_correct: cursor value -> Prop.
    Parameter table_correct: table value -> Prop.
    Parameter flatten: table value -> Flattened.table value.

    Section Specs.
      Variable t t1 t2: table value.
      Variable c c1 c2 c3 c4: cursor value.
      Variable k k1 k2 k3: key.
      Variable v v1 v2: value.

      Axiom abs_correct: abs_rel c t -> cursor_correct c /\ table_correct t.

      (* table-cursor relations *)
      (* We need to make sure that the cursor and the table are actually working with each other *)
      (* This is actually implied by [make_cursor_key] *)
      (* Axiom make_cusor_abs: abs_rel (make_cursor k t) t. *)
      (* Do we need this? *)
      (* Axiom put_abs: *)
      (*   let (new_cursor, new_table) := put c e t in *)
      (*   abs_rel new_cursor new_table. *)
      (* TODO: What about at the end of range? *)
      Axiom next_cursor_abs: abs_rel c t -> abs_rel (next_cursor c t) t.
      Axiom prev_cursor_abs: abs_rel c t -> abs_rel (prev_cursor c t) t.
      Axiom first_cursor_abs: table_correct t -> abs_rel (first_cursor t) t.
      Axiom last_cursor_abs: table_correct t -> abs_rel (last_cursor t) t.
      Axiom put_correct:
        abs_rel c1 t1 ->
        put k v c1 t1 c2 t2 ->
        table_correct t2.
      Axiom empty_correct:
        empty t ->
        table_correct t.

      Axiom first_cursor_get_empty:
        table_correct t ->
        get (first_cursor t) t = None ->
        empty t.

      Axiom get_key_rel:
        abs_rel c t ->
        get_key c t = Some k ->
        key_rel k c t.

      (* permute of get and insert operations *)
      (* Assume [key_rel] does not entail [abs_rel] *)
      Axiom get_put_same:
        put k v c1 t1 c2 t2 ->
        abs_rel c1 t1 ->
        abs_rel c3 t2 ->
        key_rel k c3 t2 ->
        get c3 t2 = Some (k, v).

      Axiom get_put_diff:
        k1 <> k2 ->
        put k1 v c1 t1 c2 t2 ->
        abs_rel c1 t1 ->
        abs_rel c4 t1 ->
        key_rel k2 c4 t1 ->
        abs_rel c3 t2 ->
        key_rel k2 c3 t2 ->
        get c3 t2 = get c4 t1.

      (* get in specific conditions *)
      Axiom get_last:
        get (last_cursor t) t = None.
      Axiom get_empty:
        empty t ->
        abs_rel c t ->
        get c t = None.

      (* Cursor and keys *)

      Axiom key_rel_eq_cursor:
        key_rel k c1 t ->
        key_rel k c2 t ->
        abs_rel c1 t ->
        abs_rel c2 t ->
        eq_cursor c1 c2 t.

      Axiom eq_cursor_get:
        abs_rel c1 t ->
        abs_rel c2 t ->
        eq_cursor c1 c2 t ->
        get c1 t = get c2 t.

      Axiom make_cursor_key:
        table_correct t -> key_rel k (make_cursor k t) t.
      Axiom make_cursor_abs:
          table_correct t -> abs_rel (make_cursor k t) t.

      (* cursor movement with respect to the order of key *)
      Axiom next_prev:
        abs_rel c t -> ~ eq_cursor c (last_cursor t) t -> eq_cursor c (prev_cursor (next_cursor c t) t) t.
      Axiom prev_next:
        abs_rel c t -> ~ eq_cursor c (first_cursor t) t -> eq_cursor c (next_cursor (prev_cursor c t) t) t.
      Axiom next_order:
        ~ eq_cursor c (last_cursor t) t -> key_rel k1 c t -> key_rel k2 (next_cursor c t) t -> KeyType.lt k1 k2.
      Axiom prev_order:
        ~ eq_cursor c (first_cursor t) t -> key_rel k1 c t -> key_rel k2 (prev_cursor c t) t -> KeyType.lt k2 k1.
      (* TODO: does this definition work? *)
      Axiom next_compact:
        ~ eq_cursor c (last_cursor t) t ->
        key_rel k1 c t -> key_rel k2 (next_cursor c t) t ->
        ~ key_rel k3 c t -> KeyType.lt k1 k3 /\ KeyType.lt k3 k2.
      Axiom prev_compact:
        ~ eq_cursor c (first_cursor t) t ->
        key_rel k1 c t -> key_rel k2 (prev_cursor c t) t ->
        ~ key_rel k3 c t -> KeyType.lt k2 k3 /\ KeyType.lt k3 k1.
    End Specs.

    Axiom flatten_invariant: forall t,
        table_correct t ->
        Flattened.table_correct (flatten t) /\
        forall (k: key) (c1: cursor value) (c2: Flattened.cursor value),
          key_rel k c1 t -> Flattened.key_rel k c2 (flatten t) ->
          abs_rel c1 t -> Flattened.abs_rel c2 (flatten t) ->
          get c1 t = Flattened.get c2 (flatten t).
  End Types.
End BTree.


Require Export ProjectiveGeometry.Dev.psoh_equiv_rk_lemmas.

(*****************************************************************************)
(** Proof of projective space or higher rank axioms **)

Section s_psohEquivToRk.

Context `{PSOHR : ProjectiveSpaceOrHigherRank}.
Context `{EP : EqDecidability Point}.
Context `{OP : OrderedType Point}.
Context `{EL : EqDecidabilityL Line}.
Context `{ELI : EqDecidabilityP Line Intersect}.

Lemma matroid1a : forall e, rkl e >= 0.
Proof.
my_rank.
Qed.

Lemma matroid1b : forall e, rkl e <= cardinal e.
Proof.
intros.
induction e.
simpl.
intuition.
unfold rkl.
case_eq e.
intros.
simpl.
intuition.
intros.
case_eq (contains_four_non_coplanar_points (a :: p :: l)).
intros.
assert( HH0 := matroid3_aux3_bis_bis (a :: p :: l) H0).
assert( HH1 := list_cardinal_aux4 (a :: p :: l) HH0).
intuition.
intros.
case_eq (contains_three_non_collinear_points (a :: p :: l)).
intros.
assert( HH0 := matroid3_aux2_cop (a :: p :: l) H1 H0).
assert( HH1 := list_cardinal_aux3 (a :: p :: l) HH0).
intuition.
intros.
case_eq (contains_two_distinct_points (a :: p :: l)).
intros.
assert( HH0 := matroid3_aux2_col (a :: p :: l) H2 H1).
assert( HH1 := list_cardinal_aux2 (a :: p :: l) HH0).
intuition.
intros.
assert( HH0 := matroid3_aux3 (a :: p :: l) H2).
destruct HH0.
rewrite <-H in H3.
assert( HH1 : (a :: e) <> nil).
intro.
inversion H4.
assert( HH2 := matroid3_aux3_bis (a :: e) HH1).
destruct HH2.
rewrite H4 in H3.
inversion H3.
destruct H4.
rewrite H4 in H3.
inversion H3.
destruct H4.
rewrite H4 in H3.
inversion H3.
rewrite H4 in H3.
inversion H3.
assert( HH1 := list_cardinal_aux1 (a :: p :: l) H3).
intuition.
Qed.

Lemma matroid2 : forall e e', inclA eq e e' -> rkl(e)<=rkl(e').
Proof.
my_rank;unfold rkl;case_eq e;case_eq e';my_rank.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
subst;assert( HH := contains_four_non_coplanar_points_sublist (p0 :: p1 :: l1) (p :: nil) H H3);simpl in HH;my_rank.
subst;assert( HH := contains_four_non_coplanar_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H3);rewrite HH in H5;my_rank.
subst;assert( HH := contains_four_non_coplanar_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H3);rewrite HH in H5;my_rank.
subst;assert( HH := contains_four_non_coplanar_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H3);rewrite HH in H5;my_rank.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: nil) H H4);simpl in HH;my_rank.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H4);rewrite H7 in HH;my_rank.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H4);rewrite H7 in HH;my_rank.
subst;assert( HH := contains_two_distinct_points_sublist (p0 :: p1 :: l1) (p :: nil) H H5);simpl in HH;my_rank.
subst;assert( HH := contains_two_distinct_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H5);rewrite H9 in HH;my_rank.
Qed.

Lemma matroid3:
forall e e',
 rkl(e ++ e') + rkl(list_inter e e') <= rkl(e) + rkl(e').
Proof.
my_rank.
assert(HH0 := all_rank e).
assert(HH1 := all_rank e').
progress intuition.
- assert(HH0 := rk_nil e H);assert(HH1 := rk_nil e' H0);
subst;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux24;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux17;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux29;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux34;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux24_bis;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux24_bis_bis;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux24_bis_bis_bis;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux17_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux29_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux34_bis;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux17_bis_bis;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux17_bis_bis_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux29_bis_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux34_bis_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux29_bis_bis_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux34_bis_bis_bis;my_rank.
Qed.

Lemma rk_singleton_ge : forall p:Point, rkl (p::nil) >=1.
Proof.
my_rank.
Qed.

Lemma rk_couple_ge : forall p q:Point,~(p[==]q)-> rkl(p::q::nil)>=2.
Proof.
my_rank;
case (eq_dec_u p q);
my_rank;simpl;my_rank.
Qed.

Lemma rk_pasch : forall a b c d,
rkl (a :: b :: c :: d :: nil) <= 3 ->
exists e, rkl (a :: b :: e :: nil) = 2 /\ rkl (c :: d :: e :: nil) = 2.
Proof.
intros.
unfold rkl in H.
generalize H.
case_eq(contains_four_non_coplanar_points (a :: b :: c :: d :: nil)).
intros.
inversion H1. inversion H3. inversion H5. inversion H7.
case_eq(contains_three_non_collinear_points (a :: b :: c :: d :: nil)).
intros.
rewrite contains_1 in H0.
rewrite contains_2_cop in H1.
destruct H0.
destruct H0.
destruct H0.
destruct H0.
destruct H3.
destruct H4.
assert(HH : InA eq a (a :: b :: c :: d :: nil));[my_inA|].
assert(HH0 : InA eq b (a :: b :: c :: d :: nil));[my_inA|].
assert(HH1 : InA eq c (a :: b :: c :: d :: nil));[my_inA|].
assert(HH2 : InA eq d (a :: b :: c :: d :: nil));[my_inA|].
inversion H0;subst.
inversion H3;subst.
assert(HH3 := col_1 a x1).
rewrite HH3 in H5;inversion H5.
inversion H7;subst.
inversion H4;subst.
assert(HH3 := col_1 a b).
rewrite <-col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H8;subst.
assert(HH3 := col_2 a b).
rewrite HH3 in H5;inversion H5.
inversion H9;subst.
generalize H5.
unfold collinear.
case_eq(eq_dec_u a b).
intros.
inversion H10.
intros.
assert(HH3 := H1 a b c d HH HH0 HH1 HH2).
assert(HH4 := rk_pasch_aux2 a b c d HH3 H5);my_rank.
inversion H10;subst.
assert(HH3 := H1 a b d c HH HH0 HH2 HH1).
assert(HH4 := rk_pasch_aux2 a b d c HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H11.
inversion H8;subst.
inversion H4;subst.
assert(HH3 := col_1 a c).
rewrite <-col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H9;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 a b c d HH HH0 HH1 HH2).
assert(HH4 := rk_pasch_aux2 a b c d HH3 H5);my_rank.
inversion H10;subst.
assert(HH3 := col_2 a c).
rewrite HH3 in H5;inversion H5.
inversion H11;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 c d a b HH1 HH2 HH HH0).
assert(HH4 := rk_pasch_aux2 c d a b HH3 H5).
destruct HH4. exists x.
my_rank.
inversion H12.
inversion H9;subst.
inversion H4;subst.
assert(HH3 := col_1 a d).
rewrite <-col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H10;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 a b d c HH HH0 HH2 HH1).
assert(HH4 := rk_pasch_aux2 a b d c HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H11;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 d c a b HH2 HH1 HH HH0).
assert(HH4 := rk_pasch_aux2 d c a b HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H12;subst.
assert(HH3 := col_2 a d).
rewrite HH3 in H5;inversion H5.
inversion H13.
inversion H10.
inversion H7;subst.
inversion H3;subst.
inversion H4;subst.
assert(HH3 := col_2 b a).
rewrite HH3 in H5;inversion H5.
inversion H8;subst.
assert(HH3 := col_1 b a).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H9;subst.
assert(HH3 := H1 b a c d HH0 HH HH1 HH2).
assert(HH4 := rk_pasch_aux2 b a c d HH3 H5);my_rank.
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H10;subst.
assert(HH3 := H1 b a d c HH0 HH HH2 HH1).
assert(HH4 := rk_pasch_aux2 b a d c HH3 H5);my_rank.
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H11.
inversion H8;subst.
assert(HH3 := col_1 b x1).
rewrite HH3 in H5;inversion H5.
inversion H9;subst.
inversion H4;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 b a c d HH0 HH HH1 HH2).
assert(HH4 := rk_pasch_aux2 b a c d HH3 H5);my_rank.
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H10;subst.
assert(HH3 := col_1 b c).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H11;subst.
assert(HH3 := col_2 b c).
rewrite HH3 in H5;inversion H5.
inversion H12;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 c d b a HH1 HH2 HH0 HH).
assert(HH4 := rk_pasch_aux2 c d b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H13.
inversion H10;subst.
inversion H4;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 b a d c HH0 HH HH2 HH1).
assert(HH4 := rk_pasch_aux2 b a d c HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H11;subst.
assert(HH3 := col_1 b d).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H12;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 d c b a HH2 HH1 HH0 HH).
assert(HH4 := rk_pasch_aux2 d c b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H13;subst.
assert(HH3 := col_2 b d).
rewrite HH3 in H5;inversion H5.
inversion H14.
inversion H11.
inversion H8;subst.
inversion H3;subst.
inversion H4;subst.
assert(HH3 := col_2 c a).
rewrite HH3 in H5;inversion H5.
inversion H9;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 a b c d HH HH0 HH1 HH2).
assert(HH4 := rk_pasch_aux2 a b c d HH3 H5);my_rank.
inversion H10;subst.
assert(HH3 := col_1 c a).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H11;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 c d a b HH1 HH2 HH HH0).
assert(HH4 := rk_pasch_aux2 c d a b HH3 H5).
destruct HH4. exists x.
my_rank.
inversion H12.
inversion H9;subst.
inversion H4;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 b a c d HH0 HH HH1 HH2).
assert(HH4 := rk_pasch_aux2 b a c d HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H10;subst.
assert(HH3 := col_2 c b).
rewrite HH3 in H5;inversion H5.
inversion H11;subst.
assert(HH3 := col_1 c b).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H12;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 c d b a HH1 HH2 HH0 HH).
assert(HH4 := rk_pasch_aux2 c d b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H13.
inversion H10;subst.
assert(HH3 := col_1 c x1).
rewrite HH3 in H5;inversion H5.
inversion H11;subst.
inversion H4;subst.
assert(HH3 := H1 c d a b HH1 HH2 HH HH0).
assert(HH4 := rk_pasch_aux2 c d a b HH3 H5).
destruct HH4. exists x.
my_rank.
inversion H12;subst.
assert(HH3 := H1 c d b a HH1 HH2 HH0 HH).
assert(HH4 := rk_pasch_aux2 c d b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H13;subst.
assert(HH3 := col_1 c d).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H14;subst.
assert(HH3 := col_2 c d).
rewrite HH3 in H5;inversion H5.
inversion H15.
inversion H12.
inversion H9;subst.
inversion H3;subst.
inversion H4;subst.
assert(HH3 := col_2 d a).
rewrite HH3 in H5;inversion H5.
inversion H10;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 a b d c HH HH0 HH2 HH1).
assert(HH4 := rk_pasch_aux2 a b d c HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H11;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 d c a b HH2 HH1 HH HH0).
assert(HH4 := rk_pasch_aux2 d c a b HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H12;subst.
assert(HH3 := col_1 d a).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H13.
inversion H10;subst.
inversion H4;subst.
rewrite col_exchange in H5;rewrite col_exchange2 in H5.
assert(HH3 := H1 b a d c HH0 HH HH2 HH1).
assert(HH4 := rk_pasch_aux2 b a d c HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H11;subst.
assert(HH3 := col_2 d b).
rewrite HH3 in H5;inversion H5.
inversion H12;subst.
rewrite col_exchange2 in H5.
assert(HH3 := H1 d c b a HH2 HH1 HH0 HH).
assert(HH4 := rk_pasch_aux2 d c b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H13;subst.
assert(HH3 := col_1 d b).
rewrite col_exchange2 in HH3.
rewrite HH3 in H5;inversion H5.
inversion H14.
inversion H11;subst.
inversion H4;subst.
assert(HH3 := H1 d c a b HH2 HH1 HH HH0).
assert(HH4 := rk_pasch_aux2 d c a b HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH5;my_rank.
inversion H12;subst.
assert(HH3 := H1 d c b a HH2 HH1 HH0 HH).
assert(HH4 := rk_pasch_aux2 d c b a HH3 H5).
destruct HH4. exists x.
assert(HH5 : equivlistA eq (a :: b :: x :: nil) (b :: a :: x :: nil));[my_inA|];rewrite HH5;
assert(HH6 : equivlistA eq (c :: d :: x :: nil) (d :: c :: x :: nil));[my_inA|];rewrite HH6;my_rank.
inversion H13;subst.
assert(HH3 := col_2 d c).
rewrite HH3 in H5;inversion H5.
inversion H14;subst.
assert(HH3 := col_1 d c).
rewrite col_exchange2 in HH3;rewrite HH3 in H5;inversion H5.
inversion H15.
inversion H12;subst.
assert(HH3 := col_1 d x1).
rewrite HH3 in H5;inversion H5.
inversion H13.
inversion H10.
case_eq(contains_two_distinct_points (a :: b :: c :: d :: nil)).
intros.
assert(HH := matroid3_aux17_bis_aux1 (a :: b :: c :: d :: nil) H0).
rewrite contains_2 in H1.
assert(HH0 : InA eq a (a :: b :: c :: d :: nil));[my_inA|].
assert(HH1 : InA eq b (a :: b :: c :: d :: nil));[my_inA|].
assert(HH2 : InA eq c (a :: b :: c :: d :: nil));[my_inA|].
assert(HH3 : InA eq d (a :: b :: c :: d :: nil));[my_inA|].
destruct HH.
destruct H4.
my_rank.
case_eq(eq_dec_u a b);case_eq(eq_dec_u c d).
assert(HH4 := a1_exist a b).
destruct HH4.
assert(HH4 := a3_1 x1).
destruct HH4.
destruct s.
destruct s.
destruct a1.
destruct H8.
destruct H9.
destruct H10.
destruct H11.
intros.
rewrite e.
rewrite e0.
case_eq(eq_dec_u b x2);case_eq(eq_dec_u b x3);
case_eq(eq_dec_u d x2);case_eq(eq_dec_u d x3).
intros;clear H15;rewrite e2 in e1;contradiction.
intros;clear H17;rewrite e3 in e2;contradiction.
intros;clear H17;rewrite e3 in e2;contradiction.
intros;clear H17;rewrite e2 in e1;contradiction.
intros;clear H15;rewrite e2 in e1;contradiction.
intros;rewrite e1;rewrite e2;exists x3;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;rewrite e2;exists x4;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;exists x3;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;rewrite e3;exists x4;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;rewrite e2;exists x4;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;rewrite e2;exists x2;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;exists x2;
split;apply rk_pasch_aux0;my_rank.
intros;clear H15;rewrite e2 in e1;contradiction.
intros;rewrite e1;exists x3;
split;apply rk_pasch_aux0;my_rank.
intros;rewrite e1;exists x2;
split;apply rk_pasch_aux0;my_rank.
intros;exists x3;
split;apply rk_pasch_aux0;my_rank.
intros.
case_eq(eq_dec_u a c).
intros.
exists d.
rewrite <-e;rewrite e0.
split;apply rk_pasch_aux0;my_rank.
intros.
exists c.
assert(HH4 : equivlistA eq (a :: b :: c :: nil) (a :: c :: b :: nil));[my_inA|].
split.
rewrite HH4;apply rk_pasch_aux3;my_rank.
apply rk_pasch_aux0;my_rank.
intros.
case_eq(eq_dec_u a c).
intros.
exists b.
rewrite <-e;rewrite <-e0.
split;apply rk_pasch_aux0;my_rank.
intros.
exists a.
split.
apply rk_pasch_aux0;my_rank.
rewrite <-e.
apply rk_pasch_aux0;my_rank.
intros.
exists a.
split.
apply rk_pasch_aux0;my_rank.
assert(HH4 := H1 c d a HH2 HH3 HH0).
apply rk_pasch_aux3;my_rank.

intros.
assert(HH4 := a1_exist a b).
destruct HH4.
assert(HH4 := a3_1 x).
destruct HH4;destruct s;destruct s;destruct a1.
destruct H5;destruct H6;destruct H7;destruct H8.
simpl in H0.
generalize H0.
case_eq(eq_dec_u a b);case_eq(eq_dec_u b c);case_eq(eq_dec_u c d).
intros.
rewrite e1;rewrite e0;rewrite e.
case_eq(eq_dec_u d x0);case_eq(eq_dec_u d x1).
intros;clear H14;rewrite e3 in e2;my_rank.
intros;exists x1;split;apply rk_pasch_aux0;my_rank.
intros;exists x0;split;apply rk_pasch_aux0;my_rank.
intros;exists x1;split;apply rk_pasch_aux0;my_rank.
intros;inversion H13.
intros;inversion H13.
intros;inversion H13.
intros;inversion H13.
intros;inversion H13.
intros;inversion H13.
intros;inversion H13.
Qed.

Lemma rk_three_points : forall a b, exists c,
rkl(a :: b :: c :: nil) = 2 /\ rkl(b :: c :: nil) = 2 /\ rkl(a :: c :: nil) = 2.
Proof.
intros.
assert( HH0 := a1_exist a b).
destruct HH0.
destruct a0.
assert( HH0 := a3_1 x).
destruct HH0.
destruct s.
destruct s.
destruct a0.
destruct H2.
destruct H3.
destruct H4.
destruct H5.
case_eq (eq_dec_u a x0).
case_eq (eq_dec_u b x1).
exists x2.
intros.
rewrite e.
rewrite e0.
simpl.
case_eq (coplanar x0 x1 x2 x2).
intros.
case_eq (collinear x0 x1 x2).
intros.
case_eq (eq_dec_u x0 x1).
intros.
contradiction.
intros.
case_eq (eq_dec_u x1 x2).
intros.
contradiction.
intros.
case_eq (eq_dec_u x0 x2).
intros.
contradiction.
intros.
split.
reflexivity.
split.
reflexivity.
reflexivity.
unfold collinear.
case_eq (eq_dec_u x0 x1).
intros.
inversion H11.
destruct (a1_exist x0 x1).
simpl.
case_eq (incid_dec x2 x3).
intros.
inversion H12.
intros.
destruct a0.
assert( HH0 := uniqueness x0 x1 x x3 H4 H5 H13 H14).
destruct HH0.
contradiction.
clear H10.
rewrite <-H15 in *.
contradiction.
unfold coplanar.
case_eq (eq_dec_u x0 x1).
intros.
inversion H10.
case_eq (eq_dec_u x2 x2).
intros.
inversion H11.
intros.
apply False_ind.
apply n.
reflexivity.
intros.
exists x1.
simpl.
split.
case_eq (coplanar a b x1 x1).
case_eq (collinear a b x1).
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x1).
intros.
clear H7 H8 H9 H10.
rewrite e in e1.
rewrite e0 in e1.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H10.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x1 x3).
intros.
inversion H11.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H13 H14).
destruct HH0.
contradiction.
clear H9.
rewrite H15 in *.
contradiction.
intros.
assert(HH := cop_3 a b x1).
rewrite HH in H9.
inversion H9.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x1).
intros.
clear H10.
rewrite e in e0.
contradiction.
intros.
reflexivity.
intros.
case_eq (eq_dec_u b x1).
intros.
exists x0.
simpl.
split.
case_eq (coplanar a b x0 x0).
intros.
case_eq (collinear a b x0).
intros.
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x0).
intros.
clear H8.
rewrite e0 in e.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H11.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x0 x3).
intros.
inversion H12.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H13 H14).
destruct HH0.
contradiction.
clear H10.
rewrite <-H15 in n0.
contradiction.
intros.
assert(HH := cop_3 a b x0).
rewrite HH in H9.
inversion H9.
case_eq (eq_dec_u b x0).
intros.
clear H8.
rewrite e0 in e.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x0).
intros.
contradiction.
reflexivity.
intros.
case_eq (eq_dec_u b x0).
case_eq (eq_dec_u a x1).
intros.
exists x2.
simpl.
split.
case_eq (coplanar a b x2 x2).
case_eq (collinear a b x2).
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x2).
intros.
clear H11.
rewrite e0 in e1.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H12.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x2 x3).
intros.
inversion H13.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H15 H16).
destruct HH0.
contradiction.
clear H11.
rewrite H17 in *.
contradiction.
intros.
assert(HH := cop_3 a b x2).
rewrite HH in H11.
inversion H11.
case_eq (eq_dec_u b x2).
intros.
clear H11.
rewrite e0 in e1.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x2).
intros.
clear H12.
rewrite e in e1.
contradiction.
intros.
reflexivity.
intros.
exists x1.
split.
simpl.
case_eq (coplanar a b x1 x1).
intros.
case_eq (collinear a b x1).
intros.
case_eq (eq_dec_u a b).
intros.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
intros.
generalize H12.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H14.
destruct (a1_exist a b).
simpl.
case_eq( incid_dec x1 x3).
intros.
inversion H15.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H16 H17).
destruct HH0.
contradiction.
clear H13.
rewrite <-H18 in n2.
contradiction.
intros.
assert(HH0 := cop_3 a b x1).
rewrite HH0 in H11.
inversion H11.
split.
simpl.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
reflexivity.
simpl.
case_eq (eq_dec_u a x1).
intros.
contradiction.
intros.
reflexivity.
intros.
exists x0.
split.
simpl.
case_eq (coplanar a b x0 x0).
intros.
case_eq (collinear a b x0).
intros.
case_eq (eq_dec_u a b).
intros.
case_eq (eq_dec_u b x0).
intros.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
intros.
generalize H11.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H13.
intro.
destruct (a1_exist a b).
simpl.
case_eq(incid_dec x0 x3).
intros.
inversion H14.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H15 H16).
destruct HH0.
contradiction.
clear H12.
rewrite <-H17 in n3.
contradiction.
intros.
assert(HH := cop_3 a b x0).
rewrite HH in H10.
inversion H10.
split.
simpl.
case_eq (eq_dec_u b x0).
intros.
contradiction.
intros.
reflexivity.
simpl.
case_eq (eq_dec_u a x0).
intros.
contradiction.
intros.
reflexivity.
Qed.

Lemma rk_lower_dim : exists a b c d, rkl(a :: b :: c :: d :: nil) >= 4.
Proof.
intros.
assert( HH0 := a3_2).
destruct HH0.
destruct s.
case_eq(eq_dec_p x x0).
intros.
clear H.
unfold Intersect in i.
destruct i.
my_rank.
assert(HH := n x1).
apply False_ind.
apply HH.
my_rank.
intros.
assert(HH := a3_1 x).
assert(HH0 := a3_1 x0).
destruct HH. destruct s. destruct s. destruct a.
destruct HH0. destruct s. destruct s. destruct a.
my_rank.
exists x1. exists x2. exists x4. exists x5.
simpl.
case_eq(coplanar x1 x2 x4 x4).
case_eq(coplanar x1 x2 x5 x4).
case_eq(coplanar x1 x2 x4 x5).
case_eq(coplanar x1 x2 x5 x5).
case_eq(coplanar x1 x4 x5 x5).
case_eq(coplanar x2 x4 x5 x5).
intros.
generalize H13.
unfold coplanar.
case_eq(eq_dec_u x2 x4).
intros.
rewrite e in *.
assert(Intersect x x0).
unfold Intersect.
exists x4.
solve[intuition].
contradiction.
case_eq(eq_dec_u x5 x5).
intros.
case_eq(collinear x1 x2 x4).
unfold collinear.
case_eq(eq_dec_u x1 x2).
intros.
contradiction.
destruct (a1_exist x1 x2).
simpl.
case_eq(incid_dec x4 x7).
intros.
destruct a.
assert(HH0 := uniqueness x1 x2 x x7 H9 H10 H24 H25).
destruct HH0.
contradiction.
clear H21.
rewrite <-H26 in *.
assert(HH : Intersect x x0).
unfold Intersect.
exists x4.
solve[intuition].
contradiction.
intros.
inversion H23.
intros.
generalize H13.
unfold coplanar.
case_eq(eq_dec_u x1 x4).
intros.
rewrite e0 in *.
assert(Intersect x x0).
unfold Intersect.
exists x4.
solve[intuition].
contradiction.
case_eq(eq_dec_u x5 x5).
intros.
generalize H14.
unfold coplanar.
case_eq(eq_dec_u x1 x2).
intros.
contradiction.
case_eq(eq_dec_u x5 x5).
intros.
generalize H15.
unfold coplanar.
case_eq(eq_dec_u x1 x2).
intros.
contradiction.
case_eq(eq_dec_u x4 x5).
intros.
contradiction.
destruct(a1_exist x1 x2).
destruct(a1_exist x4 x5).
simpl.
case_eq(eq_dec_l x7 x8).
intros.
rewrite e2 in *.
destruct a.
assert(HH := uniqueness x1 x2 x x8 H9 H10 H32 H33).
destruct HH.
contradiction.
rewrite <-H34 in *.
assert(Intersect x x0).
unfold Intersect.
exists x4.
solve[intuition].
contradiction.
case_eq(eq_dec_p x7 x8).
intros.
destruct a.
destruct a0.
assert(HH := uniqueness x1 x2 x x7 H9 H10 H33 H34).
destruct HH.
contradiction.
assert(HH := uniqueness x4 x5 x0 x8 H5 H6 H35 H36).
destruct HH.
contradiction.
clear H28.
rewrite <-H37 in *.
rewrite <-H38 in *.
contradiction.
intros.
inversion H32.
intros.
contradiction.
intros.
contradiction.
intros.
apply False_ind.
apply n1.
reflexivity.
solve[intuition].
solve[intuition].
solve[intuition].
solve[intuition].
solve[intuition].
solve[intuition].
Qed.

Class MatroidRkEquiv `(Op : ObjectPoint) `(S : FSetSpecs Point) := {
rk : set Point -> nat
}.

End s_psohEquivToRk.


Require Import erasure.
Require Import Coq.Sets.Ensembles.
Require Import errorIFF.
Require Import SpecImpliesNonSpec.
Require Import Divergence.
Require Import nonspeculativeImpliesSpeculative.

Inductive specFinalState : Type :=
|Done : trm -> specFinalState
|Diverge : specFinalState
|Error : specFinalState.

Inductive waitingOnEmpty : trm -> sHeap -> Prop :=
|waitingOnEmpty_ : forall t E x H,
         decompose t E (get (fvar x)) -> heap_lookup x H = Some(sempty COMMIT) ->
         waitingOnEmpty t H.

Fixpoint specFinished H (T:pool) :=
  match T with
      |(_, unlocked nil, _, ret M)::Ts => specFinished H Ts
      |(_, unlocked nil, _, M)::Ts => waitingOnEmpty M H /\ specFinished H Ts
      |(_, specStack _ _, _, _)::Ts => specFinished H Ts
      |(_, locked _, _, _)::Ts => specFinished H Ts
      |nil => True
      | _ => False
  end.

Inductive specRunPar (M:trm) : specFinalState -> Prop :=
|specRunParDone : forall H' T tid s2 N,
    multistep (Heap.empty ivar_state)
              (tSingleton ([1], unlocked nil, nil, bind M (lambda (done (bvar 0)))))
              (Some(H', (tUnion T (tSingleton(tid, unlocked nil, s2, done N))))) ->
    specFinished H' T -> specRunPar M (Done N)
|specRunParError :
   multistep (Heap.empty ivar_state)
             (tSingleton ([1], unlocked nil, nil, bind M (lambda (done (bvar 0)))))
             None -> specRunPar M Error
|specrunParDiverge :
   SpecDiverge (Heap.empty ivar_state)
               (tSingleton([1],unlocked nil,nil,bind M (lambda (done (bvar 0))))) ->
   specRunPar M Diverge.

Inductive parFinalState : Type :=
|pDone : ptrm -> parFinalState
|pDiverge : parFinalState
|pError : parFinalState.

Inductive pWaitingOnEmpty : ptrm -> pHeap -> Prop :=
|pwaitingOnEmpty_ : forall t E x H,
                      pdecompose t E (pget (pfvar x)) -> heap_lookup x H = Some pempty ->
                      pWaitingOnEmpty t H.

Fixpoint parFinished H (T:pPool) :=
  match T with
    |pret M::Ts => parFinished H Ts
    |t::Ts => pWaitingOnEmpty t H /\ parFinished H Ts
    |nil => True
  end.

Inductive parRunPar (M:ptrm) : parFinalState -> Prop :=
|parRunParDone : forall H' T N,
                   pmultistep (Heap.empty pivar_state) (pSingle (pbind M (plambda (pdone (pbvar 0)))))
                             (Some(H', pUnion T (pSingle (pdone N)))) -> parFinished H' T ->
                   parRunPar M (pDone N)
|parRunParError : pmultistep (Heap.empty pivar_state) (pSingle (pbind M (plambda (pdone (pbvar 0)))))
                             None -> parRunPar M pError
|parRunParDiverge : ParDiverge (Heap.empty pivar_state)
                               (pSingle(pbind M (plambda (pdone (pbvar 0))))) ->
                    parRunPar M pDiverge.

Inductive specBehavior (M:trm) : (Ensemble specFinalState) :=
|specBehavior_ : forall s,
                   specRunPar M s -> Ensembles.In specFinalState (specBehavior M) s.

Inductive parBehavior (M:ptrm) : (Ensemble parFinalState) :=
|parBehavior_ : forall s, parRunPar M s -> Ensembles.In parFinalState (parBehavior M) s.

Inductive eraseBehaviors (b : Ensemble specFinalState) : Ensemble parFinalState :=
|eraseError : Ensembles.In specFinalState b Error ->
              Ensembles.In parFinalState (eraseBehaviors b) pError
|eraseDone : forall M, Ensembles.In specFinalState b (Done M) ->
                       Ensembles.In parFinalState (eraseBehaviors b) (pDone (eraseTerm M))
|eraseDiverge : Ensembles.In specFinalState b Diverge ->
                Ensembles.In parFinalState (eraseBehaviors b) pDiverge.

Theorem raw_eraseCommitEmpty : forall x H,
                             raw_heap_lookup x H = Some(sempty COMMIT) ->
                             raw_heap_lookup x (raw_eraseHeap H) = Some pempty.
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {inv H0. simpl. rewrite eq. auto. }
   {destruct i0. destruct s. eauto. simpl. rewrite eq; eauto.
    destruct s. eauto. destruct s0; simpl; rewrite eq; eauto. }
  }
Qed.

Theorem eraseCommitEmpty : forall x H,
                             heap_lookup x H = Some(sempty COMMIT) ->
                             heap_lookup x (eraseHeap H) = Some pempty.
Proof.
  intros. destruct H. simpl. eapply raw_eraseCommitEmpty. eauto.
Qed.

Theorem waitingOnEmptyEq : forall e H,
                             waitingOnEmpty e H->
                             pWaitingOnEmpty (eraseTerm e) (eraseHeap H).
Proof.
  intros. inv H0. erewrite <- decomposeErase in H2; eauto. econstructor.
  simpl in *. eassumption. eapply eraseCommitEmpty; eauto.
Qed.

Theorem specFinishedParFinished : forall H T,
                                    specFinished H T ->
                                    parFinished (eraseHeap H) (erasePool T).
Proof.
  induction T; intros.
  {auto. }
  {destruct a. destruct p. destruct p. destruct a.
   {simpl in *. auto. }
   {destruct l0. simpl in H0. destruct t; try solve[invertHyp;
    eapply waitingOnEmptyEq in H1; simpl in *; split; auto].
    simpl. eauto. simpl in *. contradiction. }
   {simpl in *. auto. }
  }
Qed.

Ltac proveWF := econstructor; simpl; erewrite rawHeapsEq; auto; constructor.

Fixpoint sourceProg t :=
  match t with
      |fvar x => True
      |bvar x => True
      |unit => True
      |pair_ e1 e2 => sourceProg e1 /\ sourceProg e2
      |lambda e => sourceProg e
      |AST.app e1 e2 => sourceProg e1 /\ sourceProg e2
      |ret e => sourceProg e
      |bind e1 e2 => sourceProg e1 /\ sourceProg e2
      |fork e => sourceProg e
      |new => True
      |put e1 e2 => sourceProg e1 /\ sourceProg e2
      |get e => sourceProg e
      |raise e => sourceProg e
      |handle e1 e2 => sourceProg e1 /\ sourceProg e2
      |spec e1 e2 => sourceProg e1 /\ sourceProg e2
      |specRun e1 e2 => False
      |specJoin e1 e2 => False
      |fst e => sourceProg e
      |snd e => sourceProg e
      |done e => sourceProg e
  end.

Theorem eraseSourceProg : forall M, sourceProg M -> psourceProg (eraseTerm M).
Proof.
  induction M; intros; simpl; auto;
  try solve[simpl in *; invertHyp; apply IHM1 in H0; apply IHM2 in H1; auto].
Qed.

Theorem specEraseTerm : forall M, specTerm (eraseTerm M) = M.
Proof.
  induction M; intros; auto; try solve[
  simpl; rewrite IHM1; rewrite IHM2; auto];
  simpl; rewrite IHM; auto.
Qed.

Theorem specFinishedComm : forall T1 H T2, specFinished H (tUnion T1 T2) <->
                                           (specFinished H T1 /\ specFinished H T2).
Proof.
  induction T1; intros; split; intros.
  {simpl in *. auto. }
  {simpl in *. invertHyp. auto. }
  {destruct a. destruct p. destruct p. destruct a.
   {simpl in *. eapply IHT1; eauto. }
   {destruct l0. simpl in *.
    destruct t; try solve[invertHyp; eapply IHT1 in H2; invertHyp; eauto].
    eapply IHT1; eauto. contradiction. }
   {simpl in *. eapply IHT1; eauto. }
  }
  {destruct a. destruct p. destruct p. destruct a.
   {simpl in *. eapply IHT1; eauto. }
   {destruct l0. simpl in *.
    destruct t; try solve[invertHyp; split; eauto; eapply IHT1; eauto].
    eapply IHT1; eauto. simpl in *. invertHyp; auto. }
   {simpl in *. eapply IHT1; eauto. }
  }
Qed.

Theorem gatherFinished : forall t T H,
                           gather t T -> specFinished H T.
Proof.
  intros. induction H0; try solve[constructor]; eauto;
          try solve[rewrite specFinishedComm; eauto].
  {repeat rewrite specFinishedComm. simpl. eauto. }
Qed.

Theorem parWaitingOneEmpty : forall H t' H' t, pWaitingOnEmpty t H -> specHeap H H' ->
                                         t' = specTerm t -> waitingOnEmpty t' H'.
Proof.
  intros. inv H0. apply decomposeSpec in H4. econstructor. simpl in *. eauto.
  eapply specHeapLookupEmpty; eauto.
Qed.

Theorem parFinishedSpecFinished : forall H H' T T',
                                    specHeap H H' -> speculate T T' ->
                                    parFinished H T -> specFinished H' T'.
Proof.
  induction T; intros.
  {inv H2. inv H1. simpl. auto. }
  {inv H1. rewrite specFinishedComm. split.
   eapply gatherFinished; eauto. simpl in *.
   destruct a; simpl; eauto; invertHyp; split; eauto; eapply parWaitingOneEmpty; eauto. }
Qed.

Theorem SpecEqPar : forall M,
                      sourceProg M ->
                      eraseBehaviors (specBehavior M) = parBehavior (eraseTerm M).
Proof.
  intros. eqSets.
  {inv H0.
   {inv H1. constructor. inv H0. constructor. eapply specErrorParErrorStar in H1.
    simpl in *. unfold Heap.empty. erewrite rawHeapsEq. eauto. auto. proveWF. }
   {inv H1. inv H0. copy H2. eapply specImpliesNonSpecMulti in H2. invertHyp.
    constructor. rewrite eraseUnionComm in H1. simpl in H1. econstructor.
    unfold Heap.empty. erewrite rawHeapsEq. eassumption. auto.
    apply specFinishedParFinished; auto. proveWF. }
   {inv H1. inv H0. constructor. eapply SpecDivergeParDiverge in H1. constructor.
    unfold Heap.empty. erewrite rawHeapsEq. simpl in *. eassumption. auto. proveWF. }
  }
  {inv H0. inv H1.
   {existTac N. constructor. constructor. apply eraseSourceProg in H.
    gatherTac (eraseTerm M). copy H. eapply gatherSourceProg in H; eauto. copy H0.
    eapply nonspecImpliesSpecStar in H0;[idtac|idtac|idtac|constructor|constructor].
    Focus 2. constructor. constructor. constructor. eauto. repeat constructor.
    Focus 2. simpl. repeat split; auto. invertHyp. simpl in H0.
    apply specUnionComm in H. invertHyp. inv H. inv H9. inv H11. apply pmultistepWF in H4.
    invertHyp. apply poolWFComm in H. simpl in *. invertHyp.
    eapply gatherSourceProg in H; eauto. subst. simpl in H0. econstructor.
    repeat rewrite specEraseTerm in H0. unfold Heap.empty.
    erewrite (rawHeapsEq ivar_state). eassumption. auto.
    eapply parFinishedSpecFinished; eauto. simpl. auto. constructor. }
   {assert(specTerm (eraseTerm M) = M). rewrite specEraseTerm. auto.
    constructor. constructor. constructor. eapply ParErrorSpecErrorStar in H0.
    eauto. unfold Heap.empty. erewrite (rawHeapsEq ivar_state); auto. constructor.
    constructor. constructor. apply eraseSourceProg in H. constructor. auto.
    repeat constructor. constructor. rewrite <- union_empty_l. rewrite <- H1.
    replace (bind(specTerm(eraseTerm M)) (lambda(done(bvar 0)))) with
    (specTerm(pbind (eraseTerm M) (plambda(pdone (pbvar 0))))); auto. rewrite specEraseTerm.
    constructor. constructor. rewrite <- union_empty_l. constructor. apply eraseSourceProg in H.
    gatherTac (eraseTerm M). copy H3. eapply gatherSourceProg in H3; eauto. rewrite H3 in H2.
    auto. repeat constructor. }
   {assert(specTerm (eraseTerm M) = M). rewrite specEraseTerm. auto.
    constructor. constructor. constructor. eapply ParDivergeSpecDiverge in H0.
    eauto. unfold Heap.empty. erewrite (rawHeapsEq ivar_state); auto. constructor.
    rewrite <- union_empty_l. rewrite <- H1.
    replace (bind(specTerm(eraseTerm M)) (lambda(done(bvar 0)))) with
    (specTerm(pbind (eraseTerm M) (plambda(pdone (pbvar 0))))); auto. rewrite specEraseTerm.
    constructor. constructor. rewrite <- union_empty_l. constructor. apply eraseSourceProg in H.
    gatherTac (eraseTerm M). copy H3. eapply gatherSourceProg in H3; eauto. rewrite H3 in H2.
    auto. repeat constructor. constructor. simpl. apply eraseSourceProg in H. auto. }
  }
  Grab Existential Variables. constructor. constructor. constructor.
Qed.

(*Assumed based on previous work*)
Axiom ParDet : forall M M' M'', parRunPar M M' -> parRunPar M M'' -> M' = M''.

Ltac SpecDetTac :=
  match goal with
      |H:_ |- _ => eapply specImpliesNonSpecMulti in H
      |H:_ |- _ => eapply specErrorParErrorStar in H
      |H:_ |- _ => apply SpecDivergeParDiverge in H
  end.

Ltac runParDoneTac M N :=
  try(rewrite eraseUnionComm in *);
  assert(parRunPar (eraseTerm M) (pDone (eraseTerm N))) by
    (econstructor;[simpl in *; unfold Heap.empty; erewrite rawHeapsEq; eauto|
                   eapply specFinishedParFinished; eauto]).

Ltac runParErrorTac M :=
  assert(parRunPar (eraseTerm M) pError) by
    (constructor; simpl in *; unfold Heap.empty; erewrite rawHeapsEq; eauto).

Ltac runParDivergeTac M :=
  assert(parRunPar (eraseTerm M) pDiverge) by
    (constructor; simpl in *; unfold Heap.empty; erewrite rawHeapsEq; eauto).

Ltac resultsDisagree :=
  match goal with
      |H:parRunPar ?M ?N,H':parRunPar ?M ?N' |- _ => eapply ParDet in H; eauto; solveByInv
  end.

Theorem SpecDet : forall M M' M'', specRunPar M M' -> specRunPar M M'' -> M' = M''.
Proof.
  intros. inv H; inv H0; try (SpecDetTac;[SpecDetTac;[idtac|proveWF]|proveWF]); auto.
  {invertHyp. runParDoneTac M N. runParDoneTac M N0. eapply ParDet in H; eauto.
   inv H. apply eraseTermUnique in H6. subst. auto. }
  {invertHyp. runParDoneTac M N. runParErrorTac M. resultsDisagree. }
  {invertHyp. runParDoneTac M N. runParDivergeTac M. resultsDisagree. }
  {invertHyp. runParDoneTac M N. runParErrorTac M. resultsDisagree. }
  {runParErrorTac M. runParDivergeTac M. resultsDisagree. }
  {invertHyp. runParDoneTac M N. runParDivergeTac M. resultsDisagree. }
  {runParDivergeTac M. runParErrorTac M. resultsDisagree. }
Qed.


(* Bug #2136

The fsetdec tactic seems to get confused by hypotheses like
    HeqH1 : H1 = MkEquality s0 s1 b
If I clear them then it is able to solve my goal; otherwise it is not.
I would expect it to be able to solve the goal even without this hypothesis
being cleared. A small, self-contained example is below.

I have coq r12238.

Thanks
Ian
*)

Require Import FSets.
Require Import Arith.
Require Import FSetWeakList.

Module DecidableNat.
Definition t := nat.
Definition eq := @eq nat.
Definition eq_refl := @refl_equal nat.
Definition eq_sym := @sym_eq nat.
Definition eq_trans := @trans_eq nat.
Definition eq_dec := eq_nat_dec.
End DecidableNat.

Module NatSet := Make(DecidableNat).

Module Export Dec := WDecide (NatSet).
Import FSetDecideAuxiliary.

Parameter MkEquality : forall ( s0 s1 : NatSet.t )
                              ( x : nat ),
                       NatSet.Equal s1 (NatSet.add x s0).

Lemma ThisLemmaWorks : forall ( s0 s1 : NatSet.t )
                              ( a b : nat ),
                       NatSet.In a s0
                    -> NatSet.In a s1.
Proof.
intros.
remember (MkEquality s0 s1 b) as H1.
clear HeqH1.
fsetdec.
Qed.

Lemma ThisLemmaWasFailing : forall ( s0 s1 : NatSet.t )
                              ( a b : nat ),
                       NatSet.In a s0
                    -> NatSet.In a s1.
Proof.
intros.
remember (MkEquality s0 s1 b) as H1.
fsetdec.
(*
Error: Tactic failure: because the goal is beyond the scope of this tactic.
*)
Qed.


From QuickChick Require Import QuickChick.

Require Import Machine.

Require Import ZArith.
Require Import List.

Require Import TestingCommon.
Require Import Indist.
Require Import BespokeGenerator.
Require Import Shrinking.

Require Import Printing.

(* Leverage the pair/V functions and making everything observable,
   create (inefficient) instances for a single machine *)

(* Generates an SSNI-oriented single machine SState *)
Definition genSState : G SState :=
  bindGen gen_variation_SState (fun v =>
  let '(Var _ st _) := v in
  returnGen st).

Instance gSState : Gen SState :=
{|
  arbitrary := @genSState
|}.

Instance shrSState : Shrink SState :=
{| shrink x :=
    let all : list (@Variation SState):= shrinkVSState (Var top x x) in
    let SState_of_var v := let '(Var _ x _) := v in x in
    filter (indist top x) (List.map SState_of_var all)
|}.

Instance showSState : Show SState :=
{|
  show x := show_pair top x x
|}.