factored out shared preprocessor setup into theory Code_Abstract_Nat, tuning descriptions
authorhaftmann
Thu Feb 14 12:24:56 2013 +0100 (2013-02-14)
changeset 51113222fb6cb2c3e
parent 51112 da97167e03f7
child 51114 3e913a575dc6
factored out shared preprocessor setup into theory Code_Abstract_Nat, tuning descriptions
src/HOL/Library/Code_Abstract_Nat.thy
src/HOL/Library/Code_Binary_Nat.thy
src/HOL/Library/Code_Target_Nat.thy
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Library/Code_Abstract_Nat.thy	Thu Feb 14 12:24:56 2013 +0100
     1.3 @@ -0,0 +1,113 @@
     1.4 +(*  Title:      HOL/Library/Code_Abstract_Nat.thy
     1.5 +    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
     1.6 +*)
     1.7 +
     1.8 +header {* Avoidance of pattern matching on natural numbers *}
     1.9 +
    1.10 +theory Code_Abstract_Nat
    1.11 +imports Main
    1.12 +begin
    1.13 +
    1.14 +text {*
    1.15 +  When natural numbers are implemented in another than the
    1.16 +  conventional inductive @{term "0::nat"}/@{term Suc} representation,
    1.17 +  it is necessary to avoid all pattern matching on natural numbers
    1.18 +  altogether.  This is accomplished by this theory (up to a certain
    1.19 +  extent).
    1.20 +*}
    1.21 +
    1.22 +subsection {* Case analysis *}
    1.23 +
    1.24 +text {*
    1.25 +  Case analysis on natural numbers is rephrased using a conditional
    1.26 +  expression:
    1.27 +*}
    1.28 +
    1.29 +lemma [code, code_unfold]:
    1.30 +  "nat_case = (\<lambda>f g n. if n = 0 then f else g (n - 1))"
    1.31 +  by (auto simp add: fun_eq_iff dest!: gr0_implies_Suc)
    1.32 +
    1.33 +
    1.34 +subsection {* Preprocessors *}
    1.35 +
    1.36 +text {*
    1.37 +  The term @{term "Suc n"} is no longer a valid pattern.  Therefore,
    1.38 +  all occurrences of this term in a position where a pattern is
    1.39 +  expected (i.e.~on the left-hand side of a code equation) must be
    1.40 +  eliminated.  This can be accomplished – as far as possible – by
    1.41 +  applying the following transformation rule:
    1.42 +*}
    1.43 +
    1.44 +lemma Suc_if_eq: "(\<And>n. f (Suc n) \<equiv> h n) \<Longrightarrow> f 0 \<equiv> g \<Longrightarrow>
    1.45 +  f n \<equiv> if n = 0 then g else h (n - 1)"
    1.46 +  by (rule eq_reflection) (cases n, simp_all)
    1.47 +
    1.48 +text {*
    1.49 +  The rule above is built into a preprocessor that is plugged into
    1.50 +  the code generator.
    1.51 +*}
    1.52 +
    1.53 +setup {*
    1.54 +let
    1.55 +
    1.56 +fun remove_suc thy thms =
    1.57 +  let
    1.58 +    val vname = singleton (Name.variant_list (map fst
    1.59 +      (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
    1.60 +    val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
    1.61 +    fun lhs_of th = snd (Thm.dest_comb
    1.62 +      (fst (Thm.dest_comb (cprop_of th))));
    1.63 +    fun rhs_of th = snd (Thm.dest_comb (cprop_of th));
    1.64 +    fun find_vars ct = (case term_of ct of
    1.65 +        (Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
    1.66 +      | _ $ _ =>
    1.67 +        let val (ct1, ct2) = Thm.dest_comb ct
    1.68 +        in 
    1.69 +          map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
    1.70 +          map (apfst (Thm.apply ct1)) (find_vars ct2)
    1.71 +        end
    1.72 +      | _ => []);
    1.73 +    val eqs = maps
    1.74 +      (fn th => map (pair th) (find_vars (lhs_of th))) thms;
    1.75 +    fun mk_thms (th, (ct, cv')) =
    1.76 +      let
    1.77 +        val th' =
    1.78 +          Thm.implies_elim
    1.79 +           (Conv.fconv_rule (Thm.beta_conversion true)
    1.80 +             (Drule.instantiate'
    1.81 +               [SOME (ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
    1.82 +                 SOME (Thm.lambda cv' (rhs_of th)), NONE, SOME cv']
    1.83 +               @{thm Suc_if_eq})) (Thm.forall_intr cv' th)
    1.84 +      in
    1.85 +        case map_filter (fn th'' =>
    1.86 +            SOME (th'', singleton
    1.87 +              (Variable.trade (K (fn [th'''] => [th''' RS th']))
    1.88 +                (Variable.global_thm_context th'')) th'')
    1.89 +          handle THM _ => NONE) thms of
    1.90 +            [] => NONE
    1.91 +          | thps =>
    1.92 +              let val (ths1, ths2) = split_list thps
    1.93 +              in SOME (subtract Thm.eq_thm (th :: ths1) thms @ ths2) end
    1.94 +      end
    1.95 +  in get_first mk_thms eqs end;
    1.96 +
    1.97 +fun eqn_suc_base_preproc thy thms =
    1.98 +  let
    1.99 +    val dest = fst o Logic.dest_equals o prop_of;
   1.100 +    val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
   1.101 +  in
   1.102 +    if forall (can dest) thms andalso exists (contains_suc o dest) thms
   1.103 +      then thms |> perhaps_loop (remove_suc thy) |> (Option.map o map) Drule.zero_var_indexes
   1.104 +       else NONE
   1.105 +  end;
   1.106 +
   1.107 +val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
   1.108 +
   1.109 +in
   1.110 +
   1.111 +  Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
   1.112 +
   1.113 +end;
   1.114 +*}
   1.115 +
   1.116 +end
     2.1 --- a/src/HOL/Library/Code_Binary_Nat.thy	Thu Feb 14 12:24:42 2013 +0100
     2.2 +++ b/src/HOL/Library/Code_Binary_Nat.thy	Thu Feb 14 12:24:56 2013 +0100
     2.3 @@ -1,11 +1,11 @@
     2.4  (*  Title:      HOL/Library/Code_Binary_Nat.thy
     2.5 -    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
     2.6 +    Author:     Florian Haftmann, TU Muenchen
     2.7  *)
     2.8  
     2.9  header {* Implementation of natural numbers as binary numerals *}
    2.10  
    2.11  theory Code_Binary_Nat
    2.12 -imports Main
    2.13 +imports Code_Abstract_Nat
    2.14  begin
    2.15  
    2.16  text {*
    2.17 @@ -146,104 +146,6 @@
    2.18    by (simp_all add: nat_of_num_numeral)
    2.19  
    2.20  
    2.21 -subsection {* Case analysis *}
    2.22 -
    2.23 -text {*
    2.24 -  Case analysis on natural numbers is rephrased using a conditional
    2.25 -  expression:
    2.26 -*}
    2.27 -
    2.28 -lemma [code, code_unfold]:
    2.29 -  "nat_case = (\<lambda>f g n. if n = 0 then f else g (n - 1))"
    2.30 -  by (auto simp add: fun_eq_iff dest!: gr0_implies_Suc)
    2.31 -
    2.32 -
    2.33 -subsection {* Preprocessors *}
    2.34 -
    2.35 -text {*
    2.36 -  The term @{term "Suc n"} is no longer a valid pattern.
    2.37 -  Therefore, all occurrences of this term in a position
    2.38 -  where a pattern is expected (i.e.~on the left-hand side of a recursion
    2.39 -  equation) must be eliminated.
    2.40 -  This can be accomplished by applying the following transformation rules:
    2.41 -*}
    2.42 -
    2.43 -lemma Suc_if_eq: "(\<And>n. f (Suc n) \<equiv> h n) \<Longrightarrow> f 0 \<equiv> g \<Longrightarrow>
    2.44 -  f n \<equiv> if n = 0 then g else h (n - 1)"
    2.45 -  by (rule eq_reflection) (cases n, simp_all)
    2.46 -
    2.47 -text {*
    2.48 -  The rules above are built into a preprocessor that is plugged into
    2.49 -  the code generator. Since the preprocessor for introduction rules
    2.50 -  does not know anything about modes, some of the modes that worked
    2.51 -  for the canonical representation of natural numbers may no longer work.
    2.52 -*}
    2.53 -
    2.54 -(*<*)
    2.55 -setup {*
    2.56 -let
    2.57 -
    2.58 -fun remove_suc thy thms =
    2.59 -  let
    2.60 -    val vname = singleton (Name.variant_list (map fst
    2.61 -      (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
    2.62 -    val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
    2.63 -    fun lhs_of th = snd (Thm.dest_comb
    2.64 -      (fst (Thm.dest_comb (cprop_of th))));
    2.65 -    fun rhs_of th = snd (Thm.dest_comb (cprop_of th));
    2.66 -    fun find_vars ct = (case term_of ct of
    2.67 -        (Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
    2.68 -      | _ $ _ =>
    2.69 -        let val (ct1, ct2) = Thm.dest_comb ct
    2.70 -        in 
    2.71 -          map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
    2.72 -          map (apfst (Thm.apply ct1)) (find_vars ct2)
    2.73 -        end
    2.74 -      | _ => []);
    2.75 -    val eqs = maps
    2.76 -      (fn th => map (pair th) (find_vars (lhs_of th))) thms;
    2.77 -    fun mk_thms (th, (ct, cv')) =
    2.78 -      let
    2.79 -        val th' =
    2.80 -          Thm.implies_elim
    2.81 -           (Conv.fconv_rule (Thm.beta_conversion true)
    2.82 -             (Drule.instantiate'
    2.83 -               [SOME (ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
    2.84 -                 SOME (Thm.lambda cv' (rhs_of th)), NONE, SOME cv']
    2.85 -               @{thm Suc_if_eq})) (Thm.forall_intr cv' th)
    2.86 -      in
    2.87 -        case map_filter (fn th'' =>
    2.88 -            SOME (th'', singleton
    2.89 -              (Variable.trade (K (fn [th'''] => [th''' RS th']))
    2.90 -                (Variable.global_thm_context th'')) th'')
    2.91 -          handle THM _ => NONE) thms of
    2.92 -            [] => NONE
    2.93 -          | thps =>
    2.94 -              let val (ths1, ths2) = split_list thps
    2.95 -              in SOME (subtract Thm.eq_thm (th :: ths1) thms @ ths2) end
    2.96 -      end
    2.97 -  in get_first mk_thms eqs end;
    2.98 -
    2.99 -fun eqn_suc_base_preproc thy thms =
   2.100 -  let
   2.101 -    val dest = fst o Logic.dest_equals o prop_of;
   2.102 -    val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
   2.103 -  in
   2.104 -    if forall (can dest) thms andalso exists (contains_suc o dest) thms
   2.105 -      then thms |> perhaps_loop (remove_suc thy) |> (Option.map o map) Drule.zero_var_indexes
   2.106 -       else NONE
   2.107 -  end;
   2.108 -
   2.109 -val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
   2.110 -
   2.111 -in
   2.112 -
   2.113 -  Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
   2.114 -
   2.115 -end;
   2.116 -*}
   2.117 -(*>*)
   2.118 -
   2.119  code_modulename SML
   2.120    Code_Binary_Nat Arith
   2.121  
     3.1 --- a/src/HOL/Library/Code_Target_Nat.thy	Thu Feb 14 12:24:42 2013 +0100
     3.2 +++ b/src/HOL/Library/Code_Target_Nat.thy	Thu Feb 14 12:24:56 2013 +0100
     3.3 @@ -1,11 +1,11 @@
     3.4  (*  Title:      HOL/Library/Code_Target_Nat.thy
     3.5 -    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
     3.6 +    Author:     Florian Haftmann, TU Muenchen
     3.7  *)
     3.8  
     3.9  header {* Implementation of natural numbers by target-language integers *}
    3.10  
    3.11  theory Code_Target_Nat
    3.12 -imports Main Code_Numeral_Types Code_Binary_Nat
    3.13 +imports Code_Abstract_Nat Code_Numeral_Types
    3.14  begin
    3.15  
    3.16  subsection {* Implementation for @{typ nat} *}
    3.17 @@ -52,18 +52,15 @@
    3.18    "integer_of_nat 1 = 1"
    3.19    by (simp add: integer_eq_iff integer_of_nat_def)
    3.20  
    3.21 +lemma [code]:
    3.22 +  "Suc n = n + 1"
    3.23 +  by simp
    3.24 +
    3.25  lemma [code abstract]:
    3.26    "integer_of_nat (m + n) = of_nat m + of_nat n"
    3.27    by (simp add: integer_eq_iff integer_of_nat_def)
    3.28  
    3.29  lemma [code abstract]:
    3.30 -  "integer_of_nat (Code_Binary_Nat.dup n) = Code_Numeral_Types.dup (of_nat n)"
    3.31 -  by (simp add: integer_eq_iff Code_Binary_Nat.dup_def integer_of_nat_def)
    3.32 -
    3.33 -lemma [code, code del]:
    3.34 -  "Code_Binary_Nat.sub = Code_Binary_Nat.sub" ..
    3.35 -
    3.36 -lemma [code abstract]:
    3.37    "integer_of_nat (m - n) = max 0 (of_nat m - of_nat n)"
    3.38    by (simp add: integer_eq_iff integer_of_nat_def)
    3.39