src/HOL/Library/Code_Abstract_Nat.thy
 author haftmann Sat Jun 28 21:09:15 2014 +0200 (2014-06-28) changeset 57426 2cd2ccd81f93 parent 56790 f54097170704 child 57427 91f9e4148460 permissions -rw-r--r--
modernized
```     1 (*  Title:      HOL/Library/Code_Abstract_Nat.thy
```
```     2     Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
```
```     3 *)
```
```     4
```
```     5 header {* Avoidance of pattern matching on natural numbers *}
```
```     6
```
```     7 theory Code_Abstract_Nat
```
```     8 imports Main
```
```     9 begin
```
```    10
```
```    11 text {*
```
```    12   When natural numbers are implemented in another than the
```
```    13   conventional inductive @{term "0::nat"}/@{term Suc} representation,
```
```    14   it is necessary to avoid all pattern matching on natural numbers
```
```    15   altogether.  This is accomplished by this theory (up to a certain
```
```    16   extent).
```
```    17 *}
```
```    18
```
```    19 subsection {* Case analysis *}
```
```    20
```
```    21 text {*
```
```    22   Case analysis on natural numbers is rephrased using a conditional
```
```    23   expression:
```
```    24 *}
```
```    25
```
```    26 lemma [code, code_unfold]:
```
```    27   "case_nat = (\<lambda>f g n. if n = 0 then f else g (n - 1))"
```
```    28   by (auto simp add: fun_eq_iff dest!: gr0_implies_Suc)
```
```    29
```
```    30
```
```    31 subsection {* Preprocessors *}
```
```    32
```
```    33 text {*
```
```    34   The term @{term "Suc n"} is no longer a valid pattern.  Therefore,
```
```    35   all occurrences of this term in a position where a pattern is
```
```    36   expected (i.e.~on the left-hand side of a code equation) must be
```
```    37   eliminated.  This can be accomplished -- as far as possible -- by
```
```    38   applying the following transformation rule:
```
```    39 *}
```
```    40
```
```    41 lemma Suc_if_eq:
```
```    42   assumes "\<And>n. f (Suc n) \<equiv> h n"
```
```    43   assumes "f 0 \<equiv> g"
```
```    44   shows "f n \<equiv> if n = 0 then g else h (n - 1)"
```
```    45   by (rule eq_reflection) (cases n, insert assms, simp_all)
```
```    46
```
```    47 text {*
```
```    48   The rule above is built into a preprocessor that is plugged into
```
```    49   the code generator.
```
```    50 *}
```
```    51
```
```    52 setup {*
```
```    53 let
```
```    54
```
```    55 fun remove_suc ctxt thms =
```
```    56   let
```
```    57     val thy = Proof_Context.theory_of ctxt;
```
```    58     val vname = singleton (Name.variant_list (map fst
```
```    59       (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
```
```    60     val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
```
```    61     val lhs_of = snd o Thm.dest_comb o fst o Thm.dest_comb o cprop_of;
```
```    62     val rhs_of = snd o Thm.dest_comb o cprop_of;
```
```    63     fun find_vars ct = (case term_of ct of
```
```    64         (Const (@{const_name Suc}, _) \$ Var _) => [(cv, snd (Thm.dest_comb ct))]
```
```    65       | _ \$ _ =>
```
```    66         let val (ct1, ct2) = Thm.dest_comb ct
```
```    67         in
```
```    68           map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
```
```    69           map (apfst (Thm.apply ct1)) (find_vars ct2)
```
```    70         end
```
```    71       | _ => []);
```
```    72     val eqs = maps
```
```    73       (fn thm => map (pair thm) (find_vars (lhs_of thm))) thms;
```
```    74     fun mk_thms (thm, (ct, cv')) =
```
```    75       let
```
```    76         val thm' =
```
```    77           Thm.implies_elim
```
```    78            (Conv.fconv_rule (Thm.beta_conversion true)
```
```    79              (Drule.instantiate'
```
```    80                [SOME (ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
```
```    81                  SOME (Thm.lambda cv' (rhs_of thm)), NONE, SOME cv']
```
```    82                @{thm Suc_if_eq})) (Thm.forall_intr cv' thm)
```
```    83       in
```
```    84         case map_filter (fn thm'' =>
```
```    85             SOME (thm'', singleton
```
```    86               (Variable.trade (K (fn [thm'''] => [thm''' RS thm']))
```
```    87                 (Variable.global_thm_context thm'')) thm'')
```
```    88           handle THM _ => NONE) thms of
```
```    89             [] => NONE
```
```    90           | thmps =>
```
```    91               let val (thms1, thms2) = split_list thmps
```
```    92               in SOME (subtract Thm.eq_thm (thm :: thms1) thms @ thms2) end
```
```    93       end
```
```    94   in get_first mk_thms eqs end;
```
```    95
```
```    96 fun eqn_suc_base_preproc thy thms =
```
```    97   let
```
```    98     val dest = fst o Logic.dest_equals o prop_of;
```
```    99     val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
```
```   100   in
```
```   101     if forall (can dest) thms andalso exists (contains_suc o dest) thms
```
```   102       then thms |> perhaps_loop (remove_suc thy) |> (Option.map o map) Drule.zero_var_indexes
```
```   103        else NONE
```
```   104   end;
```
```   105
```
```   106 val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
```
```   107
```
```   108 in
```
```   109
```
```   110   Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
```
```   111
```
```   112 end;
```
```   113 *}
```
```   114
```
```   115 end
```