Ltac is_evar_def F := try first [is_var F; unfold F; fail 1 | fail 2 F "is not evar definition"].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 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).
Proof.
  intros.
  Time
  do 4
  match goal with
  | |- ?P => assert (P /\ P /\ P); [| tauto]; split; [| split]
  end;
  (rewrite ?sepcon_assoc;
  repeat match goal with |- ?A * _ |-- ?B * _ => 
     constr_eq A B;  simple apply (cancel_left A)
  end;
  match goal with |- ?P |-- _ => qcancel P end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  try match goal with |- ?A |-- ?B => 
       constr_eq A B; simple apply (derives_refl A)
  end;
  match goal with |- ?P |-- _ =>
   (* The "emp" is a marker to notice when one complete pass has been made *)
   rewrite <- (emp_sepcon P)
  end;
  repeat rewrite <- sepcon_assoc;
  repeat match goal with
    | |- sepcon _ emp |-- _ => fail 1
    | |- sepcon _ TT |-- _ => pull_left (@TT mpred _)
    | |- sepcon _ ?P' |-- _ => first [ cancel2 | pull_left P' ]
   end;
  repeat first [rewrite emp_sepcon | rewrite sepcon_emp];
  pull_left (@TT mpred _);
  first [ simpl; apply derives_refl'; solve [careful_unify]
            (* this is NOT a _complete_ tactic;
                 for example, "simple apply derives_refl" would be more complete.  But that
                 tactic can sometimes take minutes to discover that something doesn't unify;
                 what I have here is a compromise between reliable speed, and (in)completeness.
               *)
          | apply TT_right
          | apply @sepcon_TT; solve [auto with nocore typeclass_instances]
          | apply @TT_sepcon; solve [auto with nocore typeclass_instances]
          | cancel_frame
          | idtac
          ]).


  cancel. (* New cancel: 8.983 9.199 8.599 *)
          (* Old cancel: 133.919 133.224 138.729 *)
Abort




Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * (A * A) * TT.
Proof.
  intros.
  Time
  do 4
  match goal with
  | |- ?P => assert (P /\ P /\ P); [| tauto]; split; [| split]
  end;
(* cancel. (* 4.323 4.275 3.887 3.763 3.684 3.66 3.6 3.534 3.616 3.6 3.591 3.606 *) *)
(*  new_cancel. (* 0.615 0.656 0.655 0.653 0.687 *) *)

Goal forall A B C D: mpred,
  A * B * (C * fold_right_sepcon [A; B] * A) * B |-- B * (A * A) * fold_right_sepcon [A; B].
Proof.
  intros.
  cancel.

Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * TT * (A * A).
Proof.
  intros.
  new_cancel.

Goal forall A B C D: mpred, exists F': list mpred,
  let F := F' in
  A * B * (C * A) * B |-- B * (A * A) * fold_right_sepcon F.
Proof.
  intros; eexists; intros.
  new_cancel.

Goal forall A B C D: mpred,
  A * B * (C * A) * B |-- B * (A * D).
Proof.
  intros.
  new_cancel.


Goal forall A B C D: mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A; D].
Proof.
  intros.
  cancel_for_normal.

Goal forall A B C D: mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A] * TT.
Proof.
  intros.
  cancel_for_TT.

Goal forall A B C D: mpred, exists F: list mpred,
  fold_right_sepcon [A; B; C; A; B] |-- fold_right_sepcon [B; A] * fold_right_sepcon F.
Proof.
  intros.
  eexists.
  cancel_for_evar_frame.
*)

Ltac apply_find_core X :=
 match X with
 | ?U -> ?V => match type of U with Prop => apply_find_core V end
 | @derives mpred _ _ _ => constr:(X)
 | @eq mpred ?A ?B => constr:(@derives mpred A B)
 end.Ltac adjust2_sep_apply H :=
 let x := adjust_sep_apply H in
 match type of x with
 | @eq mpred _ _ => constr:(derives_refl' _ _ x)
 | _ => x
 end.Ltac cancel_for_sep_apply := ecancel.Ltac head_of_type_of H :=
 match type of H with ?A => apply_find_core A end.Ltac my_unshelve_evar name T cb evar_tac :=
  let x := fresh name
  in
  unshelve evar (x:T); revgoals;
  [
    let x' := eval unfold x in x
    in
    clear x; cb x'
  |
    evar_tac x
  ].Ltac norm_rewrite := autorewrite with norm.

(* Specifications: *)
Lemma TEST_L : forall n:nat, n=n -> (n + 1 = S n)%nat.