Commit 29a02e9c by Guillaume Melquiond

### Recognize Flocq's bpow as a constant.

parent 5b2b4140
 ... @@ -114,8 +114,7 @@ Definition cons_unique (e : expr) (l : list expr) := ... @@ -114,8 +114,7 @@ Definition cons_unique (e : expr) (l : list expr) := Fixpoint split_expr (e : expr) (lp lc : list expr) := Fixpoint split_expr (e : expr) (lp lc : list expr) := match e with match e with | Evar n => Scomposed lp lc | Evar n => Scomposed lp lc | Eint n => Sconst | Econst o => Sconst | Econst_pi => Sconst | Eunary o e1 => | Eunary o e1 => match split_expr e1 lp lc with match split_expr e1 lp lc with | Sconst => Sconst | Sconst => Sconst ... @@ -138,15 +137,15 @@ Fixpoint split_expr (e : expr) (lp lc : list expr) := ... @@ -138,15 +137,15 @@ Fixpoint split_expr (e : expr) (lp lc : list expr) := Theorem split_expr_correct : Theorem split_expr_correct : forall vars e lp lc, forall vars e lp lc, (forall n, eval (nth n lc (Eint 0)) vars = eval (nth n lc (Eint 0)) nil) -> (forall n, eval (nth n lc (Econst (Int 0))) vars = eval (nth n lc (Econst (Int 0))) nil) -> match split_expr e lp lc with match split_expr e lp lc with | Sconst => eval e vars = eval e nil | Sconst => eval e vars = eval e nil | Scomposed lp' lc' => | Scomposed lp' lc' => forall n, eval (nth n lc' (Eint 0)) vars = eval (nth n lc' (Eint 0)) nil forall n, eval (nth n lc' (Econst (Int 0))) vars = eval (nth n lc' (Econst (Int 0))) nil end. end. Proof. Proof. intros vars. intros vars. induction e as [n|n| |o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; try easy. induction e as [n|o|o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; try easy. specialize (IHe1 lp lc Hc). specialize (IHe1 lp lc Hc). destruct split_expr as [|lp' lc']. destruct split_expr as [|lp' lc']. now apply f_equal. now apply f_equal. ... @@ -154,9 +153,9 @@ induction e as [n|n| |o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; t ... @@ -154,9 +153,9 @@ induction e as [n|n| |o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; t specialize (IHe2 lp lc Hc). specialize (IHe2 lp lc Hc). assert (H: forall e l, assert (H: forall e l, eval e vars = eval e nil -> eval e vars = eval e nil -> (forall n, eval (nth n l (Eint 0)) vars = eval (nth n l (Eint 0)) nil) -> (forall n, eval (nth n l (Econst (Int 0))) vars = eval (nth n l (Econst (Int 0))) nil) -> forall n, forall n, eval (nth n (rcons_unique e l) (Eint 0)) vars = eval (nth n (rcons_unique e l) (Eint 0)) nil). eval (nth n (rcons_unique e l) (Econst (Int 0))) vars = eval (nth n (rcons_unique e l) (Econst (Int 0))) nil). intros e l He Hl. intros e l He Hl. induction l as [|h t IH] ; simpl. induction l as [|h t IH] ; simpl. now intros [|[|n]]. now intros [|[|n]]. ... @@ -202,14 +201,14 @@ Definition find_expr (e : expr) (vars : nat) (lp lc : list expr) := ... @@ -202,14 +201,14 @@ Definition find_expr (e : expr) (vars : nat) (lp lc : list expr) := Theorem find_expr_correct : Theorem find_expr_correct : forall e vars lp lc, forall e vars lp lc, match find_expr e vars lp lc with match find_expr e vars lp lc with | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Eint 0) = e | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e | None => True | None => True end. end. Proof. Proof. intros e vars lp lc. intros e vars lp lc. assert (H1: forall l n, assert (H1: forall l n, match find_expr_aux e n l with match find_expr_aux e n l with | Some k => (n <= k < n + length l)%nat /\ nth (k - n) l (Eint 0) = e | Some k => (n <= k < n + length l)%nat /\ nth (k - n) l (Econst (Int 0)) = e | None => True | None => True end). end). induction l as [|h t IH]. induction l as [|h t IH]. ... @@ -242,7 +241,7 @@ set (foo := ... @@ -242,7 +241,7 @@ set (foo := end). end). assert (H2: assert (H2: match foo with match foo with | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Eint 0) = e | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e | None => True | None => True end). end). unfold foo. unfold foo. ... @@ -261,7 +260,7 @@ assert (H2: ... @@ -261,7 +260,7 @@ assert (H2: rewrite app_nth2 ; rewrite map_length, seq_length. rewrite app_nth2 ; rewrite map_length, seq_length. now rewrite <- Nat.sub_add_distr. now rewrite <- Nat.sub_add_distr. lia. lia. destruct e as [| | |o n1|o n1 n2] ; simpl ; try easy. destruct e as [n|o|o n1|o n1 n2] ; simpl ; try easy. destruct (Nat.ltb_spec n vars) as [H|H] ; try easy. destruct (Nat.ltb_spec n vars) as [H|H] ; try easy. rewrite app_nth2 by apply le_plus_l. rewrite app_nth2 by apply le_plus_l. rewrite minus_plus. rewrite minus_plus. ... @@ -278,8 +277,7 @@ Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) := ... @@ -278,8 +277,7 @@ Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) := | cons h t => | cons h t => match h with match h with | Evar n => decompose vars (cons (Forward (length t + n)) p) t lc | Evar n => decompose vars (cons (Forward (length t + n)) p) t lc | Eint _ => None | Econst _ => None | Econst_pi => None | Eunary o e1 => | Eunary o e1 => match find_expr e1 vars t lc with match find_expr e1 vars t lc with | Some n => decompose vars (cons (Unary o n) p) t lc | Some n => decompose vars (cons (Unary o n) p) t lc ... @@ -299,7 +297,7 @@ Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) := ... @@ -299,7 +297,7 @@ Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) := Theorem decompose_correct : Theorem decompose_correct : forall vars p lp lc, forall vars p lp lc, (forall vars n, eval (nth n lc (Eint 0)) vars = eval (nth n lc (Eint 0)) nil) -> (forall vars n, eval (nth n lc (Econst (Int 0))) vars = eval (nth n lc (Econst (Int 0))) nil) -> let lc' := map (fun c => eval c nil) lc in let lc' := map (fun c => eval c nil) lc in match decompose (length vars) p lp lc with match decompose (length vars) p lp lc with | None => True | None => True ... @@ -315,14 +313,14 @@ easy. ... @@ -315,14 +313,14 @@ easy. intros p. intros p. simpl. simpl. assert (H: forall n e, assert (H: forall n e, nth n (t ++ map Evar (seq 0 (length vars)) ++ lc) (Eint 0) = e -> nth n (t ++ map Evar (seq 0 (length vars)) ++ lc) (Econst (Int 0)) = e -> nth n (map (fun c : expr => eval c (vars ++ lc')) t ++ vars ++ lc') 0%R = eval e (vars ++ lc')). nth n (map (fun c : expr => eval c (vars ++ lc')) t ++ vars ++ lc') 0%R = eval e (vars ++ lc')). intros n e. intros n e. destruct (Nat.lt_ge_cases n (length t)) as [H1|H1]. destruct (Nat.lt_ge_cases n (length t)) as [H1|H1]. rewrite app_nth1 by apply H1. rewrite app_nth1 by apply H1. intros H. intros H. rewrite app_nth1 by now rewrite map_length. rewrite app_nth1 by now rewrite map_length. change 0%R with ((fun c => eval c (vars ++ lc')) (Eint 0)). change 0%R with ((fun c => eval c (vars ++ lc')) (Econst (Int 0))). rewrite map_nth. rewrite map_nth. now rewrite H. now rewrite H. rewrite app_nth2 by apply H1. rewrite app_nth2 by apply H1. ... @@ -341,11 +339,11 @@ assert (H: forall n e, ... @@ -341,11 +339,11 @@ assert (H: forall n e, rewrite app_nth2 by apply H2. rewrite app_nth2 by apply H2. intros H. intros H. unfold lc'. unfold lc'. change 0%R with ((fun c => eval c nil) (Eint 0)). change 0%R with ((fun c => eval c nil) (Econst (Int 0))). rewrite map_nth, H. rewrite map_nth, H. rewrite <- H at 2. rewrite <- H at 2. now rewrite Hc, H. now rewrite Hc, H. destruct h as [| | |o e1|o e1 e2] ; try easy. destruct h as [n|o|o e1|o e1 e2] ; try easy. - specialize (IH (Forward (length t + n) :: p)). - specialize (IH (Forward (length t + n) :: p)). destruct decompose ; try easy. destruct decompose ; try easy. rewrite IH. rewrite IH. ... @@ -384,8 +382,7 @@ Qed. ... @@ -384,8 +382,7 @@ Qed. Fixpoint max_arity (e : expr) (n : nat) := Fixpoint max_arity (e : expr) (n : nat) := match e with match e with | Evar k => Nat.ltb k n | Evar k => Nat.ltb k n | Eint _ => true | Econst _ => true | Econst_pi => true | Eunary o e1 => max_arity e1 n | Eunary o e1 => max_arity e1 n | Ebinary o e1 e2 => if max_arity e1 n then max_arity e2 n else false | Ebinary o e1 e2 => if max_arity e1 n then max_arity e2 n else false end. end. ... @@ -454,7 +451,7 @@ unfold eval_real'. ... @@ -454,7 +451,7 @@ unfold eval_real'. intros H' ->. intros H' ->. simpl. simpl. clear -H'. clear -H'. induction e as [n| | |o e1|o e1 IHe1 e2 IHe2] ; simpl ; try easy. induction e as [n|o|o e1|o e1 IHe1 e2 IHe2] ; simpl ; try easy. apply app_nth1. apply app_nth1. simpl in H'. simpl in H'. now apply Nat.ltb_lt. now apply Nat.ltb_lt. ... ...
 ... @@ -23,6 +23,9 @@ Require Import Xreal. ... @@ -23,6 +23,9 @@ Require Import Xreal. Require Import Basic. Require Import Basic. Require Import Interval. Require Import Interval. Inductive nullary_op : Set := | Int (n : Z) | Bpow (r n : Z) | Pi. Inductive unary_op : Set := Inductive unary_op : Set := | Neg | Abs | Inv | Sqr | Sqrt | Neg | Abs | Inv | Sqr | Sqrt | Cos | Sin | Tan | Atan | Exp | Ln | Cos | Sin | Tan | Atan | Exp | Ln ... @@ -33,11 +36,24 @@ Inductive binary_op : Set := ... @@ -33,11 +36,24 @@ Inductive binary_op : Set := Inductive expr : Set := Inductive expr : Set := | Evar : nat -> expr | Evar : nat -> expr | Eint : Z -> expr | Econst : nullary_op -> expr | Econst_pi : expr | Eunary : unary_op -> expr -> expr | Eunary : unary_op -> expr -> expr | Ebinary : binary_op -> expr -> expr -> expr. | Ebinary : binary_op -> expr -> expr -> expr. Definition bpow' (r e : Z) := match e with | 0%Z => 1%R | Z.pos p => IZR (Z.pow_pos r p) | Z.neg p => (/ IZR (Z.pow_pos r p))%R end. Definition nullary_real (o : nullary_op) : R := match o with | Int n => IZR n | Bpow r n => bpow' r n | Pi => PI end. Definition unary_real (o : unary_op) : R -> R := Definition unary_real (o : unary_op) : R -> R := match o with match o with | Neg => Ropp | Neg => Ropp ... @@ -66,8 +82,7 @@ Definition binary_real (o : binary_op) : R -> R -> R := ... @@ -66,8 +82,7 @@ Definition binary_real (o : binary_op) : R -> R -> R := Fixpoint eval (e : expr) (l : list R) := Fixpoint eval (e : expr) (l : list R) := match e with match e with | Evar n => nth n l 0%R | Evar n => nth n l 0%R | Eint n => IZR n | Econst o => nullary_real o | Econst_pi => PI | Eunary o e1 => unary_real o (eval e1 l) | Eunary o e1 => unary_real o (eval e1 l) | Ebinary o e1 e2 => binary_real o (eval e1 l) (eval e2 l) | Ebinary o e1 e2 => binary_real o (eval e1 l) (eval e2 l) end. end. ... @@ -123,6 +138,7 @@ Ltac get_vars t l := ... @@ -123,6 +138,7 @@ Ltac get_vars t l := | IZR (Raux.Zceil ?a) => aux_u a | IZR (Raux.Zceil ?a) => aux_u a | IZR (Round_NE.ZnearestE ?a) => aux_u a | IZR (Round_NE.ZnearestE ?a) => aux_u a | PI => l | PI => l | Raux.bpow _ _ => l | IZR ?n => l | IZR ?n => l | _ => list_add t l | _ => list_add t l end in end in ... @@ -163,8 +179,9 @@ Ltac reify t l := ... @@ -163,8 +179,9 @@ Ltac reify t l := | IZR (Raux.Zfloor ?a) => aux_u (Nearbyint rnd_DN) a | IZR (Raux.Zfloor ?a) => aux_u (Nearbyint rnd_DN) a | IZR (Raux.Zceil ?a) => aux_u (Nearbyint rnd_UP) a | IZR (Raux.Zceil ?a) => aux_u (Nearbyint rnd_UP) a | IZR (Round_NE.ZnearestE ?a) => aux_u (Nearbyint rnd_NE) a | IZR (Round_NE.ZnearestE ?a) => aux_u (Nearbyint rnd_NE) a | PI => constr:(Econst_pi) | PI => constr:(Econst Pi) | IZR ?n => constr:(Eint n) | Raux.bpow ?r ?n => constr:(Econst (Bpow (Zaux.radix_val r) n)) | IZR ?n => constr:(Econst (Int n)) | _ => | _ => let n := list_find t l in let n := list_find t l in constr:(Evar n) constr:(Evar n) ... @@ -175,6 +192,27 @@ Module Bnd (I : IntervalOps). ... @@ -175,6 +192,27 @@ Module Bnd (I : IntervalOps). Module J := IntervalExt I. Module J := IntervalExt I. Definition nullary_bnd prec (o : nullary_op) : I.type := match o with | Int n => I.fromZ n | Bpow r n => I.power_int prec (I.fromZ r) n | Pi => I.pi prec end. Lemma nullary_bnd_correct : forall prec o, contains (I.convert (nullary_bnd prec o)) (Xreal (nullary_real o)). Proof. intros prec [n|r n|]. - apply I.fromZ_correct. - simpl. replace (bpow' r n) with (powerRZ (IZR r) n). apply J.power_int_correct. apply I.fromZ_correct. destruct n as [|n|n] ; simpl ; try rewrite Zpower_pos_powerRZ ; easy. - apply I.pi_correct. Qed. Definition unary_bnd prec (o : unary_op) : I.type -> I.type := Definition unary_bnd prec (o : unary_op) : I.type -> I.type := match o with match o with | Neg => I.neg | Neg => I.neg ... @@ -239,8 +277,7 @@ Qed. ... @@ -239,8 +277,7 @@ Qed. Fixpoint eval_bnd (prec : I.precision) (e : expr) := Fixpoint eval_bnd (prec : I.precision) (e : expr) := match e with match e with | Evar _ => I.nai | Evar _ => I.nai | Eint n => I.fromZ n | Econst o => nullary_bnd prec o | Econst_pi => I.pi prec | Eunary o e1 => unary_bnd prec o (eval_bnd prec e1) | Eunary o e1 => unary_bnd prec o (eval_bnd prec e1) | Ebinary o e1 e2 => binary_bnd prec o (eval_bnd prec e1) (eval_bnd prec e2) | Ebinary o e1 e2 => binary_bnd prec o (eval_bnd prec e1) (eval_bnd prec e2) end. end. ... @@ -250,13 +287,11 @@ Theorem eval_bnd_correct : ... @@ -250,13 +287,11 @@ Theorem eval_bnd_correct : contains (I.convert (eval_bnd prec e)) (Xreal (eval e nil)). contains (I.convert (eval_bnd prec e)) (Xreal (eval e nil)). Proof. Proof. intros prec. intros prec. induction e as [n|n| |o e1 IHe1|o e1 IHe1 e2 IHe2]. induction e as [n|o|o e1 IHe1|o e1 IHe1 e2 IHe2]. simpl. - apply contains_Inan, I.nai_correct. now rewrite I.nai_correct. - apply nullary_bnd_correct. apply I.fromZ_correct. - now apply unary_bnd_correct. apply I.pi_correct. - now apply binary_bnd_correct. now apply unary_bnd_correct. now apply binary_bnd_correct. Qed. Qed. End Bnd. End Bnd.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!