Local Open Scope logic.
Hint Rewrite <- prop_and : gather_prop.
Hint Rewrite gather_prop_left gather_prop_right : gather_prop.
Definition not_a_prop {A} (P: A) := True.
Ltac not_a_prop := match goal with
| |- not_a_prop  (prop _) => fail 1
| |- _ => apply Coq.Init.Logic.I
end.
Hint Rewrite @gather_prop3 using not_a_prop : gather_prop.
Hint Rewrite @gather_prop4 using not_a_prop : gather_prop.
Hint Rewrite @gather_prop5 using not_a_prop : gather_prop.
Hint Rewrite @sepcon_andp_prop @sepcon_andp_prop' : gather_prop.
(*Hint Rewrite <- sepcon_assoc : gather_prop.*)
(* These versions can sometimes take minutes, when A and B can't be unified Hint Extern 1 (_ |-- _) => (simple apply (@derives_refl mpred _) ) : cancel. Hint Extern 1 (_ |-- |> _) => (simple apply (@now_later mpred _ _) ) : cancel. *)
Hint Extern 2 (?A |-- ?B) => (constr_eq A B; simple apply derives_refl) : cancel.
Hint Extern 2 (?A |-- |> ?B) => (constr_eq A B; simple apply now_later) : cancel.
Ltac cancel1 :=
first [
simple apply cancel1_here; [
try match goal with H := _ : list mpred |- _ => clear H end; (*
this line is to work around Coq 8.4 bug,
Anomaly: undefined_evars_of_term *)
solve [eauto with nocore cancel]
| ]
| simple apply cancel1_next; cancel1
| simple apply cancel1_last; [
try match goal with H := _ : list mpred |- _ => clear H end; (*
this line is to work around Coq 8.4 bug,
Anomaly: undefined_evars_of_term *)
solve [eauto with nocore cancel] | ]
].
Ltac cancel2 :=
simple apply cancel1_start;
cancel1;
repeat simple apply cancel1_finish1;
try simple apply cancel1_finish2.
Ltac lift1 a e1 rho  :=
match e1 with
| lift0 rho => constr:(a)
| lift0 ?a1 => constr: (lift0 (a a1))
| _ => constr:(lift1 a e1)
end.
Ltac lift2 a e1 e2 rho :=
match e1 with
|  lift0 ?a1 => lift1 (a a1) e2 rho
| _ => constr:(lift2 a e1 e2)
end.
Ltac lift3 a e1 e2 e3 rho :=
match e1 with
|  lift0 ?a1 => lift2 (a a1) e2 e3 rho
| _ => constr:(lift3 a e1 e2 e3)
end.
Ltac lift4 a e1 e2 e3 e4 rho :=
match e1 with
|  lift0 ?a1 => lift3 (a a1) e2 e3 e4 rho
| _ => constr:(lift4 a e1 e2 e3 e4)
end.
Ltac abstract_env rho P :=
match P with
| @emp mpred _ _ => constr:(@emp (environ->mpred) _ _)
| @sepcon mpred _ _ ?e1 ?e2 =>
let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2
in constr:(@sepcon (environ->mpred) _ _ e1' e2')
| ?a0 ?a1 ?a2 ?e1 ?e2 ?e3 ?e4 =>
let e1' := abstract_env rho e1  in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
in lift3 (a0 a1 a2) e1' e2' e3' e4' rho
| ?a0 ?a1 ?e1 ?e2 ?e3 ?e4 =>
let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
in lift3 (a0 a1) e1' e2' e3' e4' rho
| ?a0 ?e1 ?e2 ?e3 ?e4 =>
let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3 in let e4' := abstract_env rho e4
in lift4 a0 e1' e2' e3' e4' rho
| ?a0 ?e1 ?e2 ?e3 =>
let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2 in let e3' := abstract_env rho e3
in lift3 a0 e1' e2' e3' rho
| ?a0 ?e1 ?e2 =>
let e1' := abstract_env rho e1 in let e2' := abstract_env rho e2
in lift2 a0 e1' e2' rho
| ?a0 ?e1 => let e1' := abstract_env rho e1 in lift1 a0 e1' rho
| rho => constr: (lift1)
| ?a => constr:(lift0 a)
end.
Ltac fixup_lifts :=
repeat
match goal with
| |- context[@lift0 mpred] => change (@lift0 mpred) with (@liftx (LiftEnviron mpred))
| |- context[@lift1 ?A] => change (@lift1 A mpred) with (@liftx (Tarrow A (LiftEnviron mpred)))
| |- context[@lift2 ?A ?B] =>  change (@lift2 A B mpred) with (@liftx (Tarrow A (Tarrow B (LiftEnviron mpred))))
| |- context[@lift3 ?A ?B ?C] => change (@lift3 A B C mpred) with (@liftx (Tarrow A (Tarrow B (Tarrow C (LiftEnviron mpred)))))
| |- context[@lift4 ?A ?B ?C ?D] => change (@lift4 A B C D mpred) with (@liftx (Tarrow A (Tarrow B (Tarrow C (Tarrow D (LiftEnviron mpred))))))
end.
Fixpoint fold_right_sepconx (l: list mpred) : mpred :=
match l with
| nil => emp
| a::nil => a
| a::b => a * fold_right_sepconx b
end.
Definition fold_left_sepconx (l: list mpred) : mpred :=
match l with
| nil => emp
| a::l => (fix fold_left_sepconx (a: mpred) (l: list mpred) {struct l}: mpred :=
match l with
| nil => a
| b :: l => fold_left_sepconx (sepcon a b) l
end) a l
end.
Ltac unfold_right_sepcon A :=
lazymatch A with
| (?B * ?C)%logic => let x := unfold_right_sepcon C
in let y := constr:(B :: x)
in y
| ?D => let y := constr:(D::nil) in y
end.
Ltac cancel_frame :=
match goal with
| |- _ |-- fold_right_sepcon _  => (* setup *)
rewrite !sepcon_assoc; cancel_frame
| F := ?v |- ?A |-- fold_right_sepcon ?F  => (* fast way *)
is_evar v;
apply fold_right_sepconx_eqx;
let w := unfold_right_sepcon A
in instantiate (1:=w) in (value of F);
unfold F;
unfold fold_right_sepconx;
simple apply derives_refl
(* | |- _ |-- fold_right_sepcon ?F  =>  (* slow way *)
repeat apply cancel_frame2_low;
try (unfold F; apply cancel_frame0_low);
try (unfold F; apply cancel_frame1_low)
*)
| |- ?P |-- fold_right _ _ ?F ?rho  =>
let P' := abstract_env rho P in
change ( P' rho |-- fold_right sepcon emp F rho);
fixup_lifts; cbv beta;
repeat rewrite sepcon_assoc;
repeat match goal with |- (_ * _) _ |-- _ =>
apply cancel_frame2
end;
try (unfold F; apply cancel_frame1);
try (instantiate (1:=nil) in (value of F); unfold F; apply cancel_frame0)
end.
Ltac pull_left A :=
(* For some reason in Coq 8.4pl3 and perhaps other versions, this works better than the version in log_normalize which is simply, repeat rewrite <- (pull_right A) || rewrite <- (pull_right0 A) and which sometimes fails when the terms get complicated. *)
repeat match goal with
| |- context [?Q * ?R * A] => rewrite <- (pull_right A Q R)
| |- context [?Q * A] => rewrite <- (pull_right0 A Q)
end.
Ltac qcancel P :=
lazymatch P with
| sepcon ?A ?B =>
match goal with |- _ |-- ?Q =>
try match Q with context [A] =>
let a := fresh "A" in set (a:=A);
rewrite ?(pull_left_special0 a), ?(pull_left_special a);
apply cancel_left;
clear a
end;
qcancel B
end
| ?A =>
try match goal with |- _ |-- ?Q =>
lazymatch Q with context [A] =>
let a := fresh "A" in set (a:=A);
rewrite ?(pull_left_special0 a), ?(pull_left_special a);
rewrite ?(pull_left_special0 A), ?(pull_left_special A);
apply cancel_left;
clear a
end
end
end.
Ltac is_Type_or_type T :=
match type of T with
| Type => idtac
| type => idtac
end.
Ltac local_cancel_in_syntactic_cancel unify_tac :=
cbv beta;
match goal with |- ?A |-- ?B =>
solve [ constr_eq A B; simple apply (derives_refl A)
| tryif first [has_evar A | has_evar B] then fail else auto with nocore cancel
| apply derives_refl'; unify_tac ]
end.
Ltac syntactic_cancel local_tac :=
repeat first
[ simple apply syntactic_cancel_nil
| simple apply syntactic_cancel_cons;
[ find_nth local_tac
| cbv iota; unfold delete_nth; cbv zeta iota
]
].
(* To solve: Frame := ?Frame |- fold_right_sepcon G |-- fold_right_sepcon L * fold_right_sepcon Frame *)
Ltac cancel_for_evar_frame' local_tac :=
eapply syntactic_cancel_spec1;
[ syntactic_cancel local_tac
| cbv iota; cbv zeta beta;
first [ match goal with
| |- _ |-- _ * fold_right_sepcon ?F => try unfold F
end;
simple apply syntactic_cancel_solve1
| match goal with
| |- fold_right_sepcon ?A |-- fold_right_sepcon ?B * _ => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
end;
unfold fold_left_sepconx; cbv iota beta ]
].
(* To solve: |- fold_right_sepcon G |-- fold_right_sepcon L * TT *)
Ltac cancel_for_TT local_tac :=
eapply syntactic_cancel_spec1;
[ syntactic_cancel local_tac
| cbv iota; cbv zeta beta;
first [ simple apply syntactic_cancel_solve2
| match goal with
| |- fold_right_sepcon ?A |-- fold_right_sepcon ?B * _ => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
end;
unfold fold_left_sepconx; cbv iota beta ]
].
Ltac cancel_for_normal local_tac :=
eapply syntactic_cancel_spec3;
[ syntactic_cancel local_tac
| cbv iota; cbv zeta beta;
first [ simple apply syntactic_cancel_solve3
| match goal with
| |- fold_right_sepcon ?A |-- fold_right_sepcon ?B => rewrite <- (fold_left_sepconx_eq A), <- (fold_left_sepconx_eq B)
end;
unfold fold_left_sepconx; cbv iota beta ]
].
(* return Some true exists TT, return Some false if exists fold_right_sepcon. *)
(* unused? Ltac Check_normal_mpred_list_rec L := match L with | nil => constr:(@None bool) | cons TT _ => constr:(Some true) | cons (fold_right_sepcon _) _ => constr:(Some false) | cons _ ?L0 => Check_normal_mpred_list_rec L0 end.  Ltac Check_pre_no_TT L := let res := Check_normal_mpred_list_rec L in match res with | Some true => fail 1000 "No TT should appear in the SEP clause of a funcspec's precondition" | _ => idtac end. *)
Inductive merge_abnormal_mpred: mpred -> option mpred -> option mpred -> Prop :=
| merge_abnormal_mpred_None: forall P, merge_abnormal_mpred P None (Some P)
| merge_abnormal_mpred_TT_Some: forall P, merge_abnormal_mpred TT (Some P) (Some P)
| merge_abnormal_mpred_Some_TT: forall P, merge_abnormal_mpred P (Some TT) (Some P).
Inductive fold_abnormal_mpred: list mpred -> list mpred -> option mpred -> Prop :=
| fold_abnormal_mpred_nil:
fold_abnormal_mpred nil nil None
| fold_abnormal_mpred_TT: forall R res R' res',
fold_abnormal_mpred R R' res ->
merge_abnormal_mpred TT res res' ->
fold_abnormal_mpred (TT :: R) R' res'
| fold_abnormal_mpred_fold: forall F R res R' res',
fold_abnormal_mpred R R' res ->
merge_abnormal_mpred (fold_right_sepcon F) res res' ->
fold_abnormal_mpred ((fold_right_sepcon F) :: R) R' res'
| fold_abnormal_mpred_normal: forall P R R' res,
fold_abnormal_mpred R R' res ->
fold_abnormal_mpred (P :: R) (P :: R') res.
Definition Some_or_emp (res: option mpred) := match res with | Some P => P | _ => emp end.
Inductive construct_fold_right_sepcon_rec: mpred -> list mpred -> list mpred -> Prop :=
| construct_fold_right_sepcon_rec_sepcon: forall P Q R R' R'',
construct_fold_right_sepcon_rec Q R R' ->
construct_fold_right_sepcon_rec P R' R'' ->
construct_fold_right_sepcon_rec (P * Q) R R''
| construct_fold_right_sepcon_rec_emp: forall R,
construct_fold_right_sepcon_rec emp R R
| construct_fold_right_sepcon_rec_single: forall P R,
construct_fold_right_sepcon_rec P R (P :: R).
Local Unset Elimination Schemes. (* ensure that we avoid name collision with the above *)
Inductive construct_fold_right_sepcon: mpred -> list mpred-> Prop :=
| construct_fold_right_sepcon_constr: forall P R,
construct_fold_right_sepcon_rec P nil R ->
construct_fold_right_sepcon P R.
Scheme Minimality for construct_fold_right_sepcon Sort Prop.
Local Set Elimination Schemes.
Definition before_symbol_cancel (P Q: list mpred) (res: option mpred): Prop :=
match res with
| Some R => fold_right_sepcon P |-- fold_right_sepcon Q * R
| None => fold_right_sepcon P |-- fold_right_sepcon Q
end.
Ltac construct_fold_right_sepcon_rec :=
match goal with
| |- construct_fold_right_sepcon_rec (sepcon _ _) _ _ =>
eapply construct_fold_right_sepcon_rec_sepcon;
[construct_fold_right_sepcon_rec | construct_fold_right_sepcon_rec]
| |- construct_fold_right_sepcon_rec emp _ _ =>
apply construct_fold_right_sepcon_rec_emp
| _ =>
apply construct_fold_right_sepcon_rec_single
end.
Ltac merge_abnormal_mpred :=
first
[ simple apply merge_abnormal_mpred_None
| simple apply merge_abnormal_mpred_TT_Some
| simple apply merge_abnormal_mpred_Some_TT
| fail 1000 "There should not be two fold_right_sepcon in the right side."
].
Ltac construct_fold_right_sepcon :=
apply construct_fold_right_sepcon_constr;
construct_fold_right_sepcon_rec.
Ltac is_evar_def F := try first [is_var F; unfold F; fail 1 | fail 2 F "is not evar definition"].
Ltac fold_abnormal_mpred :=
match goal with
| |- fold_abnormal_mpred nil _ _ =>
simple apply fold_abnormal_mpred_nil
| |- fold_abnormal_mpred (?P :: _) _ _ =>
match P with
| TT => simple eapply fold_abnormal_mpred_TT; [fold_abnormal_mpred | merge_abnormal_mpred]
| prop True => simple eapply fold_abnormal_mpred_TT; [fold_abnormal_mpred | merge_abnormal_mpred]
| fold_right_sepcon ?F =>
is_evar_def F;
simple eapply fold_abnormal_mpred_fold; [fold_abnormal_mpred | merge_abnormal_mpred]
| _ => simple apply fold_abnormal_mpred_normal; fold_abnormal_mpred
end
end.
Ltac new_cancel local_tac :=
match goal with
| |- @derives mpred Nveric _ _ => idtac
| _ => fail 1000 "Tactic cancel can only handle proof goals with form _ |-- _ (unlifted version)."
end;
eapply symbolic_cancel_setup;
[ construct_fold_right_sepcon
| construct_fold_right_sepcon
| fold_abnormal_mpred
| match goal with
| |- before_symbol_cancel _ _ None =>
cbv iota beta delta [before_symbol_cancel];
cancel_for_normal local_tac
| |- before_symbol_cancel _ _ (Some (fold_right_sepcon _)) =>
cbv iota beta delta [before_symbol_cancel];
cancel_for_evar_frame' local_tac
| |- before_symbol_cancel _ _ (Some TT) =>
cbv iota beta delta [before_symbol_cancel];
cancel_for_TT local_tac
| |- before_symbol_cancel _ _ (Some (prop True)) =>
cbv iota beta delta [before_symbol_cancel];
cancel_for_TT local_tac
end
].
Ltac cancel_unify_tac :=
autorewrite with cancel;
careful_unify.
Ltac cancel_local_tac :=
cbv beta;
match goal with |- ?A |-- ?B =>
solve [ constr_eq A B; simple apply (derives_refl A)
| auto with nocore cancel
| apply derives_refl'; cancel_unify_tac]
end.
Ltac cancel ::= new_cancel cancel_local_tac.
Ltac no_evar_cancel_local_tac := local_cancel_in_syntactic_cancel cancel_unify_tac.
Ltac no_evar_cancel := new_cancel no_evar_cancel_local_tac.
Ltac ecancel_unify_tac :=
autorewrite with cancel;
ecareful_unify.
Ltac ecancel_local_tac := local_cancel_in_syntactic_cancel ecancel_unify_tac.
Ltac pure_ecancel := new_cancel ecancel_local_tac.
Ltac ecancel := no_evar_cancel; pure_ecancel.
Ltac old_local_tac := local_cancel_in_syntactic_cancel careful_unify.
Ltac cancel_for_evar_frame := cancel_for_evar_frame' ecancel_local_tac.
Ltac info_cancel_local_tac :=
(tryif try (cancel_local_tac; gfail 1)
then match goal with |- ?Goal => idtac Goal "fail" end
else match goal with |- ?Goal => idtac Goal "success" end);
cancel_local_tac.
Ltac info_cancel := new_cancel info_cancel_local_tac.
Ltac info_ecancel_local_tac :=
(tryif try (ecancel_local_tac; gfail 1)
then match goal with |- ?Goal => idtac Goal "fail" end
else match goal with |- ?Goal => idtac Goal "success" end);
ecancel_local_tac.
Ltac info_ecancel := info_cancel; new_cancel info_ecancel_local_tac.

(*  Export ListNotations.  Goal forall A B C D E F G H I J K L: mpred, A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) |-- (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) * (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).  Lemma cancel_emp_wand: forall P Q R: mpred, P |-- Q -> P |-- Q * (R -* R).  Ltac cancel_wand := repeat match goal with |- _ |-- ?B => match B with context [?A -* ?A] => rewrite ?sepcon_assoc; pull_right (A -* A); first [apply cancel_emp_wand | apply wand_refl_cancel_right] end end.  Ltac norm_rewrite := autorewrite with norm. (* New version: rewrite_strat (topdown hints norm). But this will have to wait for a future version of Coq in which rewrite_strat discharges side conditions. According to Matthieu Sozeau, in the Coq trunk as of June 5, 2013, rewrite_strat is documented AND discharges side conditions. It might be about twice as fast, or 1.7 times as fast, as the old autorewrite. And then, maybe use "bottomup" instead of "topdown", see if that's better.  To test whether your version of Coq works, use this: *)
Lemma TEST_L : forall n:nat, n=n -> (n + 1 = S n)%nat.