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.
Hint Rewrite TEST_L using reflexivity : test888.
Goal forall n, S n = (n + 1)%nat.
intros.
rewrite_strat (topdown hints test888).
match goal with |- S n = S n => reflexivity end.
Qed.  (* Yes, this works in Coq 8.7.2 *)
Ltac normalize1 :=
match goal with
| |- context [@andp ?A (@LiftNatDed ?T ?B ?C) ?D ?E ?F] =>
change (@andp A (@LiftNatDed T B C) D E F) with (D F && E F)
| |- context [@later ?A  (@LiftNatDed ?T ?B ?C) (@LiftIndir ?X1 ?X2 ?X3 ?X4 ?X5) ?D ?F] =>
change (@later A  (@LiftNatDed T B C) (@LiftIndir X1 X2 X3 X4 X5) D F)
with (@later B C X5 (D F))
| |- context [@sepcon ?A (@LiftNatDed ?B ?C ?D)
(@LiftSepLog ?E ?F ?G ?H) ?J ?K ?L] =>
change (@sepcon A (@LiftNatDed B C D) (@LiftSepLog E F G H) J K L)
with (@sepcon C D H (J L) (K L))
| |- context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) by (auto with norm)
| |- context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) by (auto with norm)
| |- context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) by (auto with norm)
| |- context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) by (auto with norm)
| |-  derives ?A   ?B => match A with
| FF => apply FF_left
| !! _ => apply derives_extract_prop0
| exp (fun y => _) => apply imp_extract_exp_left; (intro y || intro)
| !! _ && _ => apply derives_extract_prop
| _ && !! _ => apply derives_extract_prop'
| context [ ((!! ?P) && ?Q) && ?R ] => rewrite (andp_assoc (!!P) Q R)
| context [ ?Q && (!! ?P && ?R)] =>
match Q with !! _ => fail 2 | _ => rewrite (andp_assoc' (!!P) Q R) end
(* In the next four rules, doing it this way (instead of leaving it to autorewrite) preserves the name of the "y" variable *)
| context [andp (exp (fun y => _)) _] =>
let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
apply imp_extract_exp_left; intro y
| context [andp _ (exp (fun y => _))] =>
let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
apply imp_extract_exp_left; intro y
| context [sepcon (exp (fun y => _)) _] =>
let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
apply imp_extract_exp_left; intro y
| context [sepcon _ (exp (fun y => _))] =>
let BB := fresh "BB" in set (BB:=B); norm_rewrite; unfold BB; clear BB;
apply imp_extract_exp_left; intro y
| _ => simple apply TT_prop_right
| _ => simple apply TT_right
| _ => constr_eq A B; apply derives_refl
end
| |- _ => solve [auto]
| |- _ |-- !! (?x = ?y) && _ =>
(rewrite (prop_true_andp' (x=y))
by (unfold y; reflexivity); unfold y in *; clear y) ||
(rewrite (prop_true_andp' (x=y))
by (unfold x; reflexivity); unfold x in *; clear x)
|  |- ?ZZ -> ?YY => match type of ZZ with
| Prop => fancy_intros true || fail 1
| _ => intros _
end
| |- ~ _ => fancy_intro true
| |- _ => progress (norm_rewrite) (*; auto with typeclass_instances *)
| |- forall _, _ => let x := fresh "x" in (intro x; repeat normalize1; try generalize dependent x)
end.
Ltac normalize :=
autorewrite with gather_prop;
repeat (((repeat simple apply go_lower_lem1'; simple apply go_lower_lem1)
|| simple apply derives_extract_prop
|| simple apply derives_extract_prop');
fancy_intros true);
repeat normalize1; try contradiction.

Lemma allp_instantiate:
forall {A : Type} {NA : NatDed A} {B : Type} (P : B -> A) (x : B),
ALL y : B, P y |-- P x.