src/HOL/Decision_Procs/approximation_generator.ML
changeset 74397 e80c4cde6064
parent 71037 f630f2e707a6
equal deleted inserted replaced
74396:dc73f9e6476b 74397:e80c4cde6064
    31 
    31 
    32 fun int_of_term t = snd (HOLogic.dest_number t) handle TERM _ => raise TERM ("int_of_term", [t]);
    32 fun int_of_term t = snd (HOLogic.dest_number t) handle TERM _ => raise TERM ("int_of_term", [t]);
    33 
    33 
    34 fun real_of_man_exp m e = Real.fromManExp {man = Real.fromInt m, exp = e}
    34 fun real_of_man_exp m e = Real.fromManExp {man = Real.fromInt m, exp = e}
    35 
    35 
    36 fun mapprox_float (\<^term>\<open>Float\<close> $ m $ e) = real_of_man_exp (int_of_term m) (int_of_term e)
    36 fun mapprox_float \<^Const_>\<open>Float for m e\<close> = real_of_man_exp (int_of_term m) (int_of_term e)
    37   | mapprox_float t = Real.fromInt (snd (HOLogic.dest_number t))
    37   | mapprox_float t = Real.fromInt (snd (HOLogic.dest_number t))
    38       handle TERM _ => raise TERM ("mapprox_float", [t]);
    38       handle TERM _ => raise TERM ("mapprox_float", [t]);
    39 
    39 
    40 (* TODO: define using compiled terms? *)
    40 (* TODO: define using compiled terms? *)
    41 fun mapprox_floatarith (\<^term>\<open>Add\<close> $ a $ b) xs = mapprox_floatarith a xs + mapprox_floatarith b xs
    41 fun mapprox_floatarith \<^Const_>\<open>Add for a b\<close> xs = mapprox_floatarith a xs + mapprox_floatarith b xs
    42   | mapprox_floatarith (\<^term>\<open>Minus\<close> $ a) xs = ~ (mapprox_floatarith a xs)
    42   | mapprox_floatarith \<^Const_>\<open>Minus for a\<close> xs = ~ (mapprox_floatarith a xs)
    43   | mapprox_floatarith (\<^term>\<open>Mult\<close> $ a $ b) xs = mapprox_floatarith a xs * mapprox_floatarith b xs
    43   | mapprox_floatarith \<^Const_>\<open>Mult for a b\<close> xs = mapprox_floatarith a xs * mapprox_floatarith b xs
    44   | mapprox_floatarith (\<^term>\<open>Inverse\<close> $ a) xs = 1.0 / mapprox_floatarith a xs
    44   | mapprox_floatarith \<^Const_>\<open>Inverse for a\<close> xs = 1.0 / mapprox_floatarith a xs
    45   | mapprox_floatarith (\<^term>\<open>Cos\<close> $ a) xs = Math.cos (mapprox_floatarith a xs)
    45   | mapprox_floatarith \<^Const_>\<open>Cos for a\<close> xs = Math.cos (mapprox_floatarith a xs)
    46   | mapprox_floatarith (\<^term>\<open>Arctan\<close> $ a) xs = Math.atan (mapprox_floatarith a xs)
    46   | mapprox_floatarith \<^Const_>\<open>Arctan for a\<close> xs = Math.atan (mapprox_floatarith a xs)
    47   | mapprox_floatarith (\<^term>\<open>Abs\<close> $ a) xs = abs (mapprox_floatarith a xs)
    47   | mapprox_floatarith \<^Const_>\<open>Abs for a\<close> xs = abs (mapprox_floatarith a xs)
    48   | mapprox_floatarith (\<^term>\<open>Max\<close> $ a $ b) xs =
    48   | mapprox_floatarith \<^Const_>\<open>Max for a b\<close> xs =
    49       Real.max (mapprox_floatarith a xs, mapprox_floatarith b xs)
    49       Real.max (mapprox_floatarith a xs, mapprox_floatarith b xs)
    50   | mapprox_floatarith (\<^term>\<open>Min\<close> $ a $ b) xs =
    50   | mapprox_floatarith \<^Const_>\<open>Min for a b\<close> xs =
    51       Real.min (mapprox_floatarith a xs, mapprox_floatarith b xs)
    51       Real.min (mapprox_floatarith a xs, mapprox_floatarith b xs)
    52   | mapprox_floatarith \<^term>\<open>Pi\<close> _ = Math.pi
    52   | mapprox_floatarith \<^Const_>\<open>Pi\<close> _ = Math.pi
    53   | mapprox_floatarith (\<^term>\<open>Sqrt\<close> $ a) xs = Math.sqrt (mapprox_floatarith a xs)
    53   | mapprox_floatarith \<^Const_>\<open>Sqrt for a\<close> xs = Math.sqrt (mapprox_floatarith a xs)
    54   | mapprox_floatarith (\<^term>\<open>Exp\<close> $ a) xs = Math.exp (mapprox_floatarith a xs)
    54   | mapprox_floatarith \<^Const_>\<open>Exp for a\<close> xs = Math.exp (mapprox_floatarith a xs)
    55   | mapprox_floatarith (\<^term>\<open>Powr\<close> $ a $ b) xs =
    55   | mapprox_floatarith \<^Const_>\<open>Powr for a b\<close> xs =
    56       Math.pow (mapprox_floatarith a xs, mapprox_floatarith b xs)
    56       Math.pow (mapprox_floatarith a xs, mapprox_floatarith b xs)
    57   | mapprox_floatarith (\<^term>\<open>Ln\<close> $ a) xs = Math.ln (mapprox_floatarith a xs)
    57   | mapprox_floatarith \<^Const_>\<open>Ln for a\<close> xs = Math.ln (mapprox_floatarith a xs)
    58   | mapprox_floatarith (\<^term>\<open>Power\<close> $ a $ n) xs =
    58   | mapprox_floatarith \<^Const_>\<open>Power for a n\<close> xs =
    59       Math.pow (mapprox_floatarith a xs, Real.fromInt (nat_of_term n))
    59       Math.pow (mapprox_floatarith a xs, Real.fromInt (nat_of_term n))
    60   | mapprox_floatarith (\<^term>\<open>Floor\<close> $ a) xs = Real.fromInt (floor (mapprox_floatarith a xs))
    60   | mapprox_floatarith \<^Const_>\<open>Floor for a\<close> xs = Real.fromInt (floor (mapprox_floatarith a xs))
    61   | mapprox_floatarith (\<^term>\<open>Var\<close> $ n) xs = nth xs (nat_of_term n)
    61   | mapprox_floatarith \<^Const_>\<open>Var for n\<close> xs = nth xs (nat_of_term n)
    62   | mapprox_floatarith (\<^term>\<open>Num\<close> $ m) _ = mapprox_float m
    62   | mapprox_floatarith \<^Const_>\<open>Num for m\<close> _ = mapprox_float m
    63   | mapprox_floatarith t _ = raise TERM ("mapprox_floatarith", [t])
    63   | mapprox_floatarith t _ = raise TERM ("mapprox_floatarith", [t])
    64 
    64 
    65 fun mapprox_atLeastAtMost eps x a b xs =
    65 fun mapprox_atLeastAtMost eps x a b xs =
    66     let
    66     let
    67       val x' = mapprox_floatarith x xs
    67       val x' = mapprox_floatarith x xs
    68     in
    68     in
    69       mapprox_floatarith a xs + eps <= x' andalso x' + eps <= mapprox_floatarith b xs
    69       mapprox_floatarith a xs + eps <= x' andalso x' + eps <= mapprox_floatarith b xs
    70     end
    70     end
    71 
    71 
    72 fun mapprox_form eps (\<^term>\<open>Bound\<close> $ x $ a $ b $ f) xs =
    72 fun mapprox_form eps \<^Const_>\<open>Bound for x a b f\<close> xs =
    73     (not (mapprox_atLeastAtMost eps x a b xs)) orelse mapprox_form eps f xs
    73     (not (mapprox_atLeastAtMost eps x a b xs)) orelse mapprox_form eps f xs
    74 | mapprox_form eps (\<^term>\<open>Assign\<close> $ x $ a $ f) xs =
    74 | mapprox_form eps \<^Const_>\<open>Assign for x a f\<close> xs =
    75     (Real.!= (mapprox_floatarith x xs, mapprox_floatarith a xs)) orelse mapprox_form eps f xs
    75     (Real.!= (mapprox_floatarith x xs, mapprox_floatarith a xs)) orelse mapprox_form eps f xs
    76 | mapprox_form eps (\<^term>\<open>Less\<close> $ a $ b) xs = mapprox_floatarith a xs + eps < mapprox_floatarith b xs
    76 | mapprox_form eps \<^Const_>\<open>Less for a b\<close> xs = mapprox_floatarith a xs + eps < mapprox_floatarith b xs
    77 | mapprox_form eps (\<^term>\<open>LessEqual\<close> $ a $ b) xs = mapprox_floatarith a xs + eps <= mapprox_floatarith b xs
    77 | mapprox_form eps \<^Const_>\<open>LessEqual for a b\<close> xs = mapprox_floatarith a xs + eps <= mapprox_floatarith b xs
    78 | mapprox_form eps (\<^term>\<open>AtLeastAtMost\<close> $ x $ a $ b) xs = mapprox_atLeastAtMost eps x a b xs
    78 | mapprox_form eps \<^Const_>\<open>AtLeastAtMost for x a b\<close> xs = mapprox_atLeastAtMost eps x a b xs
    79 | mapprox_form eps (\<^term>\<open>Conj\<close> $ f $ g) xs = mapprox_form eps f xs andalso mapprox_form eps g xs
    79 | mapprox_form eps \<^Const_>\<open>Conj for f g\<close> xs = mapprox_form eps f xs andalso mapprox_form eps g xs
    80 | mapprox_form eps (\<^term>\<open>Disj\<close> $ f $ g) xs = mapprox_form eps f xs orelse mapprox_form eps g xs
    80 | mapprox_form eps \<^Const_>\<open>Disj for f g\<close> xs = mapprox_form eps f xs orelse mapprox_form eps g xs
    81 | mapprox_form _ t _ = raise TERM ("mapprox_form", [t])
    81 | mapprox_form _ t _ = raise TERM ("mapprox_form", [t])
    82 
    82 
    83 fun dest_interpret_form (\<^const>\<open>interpret_form\<close> $ b $ xs) = (b, xs)
    83 fun dest_interpret_form \<^Const_>\<open>interpret_form for b xs\<close> = (b, xs)
    84   | dest_interpret_form t = raise TERM ("dest_interpret_form", [t])
    84   | dest_interpret_form t = raise TERM ("dest_interpret_form", [t])
    85 
       
    86 fun optionT t = Type (\<^type_name>\<open>option\<close>, [t])
       
    87 fun mk_Some t = Const (\<^const_name>\<open>Some\<close>, t --> optionT t)
       
    88 
    85 
    89 fun random_float_list size xs seed =
    86 fun random_float_list size xs seed =
    90   fold (K (apsnd (random_float size) #-> (fn c => apfst (fn b => b::c)))) xs ([],seed)
    87   fold (K (apsnd (random_float size) #-> (fn c => apfst (fn b => b::c)))) xs ([],seed)
    91 
    88 
    92 fun real_of_Float (@{code Float} (m, e)) =
    89 fun real_of_Float (@{code Float} (m, e)) =
    94 
    91 
    95 fun term_of_int i = (HOLogic.mk_number @{typ int} (@{code integer_of_int} i))
    92 fun term_of_int i = (HOLogic.mk_number @{typ int} (@{code integer_of_int} i))
    96 
    93 
    97 fun term_of_Float (@{code Float} (m, e)) = @{term Float} $ term_of_int m $ term_of_int e
    94 fun term_of_Float (@{code Float} (m, e)) = @{term Float} $ term_of_int m $ term_of_int e
    98 
    95 
    99 fun is_True \<^term>\<open>True\<close> = true
    96 fun is_True \<^Const_>\<open>True\<close> = true
   100   | is_True _ = false
    97   | is_True _ = false
   101 
    98 
   102 val postproc_form_eqs =
    99 val postproc_form_eqs =
   103   @{lemma
   100   @{lemma
   104     "real_of_float (Float 0 a) = 0"
   101     "real_of_float (Float 0 a) = 0"
   128 
   125 
   129 fun approx_random ctxt prec eps frees e xs genuine_only size seed =
   126 fun approx_random ctxt prec eps frees e xs genuine_only size seed =
   130   let
   127   let
   131     val (rs, seed') = random_float_list size xs seed
   128     val (rs, seed') = random_float_list size xs seed
   132     fun mk_approx_form e ts =
   129     fun mk_approx_form e ts =
   133       \<^const>\<open>approx_form\<close> $
   130       \<^Const>\<open>approx_form\<close> $
   134         HOLogic.mk_number \<^typ>\<open>nat\<close> prec $
   131         HOLogic.mk_number \<^Type>\<open>nat\<close> prec $
   135         e $
   132         e $
   136         (HOLogic.mk_list \<^typ>\<open>(float interval) option\<close>
   133         (HOLogic.mk_list \<^typ>\<open>float interval option\<close>
   137           (map (fn t => mk_Some \<^typ>\<open>float interval\<close> $ (\<^term>\<open>interval_of::float\<Rightarrow>_\<close> $ t)) ts)) $
   134           (map (fn t => \<^Const>\<open>Some \<^typ>\<open>float interval\<close>\<close> $ \<^Const>\<open>interval_of \<^Type>\<open>float\<close> for t\<close>) ts)) $
   138         \<^term>\<open>[] :: nat list\<close>
   135         \<^Const>\<open>Nil \<^Type>\<open>nat\<close>\<close>
   139   in
   136   in
   140     (if
   137     (if
   141       mapprox_form eps e (map (real_of_Float o fst) rs)
   138       mapprox_form eps e (map (real_of_Float o fst) rs)
   142       handle
   139       handle
   143         General.Overflow => false
   140         General.Overflow => false
   148       let
   145       let
   149         val ts = map (fn x => term_of_Float (fst x)) rs
   146         val ts = map (fn x => term_of_Float (fst x)) rs
   150         val ts' = map
   147         val ts' = map
   151           (AList.lookup op = (map dest_Free xs ~~ ts)
   148           (AList.lookup op = (map dest_Free xs ~~ ts)
   152             #> the_default Term.dummy
   149             #> the_default Term.dummy
   153             #> curry op $ \<^term>\<open>real_of_float::float\<Rightarrow>_\<close>
   150             #> curry op $ \<^Const>\<open>real_of_float\<close>
   154             #> conv_term ctxt (rewrite_with ctxt postproc_form_eqs))
   151             #> conv_term ctxt (rewrite_with ctxt postproc_form_eqs))
   155           frees
   152           frees
   156       in
   153       in
   157         if Approximation.approximate ctxt (mk_approx_form e ts) |> is_True
   154         if Approximation.approximate ctxt (mk_approx_form e ts) |> is_True
   158         then SOME (true, ts')
   155         then SOME (true, ts')