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