src/HOL/Library/bnf_lfp_countable.ML
author wenzelm
Wed Oct 08 17:09:07 2014 +0200 (2014-10-08)
changeset 58634 9f10d82e8188
parent 58461 75ee8d49c724
child 59498 50b60f501b05
permissions -rw-r--r--
added parameterized ML antiquotations @{map N}, @{fold N}, @{fold_map N}, @{split_list N};
blanchet@58160
     1
(*  Title:      HOL/Library/bnf_lfp_countable.ML
blanchet@58160
     2
    Author:     Jasmin Blanchette, TU Muenchen
blanchet@58160
     3
    Copyright   2014
blanchet@58160
     4
blanchet@58160
     5
Countability tactic for BNF datatypes.
blanchet@58160
     6
*)
blanchet@58160
     7
blanchet@58160
     8
signature BNF_LFP_COUNTABLE =
blanchet@58160
     9
sig
blanchet@58165
    10
  val derive_encode_injectives_thms: Proof.context -> string list -> thm list
blanchet@58161
    11
  val countable_datatype_tac: Proof.context -> tactic
blanchet@58160
    12
end;
blanchet@58160
    13
blanchet@58160
    14
structure BNF_LFP_Countable : BNF_LFP_COUNTABLE =
blanchet@58160
    15
struct
blanchet@58160
    16
blanchet@58160
    17
open BNF_FP_Rec_Sugar_Util
blanchet@58160
    18
open BNF_Def
blanchet@58160
    19
open BNF_Util
blanchet@58160
    20
open BNF_Tactics
blanchet@58160
    21
open BNF_FP_Util
blanchet@58160
    22
open BNF_FP_Def_Sugar
blanchet@58160
    23
blanchet@58174
    24
val countableS = @{sort countable};
blanchet@58174
    25
blanchet@58160
    26
fun nchotomy_tac nchotomy =
blanchet@58160
    27
  HEADGOAL (rtac (nchotomy RS @{thm all_reg[rotated]}) THEN'
blanchet@58168
    28
    REPEAT_ALL_NEW (resolve_tac [allI, impI] ORELSE' eresolve_tac [exE, disjE]));
blanchet@58160
    29
blanchet@58160
    30
fun meta_spec_mp_tac 0 = K all_tac
blanchet@58165
    31
  | meta_spec_mp_tac depth =
blanchet@58165
    32
    dtac meta_spec THEN' meta_spec_mp_tac (depth - 1) THEN' dtac meta_mp THEN' atac;
blanchet@58160
    33
blanchet@58160
    34
val use_induction_hypothesis_tac =
blanchet@58161
    35
  DEEPEN (1, 64 (* large number *))
blanchet@58160
    36
    (fn depth => meta_spec_mp_tac depth THEN' etac allE THEN' etac impE THEN' atac THEN' atac) 0;
blanchet@58160
    37
blanchet@58172
    38
val same_ctr_simps = @{thms sum_encode_eq prod_encode_eq sum.inject prod.inject to_nat_split
blanchet@58172
    39
  id_apply snd_conv simp_thms};
blanchet@58166
    40
val distinct_ctrs_simps = @{thms sum_encode_eq sum.inject sum.distinct simp_thms};
blanchet@58160
    41
blanchet@58166
    42
fun same_ctr_tac ctxt injects recs map_congs' inj_map_strongs' =
blanchet@58166
    43
  HEADGOAL (asm_full_simp_tac
blanchet@58166
    44
      (ss_only (injects @ recs @ map_congs' @ same_ctr_simps) ctxt) THEN_MAYBE'
blanchet@58166
    45
    TRY o REPEAT_ALL_NEW (rtac conjI) THEN_ALL_NEW
blanchet@58166
    46
    REPEAT_ALL_NEW (eresolve_tac (conjE :: inj_map_strongs')) THEN_ALL_NEW
blanchet@58172
    47
    (atac ORELSE' use_induction_hypothesis_tac));
blanchet@58160
    48
blanchet@58160
    49
fun distinct_ctrs_tac ctxt recs =
blanchet@58166
    50
  HEADGOAL (asm_full_simp_tac (ss_only (recs @ distinct_ctrs_simps) ctxt));
blanchet@58160
    51
blanchet@58160
    52
fun mk_encode_injective_tac ctxt n nchotomy injects recs map_comps' inj_map_strongs' =
blanchet@58160
    53
  let val ks = 1 upto n in
blanchet@58160
    54
    EVERY (maps (fn k => nchotomy_tac nchotomy :: map (fn k' =>
blanchet@58160
    55
      if k = k' then same_ctr_tac ctxt injects recs map_comps' inj_map_strongs'
blanchet@58160
    56
      else distinct_ctrs_tac ctxt recs) ks) ks)
blanchet@58160
    57
  end;
blanchet@58160
    58
blanchet@58160
    59
fun mk_encode_injectives_tac ctxt ns induct nchotomys injectss recss map_comps' inj_map_strongs' =
blanchet@58160
    60
  HEADGOAL (rtac induct) THEN
wenzelm@58634
    61
  EVERY (@{map 4} (fn n => fn nchotomy => fn injects => fn recs =>
blanchet@58160
    62
      mk_encode_injective_tac ctxt n nchotomy injects recs map_comps' inj_map_strongs')
blanchet@58160
    63
    ns nchotomys injectss recss);
blanchet@58160
    64
blanchet@58160
    65
fun endgame_tac ctxt encode_injectives =
blanchet@58160
    66
  unfold_thms_tac ctxt @{thms inj_on_def ball_UNIV} THEN
blanchet@58160
    67
  ALLGOALS (rtac exI THEN' rtac allI THEN' resolve_tac encode_injectives);
blanchet@58160
    68
blanchet@58160
    69
fun encode_sumN n k t =
blanchet@58160
    70
  Balanced_Tree.access {init = t,
blanchet@58160
    71
      left = fn t => @{const sum_encode} $ (@{const Inl (nat, nat)} $ t),
blanchet@58160
    72
      right = fn t => @{const sum_encode} $ (@{const Inr (nat, nat)} $ t)}
blanchet@58160
    73
    n k;
blanchet@58160
    74
blanchet@58160
    75
fun encode_tuple [] = @{term "0 :: nat"}
blanchet@58160
    76
  | encode_tuple ts =
blanchet@58160
    77
    Balanced_Tree.make (fn (t, u) => @{const prod_encode} $ (@{const Pair (nat, nat)} $ u $ t)) ts;
blanchet@58160
    78
blanchet@58160
    79
fun mk_encode_funs ctxt fpTs ns ctrss0 recs0 =
blanchet@58160
    80
  let
blanchet@58160
    81
    val thy = Proof_Context.theory_of ctxt;
blanchet@58160
    82
blanchet@58174
    83
    fun check_countable T =
blanchet@58174
    84
      Sign.of_sort thy (T, countableS) orelse
blanchet@58174
    85
      raise TYPE ("Type is not of sort " ^ Syntax.string_of_sort ctxt countableS, [T], []);
blanchet@58174
    86
blanchet@58174
    87
    fun mk_to_nat_checked T =
blanchet@58174
    88
      Const (@{const_name to_nat}, tap check_countable T --> HOLogic.natT);
blanchet@58174
    89
blanchet@58160
    90
    val nn = length ns;
blanchet@58221
    91
    val recs as rec1 :: _ = map2 (mk_co_rec thy Least_FP (replicate nn HOLogic.natT)) fpTs recs0;
blanchet@58160
    92
    val arg_Ts = binder_fun_types (fastype_of rec1);
blanchet@58160
    93
    val arg_Tss = Library.unflat ctrss0 arg_Ts;
blanchet@58160
    94
blanchet@58160
    95
    fun mk_U (Type (@{type_name prod}, [T1, T2])) =
blanchet@58160
    96
        if member (op =) fpTs T1 then T2 else HOLogic.mk_prodT (mk_U T1, mk_U T2)
blanchet@58160
    97
      | mk_U (Type (s, Ts)) = Type (s, map mk_U Ts)
blanchet@58160
    98
      | mk_U T = T;
blanchet@58160
    99
blanchet@58160
   100
    fun mk_nat (j, T) =
blanchet@58160
   101
      if T = HOLogic.natT then
blanchet@58160
   102
        SOME (Bound j)
blanchet@58160
   103
      else if member (op =) fpTs T then
blanchet@58160
   104
        NONE
blanchet@58160
   105
      else if exists_subtype_in fpTs T then
blanchet@58160
   106
        let val U = mk_U T in
blanchet@58174
   107
          SOME (mk_to_nat_checked U $ (build_map ctxt [] (snd_const o fst) (T, U) $ Bound j))
blanchet@58160
   108
        end
blanchet@58160
   109
      else
blanchet@58174
   110
        SOME (mk_to_nat_checked T $ Bound j);
blanchet@58160
   111
blanchet@58160
   112
    fun mk_arg n (k, arg_T) =
blanchet@58160
   113
      let
blanchet@58160
   114
        val bound_Ts = rev (binder_types arg_T);
blanchet@58160
   115
        val nats = map_filter mk_nat (tag_list 0 bound_Ts);
blanchet@58160
   116
      in
blanchet@58160
   117
        fold (fn T => fn t => Abs (Name.uu, T, t)) bound_Ts (encode_sumN n k (encode_tuple nats))
blanchet@58160
   118
      end;
blanchet@58160
   119
blanchet@58160
   120
    val argss = map2 (map o mk_arg) ns (map (tag_list 1) arg_Tss);
blanchet@58160
   121
  in
blanchet@58160
   122
    map (fn recx => Term.list_comb (recx, flat argss)) recs
blanchet@58160
   123
  end;
blanchet@58160
   124
blanchet@58165
   125
fun derive_encode_injectives_thms _ [] = []
blanchet@58165
   126
  | derive_encode_injectives_thms ctxt fpT_names0 =
blanchet@58160
   127
    let
blanchet@58315
   128
      fun not_datatype s = error (quote s ^ " is not a datatype");
blanchet@58315
   129
      fun not_mutually_recursive ss = error (commas ss ^ " are not mutually recursive datatypes");
blanchet@58160
   130
blanchet@58160
   131
      fun lfp_sugar_of s =
blanchet@58160
   132
        (case fp_sugar_of ctxt s of
blanchet@58160
   133
          SOME (fp_sugar as {fp = Least_FP, ...}) => fp_sugar
blanchet@58160
   134
        | _ => not_datatype s);
blanchet@58160
   135
blanchet@58232
   136
      val fpTs0 as Type (_, var_As) :: _ =
blanchet@58232
   137
        map (#T o lfp_sugar_of o fst o dest_Type) (#Ts (#fp_res (lfp_sugar_of (hd fpT_names0))));
blanchet@58160
   138
      val fpT_names = map (fst o dest_Type) fpTs0;
blanchet@58160
   139
blanchet@58160
   140
      val (As_names, _) = Variable.variant_fixes (map (fn TVar ((s, _), _) => s) var_As) ctxt;
blanchet@58160
   141
      val As =
blanchet@58174
   142
        map2 (fn s => fn TVar (_, S) => TFree (s, union (op =) countableS S))
blanchet@58160
   143
          As_names var_As;
blanchet@58160
   144
      val fpTs = map (fn s => Type (s, As)) fpT_names;
blanchet@58160
   145
blanchet@58160
   146
      val _ = subset (op =) (fpT_names0, fpT_names) orelse not_mutually_recursive fpT_names0;
blanchet@58160
   147
blanchet@58160
   148
      fun mk_conjunct fpT x encode_fun =
blanchet@58160
   149
        HOLogic.all_const fpT $ Abs (Name.uu, fpT,
blanchet@58160
   150
          HOLogic.mk_imp (HOLogic.mk_eq (encode_fun $ x, encode_fun $ Bound 0),
blanchet@58160
   151
            HOLogic.eq_const fpT $ x $ Bound 0));
blanchet@58160
   152
desharna@58461
   153
      val fp_sugars as
desharna@58461
   154
          {fp_nesting_bnfs, fp_co_induct_sugar = {common_co_inducts = induct :: _, ...}, ...} :: _ =
blanchet@58160
   155
        map (the o fp_sugar_of ctxt o fst o dest_Type) fpTs0;
desharna@58460
   156
      val ctr_sugars = map (#ctr_sugar o #fp_ctr_sugar) fp_sugars;
blanchet@58160
   157
blanchet@58160
   158
      val ctrss0 = map #ctrs ctr_sugars;
blanchet@58160
   159
      val ns = map length ctrss0;
desharna@58461
   160
      val recs0 = map (#co_rec o #fp_co_induct_sugar) fp_sugars;
blanchet@58160
   161
      val nchotomys = map #nchotomy ctr_sugars;
blanchet@58160
   162
      val injectss = map #injects ctr_sugars;
desharna@58459
   163
      val rec_thmss = map (#co_rec_thms o #fp_co_induct_sugar) fp_sugars;
blanchet@58160
   164
      val map_comps' = map (unfold_thms ctxt @{thms comp_def} o map_comp_of_bnf) fp_nesting_bnfs;
blanchet@58160
   165
      val inj_map_strongs' = map (Thm.permute_prems 0 ~1 o inj_map_strong_of_bnf) fp_nesting_bnfs;
blanchet@58160
   166
blanchet@58160
   167
      val (xs, names_ctxt) = ctxt |> mk_Frees "x" fpTs;
blanchet@58160
   168
wenzelm@58634
   169
      val conjuncts = @{map 3} mk_conjunct fpTs xs (mk_encode_funs ctxt fpTs ns ctrss0 recs0);
blanchet@58170
   170
      val goal = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj conjuncts);
blanchet@58160
   171
    in
blanchet@58296
   172
      Goal.prove (*no sorry*) ctxt [] [] goal (fn {context = ctxt, prems = _} =>
blanchet@58160
   173
        mk_encode_injectives_tac ctxt ns induct nchotomys injectss rec_thmss map_comps'
blanchet@58161
   174
          inj_map_strongs')
blanchet@58160
   175
      |> HOLogic.conj_elims
blanchet@58160
   176
      |> Proof_Context.export names_ctxt ctxt
blanchet@58160
   177
      |> map Thm.close_derivation
blanchet@58160
   178
    end;
blanchet@58160
   179
blanchet@58165
   180
fun get_countable_goal_type_name (@{const Trueprop} $ (Const (@{const_name Ex}, _)
blanchet@58160
   181
    $ Abs (_, Type (_, [Type (s, _), _]), Const (@{const_name inj_on}, _) $ Bound 0
blanchet@58160
   182
        $ Const (@{const_name top}, _)))) = s
blanchet@58165
   183
  | get_countable_goal_type_name _ = error "Wrong goal format for datatype countability tactic";
blanchet@58160
   184
blanchet@58161
   185
fun core_countable_datatype_tac ctxt st =
blanchet@58165
   186
  let val T_names = map get_countable_goal_type_name (Thm.prems_of st) in
blanchet@58165
   187
    endgame_tac ctxt (derive_encode_injectives_thms ctxt T_names) st
blanchet@58165
   188
  end;
blanchet@58160
   189
blanchet@58161
   190
fun countable_datatype_tac ctxt =
blanchet@58161
   191
  TRY (Class.intro_classes_tac []) THEN core_countable_datatype_tac ctxt;
blanchet@58160
   192
blanchet@58160
   193
end;