src/HOL/Library/Code_Abstract_Nat.thy
 changeset 51113 222fb6cb2c3e child 55415 05f5fdb8d093
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.107 +val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
1.109 +in
1.111 +  Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
1.113 +end;
1.114 +*}
1.116 +end