(* Require Import VST.msl.alg_seplog. *)
Local Open Scope logic.
Hint Extern 0 (_ |-- _) => match goal with |- ?A |-- ?B => constr_eq A B; simple apply derives_refl end : core.
(* Hint Resolve @derives_refl.    too expensive sometimes when it fails . . . *)
Ltac solve_andp' :=
first [ apply derives_refl
| apply andp_left1; solve_andp'
| apply andp_left2; solve_andp'].
Ltac solve_andp := repeat apply andp_right; solve_andp'.
Hint Resolve @TT_right: norm.
Hint Resolve @FF_left : norm.
Ltac norm := auto with norm.
Proof with norm.
intros.
apply pred_ext.
apply andp_right. apply andp_left2... apply andp_left1...
apply andp_right. apply andp_left2... apply andp_left1...
Qed.
Class CCCviaNatDed (A: Type) (prod expo: A -> A -> A) {ND: NatDed A}: Prop :=
isCCC: CartesianClosedCat.CCC A derives eq prod expo.
Instance andp_imp_CCC: forall A {ND : NatDed A}, CCCviaNatDed A andp imp.
Instance sepcon_wand_CCC: forall A {ND : NatDed A} {SL: SepLog A}, CCCviaNatDed A sepcon wand.
Hint Rewrite @FF_sepcon @sepcon_FF : norm.
Hint Rewrite @FF_andp @andp_FF : norm.
Proof with norm.
intros.
apply pred_ext.
apply andp_left1...
apply andp_right...
Qed.
Proof with norm.
intros.
rewrite sepcon_comm. rewrite sepcon_andp_prop.
rewrite sepcon_comm; auto.
Qed.
Proof with norm.
intros; rewrite sepcon_comm. apply sepcon_emp.
Qed.
Proof with norm.
intros. apply pred_ext. apply andp_left2... apply andp_right...
Qed.
Proof with norm.
intros.
apply pred_ext. apply andp_left2...
apply andp_right... apply prop_right...
Qed.
Ltac immediate := (assumption || reflexivity).
Hint Rewrite @prop_true_andp using (solve [immediate]) : norm.
Proof with norm.
intros. apply pred_ext...
apply prop_right...
Qed.
Hint Rewrite @true_eq using (solve [immediate]) : norm.
Hint Rewrite @andp_dup : norm.
Proof with norm.
intros.
apply @derives_trans with (P * emp).
rewrite sepcon_emp...
apply sepcon_derives...
Qed.
Hint Resolve @sepcon_TT : core.
Hint Rewrite @sepcon_emp @emp_sepcon @TT_andp @andp_TT
@exp_sepcon1 @exp_sepcon2
@exp_andp1 @exp_andp2
@sepcon_andp_prop @sepcon_andp_prop'
using (solve [auto with typeclass_instances])
: norm.
Ltac pull_left A := repeat (rewrite <- (pull_right A) || rewrite <- (pull_right0 A)).
Ltac pull_right A := repeat (rewrite (pull_right A) || rewrite (pull_right0 A)).
Hint Resolve @corable_andp @corable_orp @corable_allp @corable_exp
@corable_imp @corable_prop @corable_sepcon @corable_wand @corable_later : core.
Hint Resolve @corable_prop : norm.
(* The followings are not in auto-rewrite lib. *)
Ltac normalize1 :=
match goal with
| |- _ => contradiction
| |- 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)
(* 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 => _)) _] =>
autorewrite with norm; apply imp_extract_exp_left; intro y
| |- context [andp _ (exp (fun y => _))] =>
autorewrite with norm; apply imp_extract_exp_left; intro y
| |- context [sepcon (exp (fun y => _)) _] =>
autorewrite with norm; apply imp_extract_exp_left; intro y
| |- context [sepcon _ (exp (fun y => _))] =>
autorewrite with norm; apply imp_extract_exp_left; intro y
| |-  derives ?A   _ => match A with
| 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
end
| |- _ => progress  (autorewrite with norm); auto with typeclass_instances
| |- _ = ?x -> _ => intro; subst x
| |- ?x = _ -> _ => intro; subst x
|  |- ?ZZ -> _ => match type of ZZ with
| Prop =>
let H := fresh in
((assert (H:ZZ) by auto; clear H; intros _) || intro H)
| _ => intros _
end
| |- forall _, _ => let x := fresh "x" in (intro x; normalize1; try generalize dependent x)
| |- exp _ |-- _ => apply imp_extract_exp_left
| |- !! _ |-- _ => apply derives_extract_prop0
| |- !! _ && _ |-- _ => apply derives_extract_prop
| |- _ && !! _ |-- _ => apply derives_extract_prop'
| |- _ |-- !! (?x = ?y) && _ =>
(rewrite prop_true_andp with (P:= (x=y))
by (unfold y; reflexivity); unfold y in *; clear y) ||
(rewrite prop_true_andp with (P:=(x=y))
by (unfold x; reflexivity); unfold x in *; clear x)
| |- TT |-- !! _ => apply TT_prop_right
| |- _ => solve [auto with typeclass_instances]
end.
Ltac normalize1_in Hx :=
match type of Hx 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 ] =>
rewrite (true_eq P) in Hx by auto with typeclass_instances
| context [ !! ?P && ?Q ] =>
rewrite (prop_true_andp P Q) in Hx by auto with typeclass_instances
| context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) in Hx by (auto with norm)
| context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) in Hx by (auto with norm)
| context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) in Hx by (auto with norm)
| context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) in Hx by (auto with norm)
| _ => progress  (autorewrite with norm in Hx); auto with typeclass_instances
end.
Ltac normalize := repeat (auto with norm; normalize1).
Tactic Notation "normalize" "in" hyp(H) := repeat (normalize1_in H).
Definition mark {A: Type} (i: nat) (j: A) := j.
Ltac select_left n :=
repeat match goal with
| |- context [(_ * mark ?i _ * mark n _)] =>
rewrite (swap_mark1 i n); [ | solve [simpl; auto]]
| |- context [(mark ?i _ * mark n _)] =>
rewrite (swap_mark0 i n); [ | solve [simpl; auto]]
end.
Ltac select_all n := match n with
| O => idtac
| S ?n' => select_left n; select_all n'
end.
Ltac markem n P :=
match P with
| (?Y * ?Z) =>
(match goal with H: mark _ Z = Z |- _ => idtac end
|| assert (mark n Z = Z) by auto); markem (S n) Y
| ?Z =>  match goal with H: mark _ Z = Z |- _ => idtac end
|| assert (mark n Z = Z) by auto
end.
Ltac prove_assoc_commut :=
clear;
try (match goal with |- ?F _ -> ?G _ => replace G with F; auto end);
(repeat rewrite <- sepcon_assoc;
match goal with |- ?P = _ => markem O P end;
let LEFT := fresh "LEFT" in match goal with |- ?P = _ => set (LEFT := P) end;
match goal with H: mark ?n _ = _ |- _ =>
repeat  match goal with H: mark ?n _ = ?P |- _ => rewrite <- H; clear H end;
select_all n;
reflexivity
end).
(***** subtyping and contractiveness -- should split this into a separate file ******)
Ltac sub_unfold :=
match goal with
| |- _ |-- ?A _ >=> ?A _ => unfold A
| |- _ |-- ?A _ _ >=> ?A _ _ => unfold A
| |- _ |-- ?A _ _ _ >=> ?A _ _ _ => unfold A
| |- _ |-- ?A _ _ _ _ >=> ?A _ _ _ _ => unfold A
| |- _ |-- ?A _ _ _ _ _ >=> ?A _ _ _ _ _ => unfold A
| v: _ |- _ => destruct v
end.
Hint Extern 2 (_ |-- _ >=> _) => sub_unfold : contractive.
Hint Resolve @prove_HOcontractive
@subp_allp @subp_imp @subp_refl @subp_exp @subp_andp @subp_orp @subp_subp
@subp_sepcon (* NOTE: This hint fails to work unless fully instantiated, for some reason;
so the client must re-do the subp_sepcon hint *)
@allp_imp2_later_e1 @allp_imp2_later_e2 : contractive.
(*Lemma Rec_sub {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall G (F   : A -> A -> A) (HF1 : forall X, contractive (F X)) (HF2 : forall R P Q, P >=> Q |-- F P R >=> F Q R) (HF3 : forall P Q X, |>(P >=> Q) |-- F X P >=> F X Q), forall P Q, G |-- P >=> Q -> G |-- Rec (F P) >=> Rec (F Q). *)

Lemma HORec_sub {A}  {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall G B
(F : A -> (B -> A) -> B -> A)
(HF1 : forall X, HOcontractive (F X))
(HF2 : forall R a (P Q: A), P >=> Q |-- F P R a >=> F Q R a)
(HF3 : forall (P Q: B -> A) X, ALL b:B, |>(P b >=> Q b) |-- ALL b:B, F X P b >=> F X Q b),
forall P Q : A,
G |-- P >=> Q ->
G |-- ALL b:B, HORec (F P) b >=> HORec (F Q) b.