frap/Frap.v

240 lines
6.9 KiB
Coq
Raw Normal View History

Require Import Eqdep String Arith Omega Program Sets Relations Map Var Invariant Bool ModelCheck.
2016-02-21 17:16:31 +00:00
Export String Arith Sets Relations Map Var Invariant Bool ModelCheck.
2015-12-31 20:44:34 +00:00
Require Import List.
2016-02-02 17:38:00 +00:00
Export List ListNotations.
2015-12-31 20:44:34 +00:00
Open Scope string_scope.
2016-02-06 23:24:06 +00:00
Open Scope list_scope.
2015-12-31 20:44:34 +00:00
Ltac inductN n :=
match goal with
| [ |- forall x : ?E, _ ] =>
match type of E with
| Prop =>
let H := fresh in intro H;
match n with
| 1 => dependent induction H
| S ?n' => inductN n'
end
| _ => intro; inductN n
end
end.
Ltac induct e := inductN e || dependent induction e.
Ltac invert' H := inversion H; clear H; subst.
Ltac invertN n :=
match goal with
| [ |- forall x : ?E, _ ] =>
match type of E with
| Prop =>
let H := fresh in intro H;
match n with
| 1 => invert' H
| S ?n' => invertN n'
end
| _ => intro; invertN n
end
end.
Ltac invert e := invertN e || invert' e.
Ltac invert0 e := invert e; fail.
Ltac invert1 e := invert0 e || (invert e; []).
Ltac invert2 e := invert1 e || (invert e; [|]).
2016-02-23 23:59:50 +00:00
Ltac maps_neq :=
match goal with
| [ H : ?m1 = ?m2 |- _ ] =>
let rec recur E :=
match E with
| ?E' $+ (?k, _) =>
(apply (f_equal (fun m => m $? k)) in H; simpl in *; autorewrite with core in *; simpl in *; congruence)
|| recur E'
end in
recur m1 || recur m2
end.
Ltac fancy_neq :=
repeat match goal with
| _ => maps_neq
| [ H : @eq (nat -> _) _ _ |- _ ] => apply (f_equal (fun f => f 0)) in H
2016-02-23 23:59:50 +00:00
| [ H : _ = _ |- _ ] => invert H
end.
Ltac removeDups :=
match goal with
| [ |- context[constant ?ls] ] =>
someMatch ls;
erewrite (@removeDups_ok _ ls)
by repeat (apply RdNil
|| (apply RdNew; [ simpl; intuition (congruence || solve [ fancy_neq ]) | ])
|| (apply RdDup; [ simpl; intuition congruence | ]))
end.
Ltac simpl_maps :=
repeat match goal with
| [ |- context[add ?m ?k1 ?v $? ?k2] ] =>
(rewrite (@lookup_add_ne _ _ m k1 k2 v) by (congruence || omega))
|| (rewrite (@lookup_add_eq _ _ m k1 k2 v) by (congruence || omega))
end.
2016-02-18 22:51:58 +00:00
Ltac simplify := repeat (unifyTails; pose proof I);
repeat match goal with
| [ H : True |- _ ] => clear H
end;
repeat progress (simpl in *; intros; try autorewrite with core in *; simpl_maps);
2016-02-18 22:51:58 +00:00
repeat (removeDups || doSubtract).
2016-02-09 18:11:58 +00:00
Ltac propositional := intuition idtac.
2015-12-31 20:44:34 +00:00
2016-01-17 01:32:12 +00:00
Ltac linear_arithmetic := intros;
2015-12-31 20:44:34 +00:00
repeat match goal with
| [ |- context[max ?a ?b] ] =>
let Heq := fresh "Heq" in destruct (Max.max_spec a b) as [[? Heq] | [? Heq]];
rewrite Heq in *; clear Heq
| [ _ : context[max ?a ?b] |- _ ] =>
let Heq := fresh "Heq" in destruct (Max.max_spec a b) as [[? Heq] | [? Heq]];
rewrite Heq in *; clear Heq
| [ |- context[min ?a ?b] ] =>
let Heq := fresh "Heq" in destruct (Min.min_spec a b) as [[? Heq] | [? Heq]];
rewrite Heq in *; clear Heq
| [ _ : context[min ?a ?b] |- _ ] =>
let Heq := fresh "Heq" in destruct (Min.min_spec a b) as [[? Heq] | [? Heq]];
rewrite Heq in *; clear Heq
end; omega.
2016-02-09 21:28:48 +00:00
Ltac equality := intuition congruence.
2015-12-31 20:44:34 +00:00
Ltac cases E :=
2016-02-06 23:24:06 +00:00
((is_var E; destruct E)
|| match type of E with
| {_} + {_} => destruct E
| _ => let Heq := fresh "Heq" in destruct E eqn:Heq
end);
repeat match goal with
| [ H : _ = left _ |- _ ] => clear H
| [ H : _ = right _ |- _ ] => clear H
end.
2016-01-17 01:32:12 +00:00
Global Opaque max min.
2016-02-07 03:09:37 +00:00
Infix "==n" := eq_nat_dec (no associativity, at level 50).
2016-03-07 01:30:05 +00:00
Infix "<=?" := le_lt_dec.
2016-02-07 03:09:37 +00:00
Export Frap.Map.
Ltac maps_equal := Frap.Map.M.maps_equal; simplify.
2016-02-16 00:39:36 +00:00
Ltac first_order := firstorder idtac.
2016-02-21 17:16:31 +00:00
(** * Model checking *)
Ltac sets := Sets.sets ltac:(simpl in *; intuition (subst; auto)).
Ltac model_check_invert1 :=
match goal with
| [ H : ?P |- _ ] =>
match type of P with
| Prop => invert H;
repeat match goal with
| [ H : existT _ ?x _ = existT _ ?x _ |- _ ] =>
apply inj_pair2 in H; subst
end; simplify
end
end.
Ltac model_check_invert := simplify; subst; repeat model_check_invert1.
2016-02-21 17:16:31 +00:00
Lemma oneStepClosure_solve : forall A (sys : trsys A) I I',
oneStepClosure sys I I'
-> I = I'
-> oneStepClosure sys I I.
Proof.
equality.
Qed.
Ltac singletoner := try (exfalso; solve [ sets ]);
2016-02-21 17:16:31 +00:00
repeat match goal with
(* | _ => apply singleton_in *)
| [ |- _ ?S ] => idtac S; apply singleton_in
2016-02-21 17:16:31 +00:00
| [ |- (_ \cup _) _ ] => apply singleton_in_other
end.
Ltac closure :=
repeat (apply oneStepClosure_empty
|| (apply oneStepClosure_split; [ model_check_invert; try equality; solve [ singletoner ] | ])).
Ltac model_check_done :=
apply MscDone; eapply oneStepClosure_solve; [ closure | simplify; solve [ sets ] ].
2016-02-21 17:16:31 +00:00
Ltac model_check_step :=
eapply MscStep; [ closure | simplify ].
2016-02-21 17:16:31 +00:00
Ltac model_check_steps1 := model_check_done || model_check_step.
Ltac model_check_steps := repeat model_check_steps1.
Ltac model_check_finish := simplify; propositional; subst; simplify; try equality; try linear_arithmetic.
2016-02-21 17:16:31 +00:00
Ltac model_check_infer :=
apply multiStepClosure_ok; simplify; model_check_steps.
Ltac model_check_find_invariant :=
simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.
Ltac model_check := model_check_find_invariant; model_check_finish.
Inductive ordering (n m : nat) :=
| Lt (_ : n < m)
| Eq (_ : n = m)
| Gt (_ : n > m).
Local Hint Constructors ordering.
Local Hint Extern 1 (_ < _) => omega.
Local Hint Extern 1 (_ > _) => omega.
Theorem totally_ordered : forall n m, ordering n m.
Proof.
induction n; destruct m; simpl; eauto.
destruct (IHn m); eauto.
Qed.
Ltac total_ordering N M := destruct (totally_ordered N M).
Ltac inList x xs :=
match xs with
| (x, _) => constr:true
| (_, ?xs') => inList x xs'
| _ => constr:false
end.
Ltac maybe_simplify_map m found kont :=
match m with
| @empty ?A ?B => kont (@empty A B)
| ?m' $+ (?k, ?v) =>
let iL := inList k found in
match iL with
| true => maybe_simplify_map m' found kont
| false =>
maybe_simplify_map m' (k, found) ltac:(fun m' => kont (m' $+ (k, v)))
end
end.
Ltac simplify_map' m found kont :=
match m with
| ?m' $+ (?k, ?v) =>
let iL := inList k found in
match iL with
| true => maybe_simplify_map m' found kont
| false =>
simplify_map' m' (k, found) ltac:(fun m' => kont (m' $+ (k, v)))
end
end.
Ltac simplify_map :=
match goal with
| [ |- context[@add ?A ?B ?m ?k ?v] ] =>
simplify_map' (m $+ (k, v)) tt ltac:(fun m' =>
replace (@add A B m k v) with m' by maps_equal)
end.