Commit 7dd4f12f authored by Nikita Zyuzin's avatar Nikita Zyuzin

Merge branch 'certificates' of https://gitlab.mpi-sws.org/AVA/daisy into fma_proofs_merge

Conflicts:
	coq/ErrorValidation.v
	coq/Expressions.v
	coq/FPRangeValidator.v
	coq/IEEE_connection.v
	coq/Infra/Ltacs.v
	coq/IntervalValidation.v
	coq/Typing.v
parents 5bbb6b4a 13ae6d87
......@@ -112,7 +112,7 @@ $ git submodule init
Then, initialize the CakeML submodule and start compilation:
```bash
$ git submodule update --recursive --remote
$ git submodule update --recursive
$ cd hol4/
$ Holmake
```
......
......@@ -13,9 +13,11 @@ Require Export Daisy.Infra.ExpressionAbbrevs Daisy.Commands.
(** Certificate checking function **)
Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (defVars:nat -> option mType) :=
if (typeCheck e defVars (typeMap defVars e)) then
if (validIntervalbounds e absenv P NatSet.empty) && FPRangeValidator e absenv (typeMap defVars e) NatSet.empty
then (validErrorbound e (typeMap defVars e) absenv NatSet.empty)
let tMap := (typeMap defVars e (DaisyMap.empty mType)) in
if (typeCheck e defVars tMap)
then
if (validIntervalbounds e absenv P NatSet.empty) && FPRangeValidator e absenv tMap NatSet.empty
then (validErrorbound e tMap absenv NatSet.empty)
else false
else false.
......@@ -27,19 +29,20 @@ Definition CertificateChecker (e:exp Q) (absenv:analysisResult) (P:precond) (def
Theorem Certificate_checking_is_sound (e:exp Q) (absenv:analysisResult) P defVars:
forall (E1 E2:env),
approxEnv E1 defVars absenv (usedVars e) NatSet.empty E2 ->
(forall v, NatSet.mem v (Expressions.usedVars e) = true ->
(forall v, NatSet.In v (Expressions.usedVars e) ->
exists vR, E1 v = Some vR /\
(Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
(forall v, (v) mem (usedVars e) = true ->
(forall v, NatSet.In v (usedVars e) ->
exists m : mType,
defVars v = Some m) ->
CertificateChecker e absenv P defVars = true ->
exists vR vF m,
eval_exp E1 (toRMap defVars) (toREval (toRExp e)) vR M0 /\
eval_exp E2 defVars (toRExp e) vF m /\
(forall vF m,
eval_exp E2 defVars (toRExp e) vF m ->
(Rabs (vR - vF) <= Q2R (snd (absenv e))))%R.
exists iv err vR vF m,
DaisyMap.find e absenv = Some (iv, err) /\
eval_exp E1 (toRMap defVars) (toREval (toRExp e)) vR M0 /\
eval_exp E2 defVars (toRExp e) vF m /\
(forall vF m,
eval_exp E2 defVars (toRExp e) vF m ->
(Rabs (vR - vF) <= Q2R err))%R.
(**
The proofs is a simple composition of the soundness proofs for the range
validator and the error bound validator.
......@@ -49,55 +52,52 @@ Proof.
unfold CertificateChecker in certificate_valid.
rewrite <- andb_lazy_alt in certificate_valid.
andb_to_prop certificate_valid.
env_assert absenv e env_e.
destruct env_e as [iv [err absenv_eq]].
destruct iv as [ivlo ivhi].
rewrite absenv_eq; simpl.
pose proof (NatSetProps.empty_union_2 (Expressions.usedVars e) NatSet.empty_spec) as union_empty.
hnf in union_empty.
assert (forall v1, (v1) mem (Expressions.usedVars e NatSet.empty) = true ->
exists m0 : mType, defVars v1 = Some m0).
{ intros; eapply types_defined.
rewrite NatSet.mem_spec in *.
rewrite <- union_empty; eauto. }
assert (dVars_range_valid NatSet.empty E1 absenv).
{ unfold dVars_range_valid.
intros; set_tac. }
assert (NatSet.Subset (usedVars e -- NatSet.empty) (Expressions.usedVars e)).
{ hnf; intros a in_empty.
set_tac. }
assert (vars_typed (usedVars e NatSet.empty) defVars).
{ unfold vars_typed. intros; apply types_defined. set_tac. destruct H1; set_tac.
split; try auto. hnf; intros; set_tac. }
rename R into validFPRanges.
assert (forall v, (v) mem (NatSet.empty) = true -> exists vR :R, E1 v = Some vR /\ (Q2R (fst (fst (absenv (Var Q v)))) <= vR <= Q2R (snd (fst (absenv (Var Q v)))))%R).
{ intros v v_in_empty.
rewrite NatSet.mem_spec in v_in_empty.
inversion v_in_empty. }
edestruct validIntervalbounds_sound as [vR [eval_real real_bounds_e]]; eauto.
destruct (validErrorbound_sound e P (typeMap defVars e) L approxE1E2 H0 eval_real R0 L1 H1 P_valid H absenv_eq) as [[vF [mF eval_float]] err_bounded]; auto.
exists vR; exists vF; exists mF; split; auto.
edestruct (validIntervalbounds_sound e (A:=absenv) (P:=P) (fVars:=usedVars e) (dVars:=NatSet.empty) (Gamma:=defVars) (E:=E1))
as [iv_e [ err_e [vR [ map_e [eval_real real_bounds_e]]]]]; eauto.
destruct iv_e as [elo ehi].
edestruct (validErrorbound_sound e (typeMap defVars e (DaisyMap.empty mType)) L approxE1E2 H0 eval_real R0 L1 H P_valid H1 map_e) as [[vF [mF eval_float]] err_bounded]; auto.
exists (elo, ehi), err_e, vR, vF, mF; split; auto.
Qed.
Definition CertificateCheckerCmd (f:cmd Q) (absenv:analysisResult) (P:precond) defVars:=
if (typeCheckCmd f defVars (typeMapCmd defVars f) && validSSA f (freeVars f))
let tMap := typeMapCmd defVars f (DaisyMap.empty mType) in
if (typeCheckCmd f defVars tMap && validSSA f (freeVars f))
then
if (validIntervalboundsCmd f absenv P NatSet.empty) &&
FPRangeValidatorCmd f absenv (typeMapCmd defVars f) NatSet.empty
then (validErrorboundCmd f (typeMapCmd defVars f) absenv NatSet.empty)
FPRangeValidatorCmd f absenv tMap NatSet.empty
then (validErrorboundCmd f tMap absenv NatSet.empty)
else false
else false.
Theorem Certificate_checking_cmds_is_sound (f:cmd Q) (absenv:analysisResult) P defVars:
forall (E1 E2:env),
approxEnv E1 defVars absenv (freeVars f) NatSet.empty E2 ->
(forall v, NatSet.mem v (freeVars f)= true ->
(forall v, NatSet.In v (freeVars f) ->
exists vR, E1 v = Some vR /\
(Q2R (fst (P v)) <= vR <= Q2R (snd (P v)))%R) ->
(forall v, (v) mem (freeVars f) = true ->
(forall v, NatSet.In v (freeVars f) ->
exists m : mType,
defVars v = Some m) ->
CertificateCheckerCmd f absenv P defVars = true ->
exists vR vF m,
exists iv err vR vF m,
DaisyMap.find (getRetExp f) absenv = Some (iv,err) /\
bstep (toREvalCmd (toRCmd f)) E1 (toRMap defVars) vR M0 /\
bstep (toRCmd f) E2 defVars vF m /\
(forall vF m,
bstep (toRCmd f) E2 defVars vF m ->
(Rabs (vR - vF) <= Q2R (snd (absenv (getRetExp f))))%R).
(Rabs (vR - vF) <= Q2R (err))%R).
(**
The proofs is a simple composition of the soundness proofs for the range
validator and the error bound validator.
......@@ -109,32 +109,25 @@ Proof.
andb_to_prop certificate_valid.
apply validSSA_sound in R0.
destruct R0 as [outVars ssa_f].
env_assert absenv (getRetExp f) env_f.
destruct env_f as [iv [err absenv_eq]].
destruct iv as [ivlo ivhi].
assert (ssa f (freeVars f NatSet.empty) outVars) as ssa_valid.
{ eapply ssa_equal_set; try eauto.
apply NatSetProps.empty_union_2.
apply NatSet.empty_spec. }
rename R into validFPRanges.
assert (forall v, (v) mem (NatSet.empty) = true ->
exists vR : R,
E1 v = Some vR /\ (Q2R (fst (fst (absenv (Var Q v)))) <= vR <= Q2R (snd (fst (absenv (Var Q v)))))%R) as no_dVars_valid.
{ intros v v_in_empty.
set_tac. inversion v_in_empty. }
assert (forall v, (v) mem (freeVars f NatSet.empty) = true ->
exists m : mType, defVars v = Some m) as types_valid.
{ intros v v_mem; apply types_defined.
set_tac. rewrite NatSet.union_spec in v_mem.
destruct v_mem; try auto.
inversion H. }
assert (dVars_range_valid NatSet.empty E1 absenv).
{ unfold dVars_range_valid.
intros; set_tac. }
assert (vars_typed (freeVars f NatSet.empty) defVars).
{ unfold vars_typed. intros; apply types_defined. set_tac.
destruct H0; set_tac. }
assert (NatSet.Subset (freeVars f -- NatSet.empty) (freeVars f))
as freeVars_contained by set_tac.
edestruct (validIntervalboundsCmd_sound) as [vR [eval_real bounded_real_f]] ; eauto.
rewrite absenv_eq; simpl.
edestruct (validIntervalboundsCmd_sound)
as [iv [ err [vR [map_f [eval_real bounded_real_f]]]]]; eauto.
destruct iv as [f_lo f_hi].
edestruct validErrorboundCmd_gives_eval as [vF [mF eval_float]]; eauto.
exists vR; exists vF; exists mF; split; try auto.
split; try auto.
exists (f_lo, f_hi), err, vR, vF, mF; split; try auto.
split; try auto; split; try auto.
intros.
eapply validErrorboundCmd_sound; eauto.
Qed.
\ No newline at end of file
......@@ -20,124 +20,113 @@ Inductive approxEnv : env -> (nat -> option mType) -> analysisResult -> NatSet.t
(Rabs (v1 - v2) <= (Rabs v1) * Q2R (mTypeToQ m))%R ->
NatSet.mem x (NatSet.union fVars dVars) = false ->
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A (NatSet.add x fVars) dVars (updEnv x v2 E2)
|approxUpdBound E1 E2 defVars A v1 v2 x fVars dVars m:
|approxUpdBound E1 E2 defVars A v1 v2 x fVars dVars m iv err:
approxEnv E1 defVars A fVars dVars E2 ->
(Rabs (v1 - v2) <= Q2R (snd (A (Var Q x))))%R ->
DaisyMap.find (Var Q x) A = Some (iv, err) ->
(Rabs (v1 - v2) <= Q2R err)%R ->
NatSet.mem x (NatSet.union fVars dVars) = false ->
approxEnv (updEnv x v1 E1) (updDefVars x m defVars) A fVars (NatSet.add x dVars) (updEnv x v2 E2).
(* Inductive approxParams :env -> env -> Prop := *)
(* |approxParamRefl: *)
(* approxParams emptyEnv emptyEnv *)
(* |approxParamUpd E1 E2 m x v1 v2 : *)
(* approxParams E1 E2 -> *)
(* (Rabs (v1 - v2) <= Q2R (meps m))%R -> *)
(* approxParams (updEnv x M0 v1 E1) (updEnv x m v2 E2). *)
Section RelationProperties.
Variable (x:nat) (v:R) (E1 E2:env) (Gamma:nat -> option mType) (A:analysisResult) (fVars dVars: NatSet.t).
Variable (x:nat) (v:R) (E1 E2:env) (Gamma:nat -> option mType)
(A:analysisResult) (fVars dVars: NatSet.t).
Hypothesis approxEnvs: approxEnv E1 Gamma A fVars dVars E2.
Lemma approxEnv_gives_value:
E1 x = Some v ->
NatSet.In x (NatSet.union fVars dVars) ->
exists v',
E2 x = Some v'.
Proof.
induction approxEnvs;
intros E1_def x_valid.
- unfold emptyEnv in E1_def; simpl in E1_def. congruence.
- unfold updEnv in *.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
+ eexists; eauto.
+ eapply IHa; auto.
set_tac.
rewrite NatSet.union_spec in x_valid.
destruct x_valid; set_tac.
rewrite NatSet.add_spec in H1.
destruct H1; subst; try auto.
rewrite Nat.eqb_refl in eq_case; congruence.
- unfold updEnv in *.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
+ eexists; eauto.
+ eapply IHa; auto.
set_tac.
rewrite NatSet.union_spec in x_valid.
destruct x_valid; set_tac.
rewrite NatSet.add_spec in H1.
destruct H1; subst; try auto.
rewrite Nat.eqb_refl in eq_case; congruence.
Qed.
Lemma approxEnv_gives_value:
E1 x = Some v ->
NatSet.In x (NatSet.union fVars dVars) ->
exists v',
E2 x = Some v'.
Proof.
induction approxEnvs;
intros E1_def x_valid.
- unfold emptyEnv in E1_def; simpl in E1_def. congruence.
- unfold updEnv in *.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
+ eexists; eauto.
+ eapply IHa; eauto.
set_tac.
destruct x_valid; set_tac.
destruct H1 as [? | [? ?]]; subst; try auto.
rewrite Nat.eqb_refl in eq_case; congruence.
- unfold updEnv in *.
case_eq (x =? x0); intros eq_case; rewrite eq_case in *.
+ eexists; eauto.
+ eapply IHa; auto.
set_tac.
destruct x_valid; set_tac.
destruct H2 as [? | [ ? ?]]; subst; try auto.
rewrite Nat.eqb_refl in eq_case; congruence.
Qed.
Arguments mTypeToQ _ : simpl nomatch.
Arguments mTypeToQ _ : simpl nomatch.
Lemma approxEnv_fVar_bounded v2 m:
E1 x = Some v ->
E2 x = Some v2 ->
NatSet.In x fVars ->
Gamma x = Some m ->
(Rabs (v - v2) <= (Rabs v) * Q2R (mTypeToQ m))%R.
Proof.
induction approxEnvs;
intros E1_def E2_def x_free x_typed.
- unfold emptyEnv in *; simpl in *; congruence.
- set_tac.
rewrite add_spec_strong in x_free.
destruct x_free as [x_x0 | [x_neq x_free]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
unfold updDefVars in x_typed.
rewrite Nat.eqb_refl in x_typed.
inversion x_typed; subst.
inversion E1_def; inversion E2_def; subst; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
Lemma approxEnv_fVar_bounded v2 m:
E1 x = Some v ->
E2 x = Some v2 ->
NatSet.In x fVars ->
Gamma x = Some m ->
(Rabs (v - v2) <= (Rabs v) * Q2R (mTypeToQ m))%R.
Proof.
induction approxEnvs;
intros E1_def E2_def x_free x_typed.
- unfold emptyEnv in *; simpl in *; congruence.
- set_tac.
destruct x_free as [x_x0 | [x_neq x_free]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
unfold updDefVars in x_typed.
rewrite Nat.eqb_refl in x_typed.
inversion x_typed; subst.
inversion E1_def; inversion E2_def; subst; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
apply IHa; auto.
- assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac.
apply H1.
set_tac. }
unfold updEnv in *; rewrite x_x0_neq in *.
apply IHa; auto.
- assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac.
apply H0.
set_tac. }
unfold updEnv in *; rewrite x_x0_neq in *.
apply IHa; auto.
unfold updDefVars in x_typed;
rewrite x_x0_neq in x_typed; auto.
Qed.
unfold updDefVars in x_typed;
rewrite x_x0_neq in x_typed; auto.
Qed.
Lemma approxEnv_dVar_bounded v2 m e:
E1 x = Some v ->
E2 x = Some v2 ->
NatSet.In x dVars ->
Gamma x = Some m ->
snd (A (Var Q x)) = e ->
(Rabs (v - v2) <= Q2R e)%R.
Proof.
induction approxEnvs;
intros E1_def E2_def x_def x_typed A_e; subst.
- unfold emptyEnv in *; simpl in *; congruence.
- assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac.
apply H0; set_tac.
}
unfold updEnv in *; rewrite x_x0_neq in *.
unfold updDefVars in x_typed; rewrite x_x0_neq in x_typed.
apply IHa; auto.
- set_tac.
rewrite add_spec_strong in x_def.
destruct x_def as [x_x0 | [x_neq x_def]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
inversion E1_def; inversion E2_def; subst; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
Lemma approxEnv_dVar_bounded v2 m iv e:
E1 x = Some v ->
E2 x = Some v2 ->
NatSet.In x dVars ->
Gamma x = Some m ->
DaisyMap.find (Var Q x) A = Some (iv, e) ->
(Rabs (v - v2) <= Q2R e)%R.
Proof.
induction approxEnvs;
intros E1_def E2_def x_def x_typed A_e; subst.
- unfold emptyEnv in *; simpl in *; congruence.
- assert (x =? x0 = false) as x_x0_neq.
{ rewrite Nat.eqb_neq; hnf; intros; subst.
set_tac.
apply H0; set_tac.
}
unfold updEnv in *; rewrite x_x0_neq in *.
unfold updDefVars in x_typed; rewrite x_x0_neq in x_typed.
apply IHa; auto.
Qed.
- set_tac.
destruct x_def as [x_x0 | [x_neq x_def]]; subst.
+ unfold updEnv in *;
rewrite Nat.eqb_refl in *; simpl in *.
inversion E1_def; inversion E2_def; subst.
rewrite A_e in *; inversion H; auto.
+ unfold updEnv in *; simpl in *.
rewrite <- Nat.eqb_neq in x_neq.
rewrite x_neq in *; simpl in *.
unfold updDefVars in x_typed; rewrite x_neq in x_typed.
apply IHa; auto.
Qed.
End RelationProperties.
\ No newline at end of file
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -62,3 +62,15 @@ Definition updEnv (x:nat) (v: R) (E:env) (y:nat) :=
Definition updDefVars (x:nat) (m:mType) (defVars:nat -> option mType) (y:nat) :=
if (y =? x) then Some m else defVars y.
Definition optionLift (V T:Type) (v:option V) default (f: V -> T) :=
match v with
| None => default
| Some val => f val
end.
Ltac optionD :=
match goal with
|H: context[optionLift ?v ?default ?f] |- _ =>
destruct ?v eqn:?
end.
\ No newline at end of file
......@@ -2,11 +2,20 @@
Some abbreviations that require having defined expressions beforehand
If we would put them in the Abbrevs file, this would create a circular dependency which Coq cannot resolve.
**)
Require Import Coq.QArith.QArith Coq.Reals.Reals Coq.QArith.Qreals.
Require Import Coq.QArith.QArith Coq.Reals.Reals Coq.QArith.Qreals Coq.QArith.QOrderedType Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Export Daisy.Infra.Abbrevs Daisy.Expressions.
Module Q_orderedExps := ExpOrderedType (Q_as_OT).
Module legacy_OrderedQExps := Structures.OrdersAlt.Backport_OT (Q_orderedExps).
Module DaisyMap := FMapAVL.Make(legacy_OrderedQExps).
Module DaisyMapFacts := OrdProperties (DaisyMap).
Definition analysisResult :Type := DaisyMap.t (intv * error).
(**
We treat a function mapping an expression arguing on fractions as value type
to pairs of intervals on rationals and rational errors as the analysis result
**)
Definition analysisResult :Type := exp Q -> intv * error.
\ No newline at end of file
(* Definition analysisResult :Type := exp Q -> intv * error. *)
\ No newline at end of file
......@@ -21,11 +21,13 @@ Ltac canonize_Q_prop :=
match goal with
| [ H: Qle_bool ?a ?b = true |- _] => rewrite Qle_bool_iff in H
| [ H: Qleb ?a ?b = true |- _ ] => rewrite Qle_bool_iff in H
| [ H: Qeq_bool ?a ?b = true |- _] => rewrite Qeq_bool_iff in H
end.
Ltac canonize_Q_to_R :=
match goal with
| [ H: (?a <= ?b)%Q |- _ ] => apply Qle_Rle in H
| [ H: (?a == ?b)%Q |- _ ] => apply Qeq_eqR in H
| [ H: context [Q2R 0] |- _ ] => rewrite Q2R0_is_0 in H
| [ |- context [Q2R 0] ] => rewrite Q2R0_is_0
end.
......@@ -44,96 +46,116 @@ Ltac Q2R_to_head_step :=
Ltac Q2R_to_head := repeat Q2R_to_head_step.
Ltac NatSet_simp hyp :=
try rewrite NatSet.mem_spec in hyp;
try rewrite NatSet.equal_spec in hyp;
try rewrite NatSet.subset_spec in hyp;
try rewrite NatSet.empty_spec in hyp;
try rewrite NatSet.is_empty_spec in hyp;
try rewrite NatSet.add_spec in hyp;
try rewrite NatSet.remove_spec in hyp;
try rewrite NatSet.singleton_spec in hyp;
try rewrite NatSet.union_spec in hyp;
try rewrite NatSet.inter_spec in hyp;
try rewrite NatSet.diff_spec in hyp.
Ltac NatSet_prop :=
match goal with
| [ H : true = true |- _ ] => clear H; NatSet_prop
| [ H: ?T = true |- _ ] => NatSet_simp H;
(apply Is_true_eq_left in H; NatSet_prop; apply Is_true_eq_true in H) || NatSet_prop
| _ => try auto
end.
Ltac destruct_if :=
match goal with
| [H: (if ?c then ?a else ?b) = _ |- _ ] =>
case_eq ?c;
let name := fresh "cond" in
intros name;
rewrite name in *;
try congruence
end.
Definition optionLift (X Y:Type) (v:option X) (f:X -> Y) (e:Y) :=
match v with
|Some val => f val
| None => e
end.
match v with
|Some val => f val
| None => e
end.
Lemma optionLift_eq (X Y:Type) v (f:X -> Y) (e:Y):
match v with |Some val => f val | None => e end = optionLift X Y v f e.
match v with |Some val => f val | None => e end = optionLift X Y v f e.
Proof.
cbv; auto.
reflexivity.
Qed.
Lemma optionLift_cond X (a:bool) (b c :X):
(if a then b else c) = match a with |true => b |false => c end.
(if a then b else c) = match a with |true => b |false => c end.
Proof.
cbv; auto.
reflexivity.
Qed.
Ltac remove_matches := rewrite optionLift_eq in *.
Ltac remove_conds := rewrite <- andb_lazy_alt, optionLift_cond in *.
Ltac match_factorize_asm :=
match goal with
| [ H: ?t = ?u |- context [optionLift _ _ ?t _ _]]
=> rewrite H; cbn
| [ H1: ?t = ?u, H2: context [optionLift _ _ ?t _ _] |- _ ]
=> rewrite H1 in H2; cbn in H2
| [ H: context [optionLift _ _ ?t _ _] |- _ ]
=> destruct t eqn:?; cbn in H; try congruence
end.
Ltac match_factorize :=
match goal with
| [ H: ?t = ?u |- context [optionLift _ _ ?t _ _]]
=> rewrite H; cbn
| [ H1: ?t = ?u, H2: context [optionLift _ _ ?t _ _] |- _ ]
=> rewrite H1 in H2; cbn in H2
| [ H: context [optionLift _ _ ?t _ _] |- _ ]
=> destruct t eqn:?; cbn in H; try congruence
| [ |- context [optionLift _ _ ?t _ _] ]
=> destruct t eqn:?; cbn; try congruence
end.
match_factorize_asm ||
match goal with
| [ |- context [optionLift _ _ ?t _ _] ]
=> destruct t eqn:?; cbn; try congruence
end.
Ltac pair_factorize :=
match goal with
| [H: context[let (_, _) := ?p in _] |- _] => destruct p; cbn in H
end.
match goal with
| [H: context[let (_, _) := ?p in _] |- _] => destruct p; cbn in H
end.
Ltac destr_factorize :=
match goal with
| [H1: _ ?v = Some ?a, H2: _ ?v = Some ?b |- _]
=> rewrite H1 in H2; inversion H2; subst; clear H2
| [H1: _ ?k ?M = Some ?a, H2: _ ?k ?M = Some ?b |- _]
=> rewrite H1 in H2; inversion H2; subst; clear H2
end.
Ltac match_simpl :=
try remove_conds;
try remove_matches;
repeat match_factorize;
try pair_factorize.
try remove_conds;
try remove_matches;
repeat match_factorize;
try pair_factorize.
Ltac bool_factorize :=
match goal with
| [H: _ = true |- _] => andb_to_prop H
end.
match goal with
| [H: _ = true |- _] => andb_to_prop H
end.
Ltac Daisy_compute :=
repeat
(match_simpl || bool_factorize).
Ltac Daisy_compute_asm :=
repeat (
(try remove_conds;
try remove_matches;
repeat match_factorize_asm;
try pair_factorize) ||
bool_factorize).
(* HOL4 Style patter matching tactics *)
Tactic Notation "lift " tactic(t) :=
fun H => t H.
Ltac Daisy_compute :=
repeat (
(try remove_conds;
try remove_matches;
repeat match_factorize;
try pair_factorize) ||
bool_factorize).
(* Ltac destruct_if := *)
(* match goal with *)
(* | [H: if ?c then ?a else ?b = _ |- _ ] => *)
(* case_eq ?c; *)