coq tactic - Simplifying Subformulas in Coq -
i'm trying solve equation of form
a * b * c * d * e = f where * complicated left associative operation.
at moment, opaque (including * , a through f), , can made transparent via autounfold m_db.
the problem if globally unfold definition in formula, simplification take forever. instead, want first unfold a * b, apply tactics reduce normal form x, , same x * c , forth.
any idea how accomplish this? here's current approach in a or at a doesn't work. also, it's not clear me whether right structure, or reduce_m ought return something.
ltac reduce_m m := match m | ?a × ?b => reduce_m a; reduce_m b; simpl; autorewrite c_db | ?a => autounfold m_db (* in *); simpl; autorewrite c_db end. ltac simpl_m := match goal | [|- ?m = _ ] => reduce_m m end. a minimalish example:
require import arith. definition add_f (f g : nat -> nat) := fun x => f x + g x. infix "+" := add_f. definition f := fun x => if x =? 4 1 else 0. definition g := fun x => if x <=? 4 3 else 0. definition h := fun x => if x =? 2 2 else 0. lemma ex : f + g + h = fun x => match x | 0 => 3 | 1 => 3 | 2 => 5 | 3 => 3 | 4 => 4 | _ => 0 end.
you can put term in hypothesis , autounfold in that. is, can replace
autounfold m_db (* in *) with
let aterm := fresh in set (aterm := a); autounfold m_db in aterm; subst aterm if a big, slow, because set complicated , sort of reduction. if case, can set goal have:
ha : a' = hb : b' = b hc : c' = c hd : d' = d : e' = e hab : ab = a' * b' habc : abc = ab * c' habcd : abcd = abc * d' habcde : abcde = abcd * e' ------------------------ abcde = f and can like
ltac reduce h := autounfold m_db in h; simpl in h; autorewrite c_db in h. reduce ha; reduce hb; reduce hc; reduce hd; reduce he; subst a' b'; reduce hab; subst ab c'; reduce habc; subst abc d'; reduce habcd; subst abcd e'; reduce habcde; subst abcde. update account example:
to reduction on function, indeed need either function extensionality, or use relation other =. however, don't need function extensionality modularization bits:
require import arith. definition add_f (f g : nat -> nat) := fun x => f x + g x. infix "+" := add_f. definition f := fun x => if x =? 4 1 else 0. definition g := fun x => if x <=? 4 3 else 0. definition h := fun x => if x =? 2 2 else 0. ltac save x x' h := remember x x' eqn:h in *. lemma ex : f + g + h = fun x => match x | 0 => 3 | 1 => 3 | 2 => 5 | 3 => 3 | 4 => 4 | _ => 0 end. proof. save f f' hf; save g g' hg; save h h' hh; save (f' + g') fg hfg; save (fg + h') fgh hfgh. cbv [f g] in *. subst f' g'. cbv [add_f] in hfg. (* note: if want simplify [(if x =? 4 1 else 0) + (if x <=? 4 3 else 0)], need function extensionality. however, don't need modularize simplification. *) alternatively, if set goal bit differently, can avoid function extensionality:
require import arith coq.classes.relationclasses coq.setoids.setoid coq.classes.morphisms. definition add_f (f g : nat -> nat) := fun x => f x + g x. infix "+" := add_f. definition f := fun x => if x =? 4 1 else 0. definition g := fun x => if x <=? 4 3 else 0. definition h := fun x => if x =? 2 2 else 0. ltac save x x' h := remember x x' eqn:h in *. definition nat_case (p : nat -> type) (o : p 0) (s : forall n, p (s n)) (x : nat) : p x := match x | 0 => o | s n' => s n' end. lemma nat_case_plus (a a' : nat) (b b' : nat -> nat) (x : nat) : (nat_case _ b x + nat_case _ a' b' x)%nat = nat_case _ (a + a')%nat (fun x => b x + b' x)%nat x. proof. destruct x; reflexivity. qed. lemma nat_case_plus_const (a : nat) (b : nat -> nat) (x : nat) (y : nat) : (nat_case _ b x + y)%nat = nat_case _ (a + y)%nat (fun x => b x + y)%nat x. proof. destruct x; reflexivity. qed. global instance nat_case_proper {p} : proper (eq ==> forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq)) (nat_case p). proof. unfold forall_relation; intros x x' ? f f' hf [|a]; unfold nat_case; auto. qed. global instance nat_case_proper' {p} : proper (eq ==> pointwise_relation _ eq ==> forall_relation (fun _ => eq)) (nat_case (fun _ => p)). proof. unfold forall_relation, pointwise_relation; intros x x' ? f f' hf [|a]; unfold nat_case; auto. qed. global instance nat_case_proper'' {p} {x} : proper (pointwise_relation _ eq ==> eq ==> eq) (nat_case (fun _ => p) x). proof. intros ??? b ?; subst b; destruct a; simpl; auto. qed. global instance nat_case_proper''' {p} {x} : proper (forall_relation (fun _ => eq) ==> eq ==> eq) (nat_case (fun _ => p) x). proof. intros ??? b ?; subst b; destruct a; simpl; auto. qed. ltac reduce := let solve_tac := unfold nat_case; repeat match goal |- context[match ?x o => _ | _ => _ end] => destruct x end; reflexivity in repeat match goal | [ h : context[if ?x =? 4 ?a else ?b] |- _ ] => replace (if x =? 4 else b) (match x 4 => | _ => b end) in h solve_tac | [ h : context[if ?x =? 2 ?a else ?b] |- _ ] => replace (if x =? 2 else b) (match x 2 => | _ => b end) in h solve_tac | [ h : context[if ?x <=? 4 ?a else ?b] |- _ ] => replace (if x <=? 4 else b) (match x 0 | 1 | 2 | 3 | 4 => | _ => b end) in h solve_tac | [ h : context g[match ?x x' in nat return @?t x' o => ?a | s n => @?s n end] |- _ ] => let g' := context g[@nat_case t s x] in change g' in h | [ h : context g[fun v => match @?x v x' in nat return @?t x' o => ?a | s n => @?s n end] |- _ ] => let g' := context g[fun v => @nat_case t s (x v)] in change g' in h; cbv beta in * | [ h : context[(nat_case _ _ _ _ + nat_case _ _ _ _)%nat] |- _ ] => progress repeat setoid_rewrite nat_case_plus in h; simpl in h | [ h : context[(nat_case _ _ _ _ + _)%nat] |- _ ] => progress repeat setoid_rewrite nat_case_plus_const in h; simpl in h end. lemma ex : forall x, (f + g + h) x = match x | 0 => 3 | 1 => 3 | 2 => 5 | 3 => 3 | 4 => 4 | _ => 0 end. proof. intro x; cbv [add_f]. save (f x) f' hf; save (g x) g' hg; save (h x) h' hh; save (f' + g')%nat fg hfg; save (fg + h')%nat fgh hfgh. cbv [f g] in *. subst f' g'; reduce. cbv [h] in *; reduce. subst fg h'; reduce. subst fgh. unfold nat_case. reflexivity. qed.
Comments
Post a Comment