src/HOL/datatype.ML
author paulson
Thu Jan 08 18:10:34 1998 +0100 (1998-01-08)
changeset 4537 4e835bd9fada
parent 4448 b587d40ad474
child 4545 4eadc8c2681b
permissions -rw-r--r--
Expressed most Oops rules using Notes instead of Says, and other tidying
clasohm@923
     1
(* Title:       HOL/datatype.ML
clasohm@923
     2
   ID:          $Id$
clasohm@1668
     3
   Author:      Max Breitling, Carsten Clasohm, Tobias Nipkow, Norbert Voelker,
clasohm@1668
     4
                Konrad Slind
clasohm@923
     5
   Copyright 1995 TU Muenchen
clasohm@923
     6
*)
clasohm@923
     7
wenzelm@4107
     8
wenzelm@4107
     9
(** theory information about datatypes **)
berghofe@3615
    10
wenzelm@4107
    11
fun datatype_info_sg sg name =
wenzelm@4107
    12
  (case Symtab.lookup (ThyData.get_datatypes_sg sg, name) of
wenzelm@4107
    13
    Some info => info
wenzelm@4107
    14
  | None => error ("Unknown datatype " ^ quote name));
berghofe@3615
    15
wenzelm@4107
    16
val datatype_info = datatype_info_sg o sign_of;
berghofe@3615
    17
wenzelm@4107
    18
fun match_info thy name =
wenzelm@4107
    19
  let val {case_const, constructors, ...} = datatype_info thy name in
wenzelm@4107
    20
    {case_const = case_const, constructors = constructors}
wenzelm@4107
    21
  end;
berghofe@3615
    22
wenzelm@4107
    23
fun induct_info thy name =
wenzelm@4107
    24
  let val {constructors, nchotomy, ...} = datatype_info thy name in
wenzelm@4107
    25
    {constructors = constructors, nchotomy = nchotomy}
wenzelm@4107
    26
  end;
wenzelm@4107
    27
wenzelm@4107
    28
(*retrieve information for all datatypes defined in a theory*)
berghofe@3615
    29
fun extract_info thy =
wenzelm@4107
    30
  let
wenzelm@4107
    31
    val infos = map snd (Symtab.dest (ThyData.get_datatypes thy));
wenzelm@4107
    32
    val (congs, rewrites) = (map #case_cong infos, flat (map #case_rewrites infos));
berghofe@3615
    33
  in {case_congs = congs, case_rewrites = rewrites} end;
berghofe@3615
    34
wenzelm@4107
    35
berghofe@3615
    36
local
berghofe@3615
    37
berghofe@3615
    38
fun find_tname var Bi =
berghofe@3615
    39
  let val frees = map dest_Free (term_frees Bi)
berghofe@3615
    40
      val params = Logic.strip_params Bi;
berghofe@3615
    41
  in case assoc (frees@params, var) of
berghofe@3615
    42
       None => error("No such variable in subgoal: " ^ quote var)
berghofe@3615
    43
     | Some(Type(tn,_)) => tn
berghofe@3615
    44
     | _ => error("Cannot induct on type of " ^ quote var)
berghofe@3615
    45
  end;
berghofe@3615
    46
berghofe@3615
    47
fun infer_tname state sign i aterm =
berghofe@3615
    48
let val (_, _, Bi, _) = dest_state (state, i)
berghofe@3615
    49
    val params = Logic.strip_params Bi	        (*params of subgoal i*)
berghofe@3615
    50
    val params = rev(rename_wrt_term Bi params) (*as they are printed*)
berghofe@3615
    51
    val (types,sorts) = types_sorts state
berghofe@3615
    52
    fun types'(a,~1) = (case assoc(params,a) of None => types(a,~1) | sm => sm)
berghofe@3615
    53
      | types'(ixn) = types ixn;
berghofe@3615
    54
    val (ct,_) = read_def_cterm (sign,types',sorts) [] false
berghofe@3615
    55
                                (aterm,TVar(("",0),[]));
berghofe@3615
    56
in case #T(rep_cterm ct) of
berghofe@3615
    57
     Type(tn,_) => tn
berghofe@3615
    58
   | _ => error("Cannot induct on type of " ^ quote aterm)
berghofe@3615
    59
end;
berghofe@3615
    60
berghofe@3615
    61
in
berghofe@3615
    62
berghofe@3615
    63
(* generic induction tactic for datatypes *)
berghofe@3615
    64
fun induct_tac var i state = state |>
berghofe@3615
    65
        let val (_, _, Bi, _) = dest_state (state, i)
berghofe@3615
    66
            val sign = #sign(rep_thm state)
berghofe@3615
    67
            val tn = find_tname var Bi
wenzelm@4107
    68
            val ind_tac = #induct_tac(datatype_info_sg sign tn)
berghofe@3615
    69
        in ind_tac var i end;
berghofe@3615
    70
berghofe@3615
    71
(* generic exhaustion tactic for datatypes *)
berghofe@3615
    72
fun exhaust_tac aterm i state = state |>
berghofe@3615
    73
        let val sign = #sign(rep_thm state)
berghofe@3615
    74
            val tn = infer_tname state sign i aterm
wenzelm@4107
    75
            val exh_tac = #exhaust_tac(datatype_info_sg sign tn)
berghofe@3615
    76
        in exh_tac aterm i end;
berghofe@3615
    77
berghofe@3615
    78
end;
berghofe@3615
    79
berghofe@3615
    80
nipkow@3292
    81
(* should go into Pure *)
paulson@3538
    82
fun ALLNEWSUBGOALS tac tacf i st0 = st0 |>
paulson@3538
    83
  (tac i THEN
paulson@3538
    84
   (fn st1 => st1 |> 
paulson@3538
    85
        let val d = nprems_of st1 - nprems_of st0
paulson@3538
    86
        in EVERY(map tacf ((i+d) downto i)) end));
clasohm@923
    87
clasohm@923
    88
(*used for constructor parameters*)
clasohm@923
    89
datatype dt_type = dtVar of string |
clasohm@923
    90
  dtTyp of dt_type list * string |
clasohm@923
    91
  dtRek of dt_type list * string;
clasohm@923
    92
clasohm@923
    93
structure Datatype =
clasohm@923
    94
struct
clasohm@923
    95
local 
clasohm@923
    96
clasohm@923
    97
open ThyParse HOLogic;
clasohm@923
    98
exception Impossible;
clasohm@923
    99
exception RecError of string;
clasohm@923
   100
clasohm@923
   101
val is_dtRek = (fn dtRek _ => true  |  _  => false);
clasohm@923
   102
fun opt_parens s = if s = "" then "" else enclose "(" ")" s; 
clasohm@923
   103
clasohm@923
   104
(* ----------------------------------------------------------------------- *)
clasohm@923
   105
(* Derivation of the primrec combinator application from the equations     *)
clasohm@923
   106
clasohm@923
   107
(* substitute fname(ls,xk,rs) by yk(ls,rs) in t for (xk,yk) in pairs  *) 
clasohm@923
   108
clasohm@923
   109
fun subst_apps (_,_) [] t = t
clasohm@923
   110
  | subst_apps (fname,rpos) pairs t =
clasohm@923
   111
    let 
clasohm@923
   112
    fun subst (Abs(a,T,t)) = Abs(a,T,subst t)
clasohm@923
   113
      | subst (funct $ body) = 
clasohm@1465
   114
        let val (f,b) = strip_comb (funct$body)
clasohm@1465
   115
        in 
wenzelm@3945
   116
          if is_Const f andalso Sign.base_name (fst(dest_Const f)) = fname 
clasohm@1465
   117
            then 
clasohm@1465
   118
              let val (ls,rest) = (take(rpos,b), drop(rpos,b));
clasohm@1465
   119
                val (xk,rs) = (hd rest,tl rest)
clasohm@1465
   120
                  handle LIST _ => raise RecError "not enough arguments \
clasohm@1465
   121
                   \ in recursive application on rhs"
clasohm@923
   122
              in 
clasohm@1465
   123
                (case assoc (pairs,xk) of 
clasohm@1574
   124
                   None   => list_comb(f, map subst b)
clasohm@1574
   125
                 | Some U => list_comb(U, map subst (ls @ rs)))
clasohm@1465
   126
              end
clasohm@1465
   127
          else list_comb(f, map subst b)
clasohm@1465
   128
        end
clasohm@923
   129
      | subst(t) = t
clasohm@923
   130
    in subst t end;
clasohm@923
   131
  
clasohm@923
   132
(* abstract rhs *)
clasohm@923
   133
clasohm@923
   134
fun abst_rec (fname,rpos,tc,ls,cargs,rs,rhs) =       
paulson@2270
   135
  let val rargs = (map #1 o 
clasohm@1465
   136
                   (filter (fn (a,T) => is_dtRek T))) (cargs ~~ tc);
clasohm@923
   137
      val subs = map (fn (s,T) => (s,dummyT))
clasohm@1465
   138
                   (rev(rename_wrt_term rhs rargs));
clasohm@923
   139
      val subst_rhs = subst_apps (fname,rpos)
clasohm@1465
   140
                        (map Free rargs ~~ map Free subs) rhs;
clasohm@923
   141
  in 
clasohm@923
   142
      list_abs_free (cargs @ subs @ ls @ rs, subst_rhs) 
clasohm@923
   143
  end;
clasohm@923
   144
clasohm@923
   145
(* parsing the prim rec equations *)
clasohm@923
   146
clasohm@923
   147
fun dest_eq ( Const("Trueprop",_) $ (Const ("op =",_) $ lhs $ rhs))
clasohm@923
   148
                 = (lhs, rhs)
clasohm@923
   149
   | dest_eq _ = raise RecError "not a proper equation"; 
clasohm@923
   150
clasohm@923
   151
fun dest_rec eq = 
clasohm@923
   152
  let val (lhs,rhs) = dest_eq eq; 
clasohm@923
   153
    val (name,args) = strip_comb lhs; 
clasohm@923
   154
    val (ls',rest)  = take_prefix is_Free args; 
clasohm@923
   155
    val (middle,rs') = take_suffix is_Free rest;
clasohm@923
   156
    val rpos = length ls';
clasohm@923
   157
    val (c,cargs') = strip_comb (hd middle)
clasohm@923
   158
      handle LIST "hd" => raise RecError "constructor missing";
clasohm@923
   159
    val (ls,cargs,rs) = (map dest_Free ls', map dest_Free cargs'
clasohm@1465
   160
                         , map dest_Free rs')
clasohm@923
   161
      handle TERM ("dest_Free",_) => 
clasohm@1465
   162
          raise RecError "constructor has illegal argument in pattern";
clasohm@923
   163
  in 
clasohm@923
   164
    if length middle > 1 then 
clasohm@923
   165
      raise RecError "more than one non-variable in pattern"
clasohm@923
   166
    else if not(null(findrep (map fst (ls @ rs @ cargs)))) then 
clasohm@923
   167
      raise RecError "repeated variable name in pattern" 
wenzelm@3945
   168
         else (Sign.base_name (fst(dest_Const name)) handle TERM _ => 
clasohm@1465
   169
               raise RecError "function is not declared as constant in theory"
wenzelm@3945
   170
                 ,rpos,ls, Sign.base_name (fst(dest_Const c)),cargs,rs,rhs)
clasohm@923
   171
  end; 
clasohm@923
   172
clasohm@923
   173
(* check function specified for all constructors and sort function terms *)
clasohm@923
   174
clasohm@923
   175
fun check_and_sort (n,its) = 
clasohm@923
   176
  if length its = n 
wenzelm@4448
   177
    then map snd (Library.sort (make_ord (fn ((i : int,_),(j,_)) => i<j)) its)
clasohm@923
   178
  else raise error "Primrec definition error:\n\
clasohm@923
   179
   \Please give an equation for every constructor";
clasohm@923
   180
clasohm@923
   181
(* translate rec equations into function arguments suitable for rec comb *)
clasohm@923
   182
(* theory parameter needed for printing error messages                   *) 
clasohm@923
   183
clasohm@923
   184
fun trans_recs _ _ [] = error("No primrec equations.")
clasohm@923
   185
  | trans_recs thy cs' (eq1::eqs) = 
clasohm@923
   186
    let val (name1,rpos1,ls1,_,_,_,_) = dest_rec eq1
clasohm@923
   187
      handle RecError s =>
clasohm@1465
   188
        error("Primrec definition error: " ^ s ^ ":\n" 
clasohm@1465
   189
              ^ "   " ^ Sign.string_of_term (sign_of thy) eq1);
clasohm@923
   190
      val tcs = map (fn (_,c,T,_,_) => (c,T)) cs';  
clasohm@923
   191
      val cs = map fst tcs;
clasohm@923
   192
      fun trans_recs' _ [] = []
clasohm@923
   193
        | trans_recs' cis (eq::eqs) = 
clasohm@1465
   194
          let val (name,rpos,ls,c,cargs,rs,rhs) = dest_rec eq; 
clasohm@1465
   195
            val tc = assoc(tcs,c);
oheimb@4188
   196
            val i = 1 + find_index_eq c cs;
clasohm@1465
   197
          in
clasohm@1465
   198
          if name <> name1 then 
clasohm@1465
   199
            raise RecError "function names inconsistent"
clasohm@1465
   200
          else if rpos <> rpos1 then 
clasohm@1465
   201
            raise RecError "position of rec. argument inconsistent"
clasohm@1465
   202
          else if i = 0 then 
clasohm@1465
   203
            raise RecError "illegal argument in pattern" 
clasohm@1465
   204
          else if i mem cis then
clasohm@1465
   205
            raise RecError "constructor already occured as pattern "
clasohm@1465
   206
               else (i,abst_rec (name,rpos,the tc,ls,cargs,rs,rhs))
clasohm@1465
   207
                     :: trans_recs' (i::cis) eqs 
clasohm@1465
   208
          end
clasohm@1465
   209
          handle RecError s =>
clasohm@1465
   210
                error("Primrec definition error\n" ^ s ^ "\n" 
clasohm@1465
   211
                      ^ "   " ^ Sign.string_of_term (sign_of thy) eq);
clasohm@923
   212
    in (  name1, ls1
clasohm@1465
   213
        , check_and_sort (length cs, trans_recs' [] (eq1::eqs)))
clasohm@923
   214
    end ;
clasohm@923
   215
clasohm@923
   216
in
clasohm@923
   217
  fun add_datatype (typevars, tname, cons_list') thy = 
clasohm@923
   218
    let
nipkow@3308
   219
      val dummy = require_thy thy "Arith" "datatype definitions";
nipkow@2880
   220
      
clasohm@923
   221
      fun typid(dtRek(_,id)) = id
clasohm@923
   222
        | typid(dtVar s) = implode (tl (explode s))
clasohm@923
   223
        | typid(dtTyp(_,id)) = id;
clasohm@923
   224
clasohm@923
   225
      fun index_vnames(vn::vns,tab) =
clasohm@923
   226
            (case assoc(tab,vn) of
clasohm@923
   227
               None => if vn mem vns
clasohm@923
   228
                       then (vn^"1") :: index_vnames(vns,(vn,2)::tab)
clasohm@923
   229
                       else vn :: index_vnames(vns,tab)
clasohm@923
   230
             | Some(i) => (vn^(string_of_int i)) ::
clasohm@923
   231
                          index_vnames(vns,(vn,i+1)::tab))
clasohm@923
   232
        | index_vnames([],tab) = [];
clasohm@923
   233
clasohm@923
   234
      fun mk_var_names types = index_vnames(map typid types,[]);
clasohm@923
   235
clasohm@923
   236
      (*search for free type variables and convert recursive *)
clasohm@923
   237
      fun analyse_types (cons, types, syn) =
clasohm@1465
   238
        let fun analyse(t as dtVar v) =
clasohm@923
   239
                  if t mem typevars then t
clasohm@923
   240
                  else error ("Free type variable " ^ v ^ " on rhs.")
clasohm@1465
   241
              | analyse(dtTyp(typl,s)) =
clasohm@1465
   242
                  if tname <> s then dtTyp(analyses typl, s)
clasohm@923
   243
                  else if typevars = typl then dtRek(typl, s)
clasohm@923
   244
                       else error (s ^ " used in different ways")
clasohm@1465
   245
              | analyse(dtRek _) = raise Impossible
clasohm@1465
   246
            and analyses ts = map analyse ts;
clasohm@1465
   247
        in (cons, Syntax.const_name cons syn, analyses types,
clasohm@923
   248
            mk_var_names types, syn)
clasohm@923
   249
        end;
clasohm@923
   250
clasohm@923
   251
     (*test if all elements are recursive, i.e. if the type is empty*)
clasohm@923
   252
      
clasohm@923
   253
      fun non_empty (cs : ('a * 'b * dt_type list * 'c *'d) list) = 
clasohm@1465
   254
        not(forall (exists is_dtRek o #3) cs) orelse
clasohm@1465
   255
        error("Empty datatype not allowed!");
clasohm@923
   256
clasohm@923
   257
      val cons_list = map analyse_types cons_list';
clasohm@923
   258
      val dummy = non_empty cons_list;
clasohm@923
   259
      val num_of_cons = length cons_list;
clasohm@923
   260
clasohm@923
   261
     (* Auxiliary functions to construct argument and equation lists *)
clasohm@923
   262
clasohm@923
   263
     (*generate 'var_n, ..., var_m'*)
clasohm@923
   264
      fun Args(var, delim, n, m) = 
clasohm@1465
   265
        space_implode delim (map (fn n => var^string_of_int(n)) (n upto m));
clasohm@923
   266
clasohm@923
   267
      fun C_exp name vns = name ^ opt_parens(space_implode ") (" vns);
clasohm@923
   268
clasohm@923
   269
     (*Arg_eqs([x1,...,xn],[y1,...,yn]) = "x1 = y1 & ... & xn = yn" *)
clasohm@923
   270
      fun arg_eqs vns vns' =
clasohm@923
   271
        let fun mkeq(x,x') = x ^ "=" ^ x'
paulson@2270
   272
        in space_implode " & " (ListPair.map mkeq (vns,vns')) end;
clasohm@923
   273
clasohm@923
   274
     (*Pretty printers for type lists;
clasohm@923
   275
       pp_typlist1: parentheses, pp_typlist2: brackets*)
nipkow@1279
   276
      fun pp_typ (dtVar s) = "(" ^ s ^ "::term)"
clasohm@923
   277
        | pp_typ (dtTyp (typvars, id)) =
clasohm@1465
   278
          if null typvars then id else (pp_typlist1 typvars) ^ id
clasohm@923
   279
        | pp_typ (dtRek (typvars, id)) = (pp_typlist1 typvars) ^ id
clasohm@923
   280
      and
clasohm@1465
   281
        pp_typlist' ts = commas (map pp_typ ts)
clasohm@923
   282
      and
clasohm@1465
   283
        pp_typlist1 ts = if null ts then "" else parens (pp_typlist' ts);
clasohm@923
   284
clasohm@923
   285
      fun pp_typlist2 ts = if null ts then "" else brackets (pp_typlist' ts);
clasohm@923
   286
clasohm@923
   287
     (* Generate syntax translation for case rules *)
clasohm@923
   288
      fun calc_xrules c_nr y_nr ((_, name, _, vns, _) :: cs) = 
clasohm@1465
   289
        let val arity = length vns;
clasohm@1465
   290
          val body  = "z" ^ string_of_int(c_nr);
clasohm@1465
   291
          val args1 = if arity=0 then ""
clasohm@1465
   292
                      else " " ^ Args ("y", " ", y_nr, y_nr+arity-1);
clasohm@1465
   293
          val args2 = if arity=0 then ""
clasohm@1465
   294
                      else "(% " ^ Args ("y", " ", y_nr, y_nr+arity-1) 
clasohm@1465
   295
                        ^ ". ";
clasohm@1465
   296
          val (rest1,rest2) = 
clasohm@1465
   297
            if null cs then ("","")
clasohm@1465
   298
            else let val (h1, h2) = calc_xrules (c_nr+1) (y_nr+arity) cs
clasohm@1465
   299
            in (" | " ^ h1, " " ^ h2) end;
clasohm@1465
   300
        in (name ^ args1 ^ " => " ^ body ^ rest1,
clasohm@964
   301
            args2 ^ body ^ (if args2 = "" then "" else ")") ^ rest2)
clasohm@923
   302
        end
clasohm@923
   303
        | calc_xrules _ _ [] = raise Impossible;
clasohm@923
   304
      
clasohm@923
   305
      val xrules =
clasohm@1465
   306
        let val (first_part, scnd_part) = calc_xrules 1 1 cons_list
wenzelm@3534
   307
        in [Syntax.ParsePrintRule (("logic", "case x of " ^ first_part),
paulson@2031
   308
                        ("logic", tname ^ "_case " ^ scnd_part ^ " x"))]
clasohm@1465
   309
        end;
clasohm@923
   310
clasohm@923
   311
     (*type declarations for constructors*)
clasohm@923
   312
      fun const_type (id, _, typlist, _, syn) =
clasohm@1465
   313
        (id,  
clasohm@1465
   314
         (if null typlist then "" else pp_typlist2 typlist ^ " => ") ^
clasohm@1465
   315
            pp_typlist1 typevars ^ tname, syn);
clasohm@923
   316
clasohm@923
   317
clasohm@923
   318
      fun assumpt (dtRek _ :: ts, v :: vs ,found) =
clasohm@1465
   319
        let val h = if found then ";P(" ^ v ^ ")" else "[| P(" ^ v ^ ")"
clasohm@1465
   320
        in h ^ (assumpt (ts, vs, true)) end
clasohm@923
   321
        | assumpt (t :: ts, v :: vs, found) = assumpt (ts, vs, found)
clasohm@923
   322
      | assumpt ([], [], found) = if found then "|] ==>" else ""
clasohm@923
   323
        | assumpt _ = raise Impossible;
clasohm@923
   324
clasohm@923
   325
      fun t_inducting ((_, name, types, vns, _) :: cs) =
clasohm@1465
   326
        let
clasohm@1465
   327
          val h = if null types then " P(" ^ name ^ ")"
wenzelm@3842
   328
                  else " !!" ^ (space_implode " " vns) ^ ". " ^
clasohm@1465
   329
                    (assumpt (types, vns, false)) ^
clasohm@923
   330
                    "P(" ^ C_exp name vns ^ ")";
clasohm@1465
   331
          val rest = t_inducting cs;
clasohm@1465
   332
        in if rest = "" then h else h ^ "; " ^ rest end
clasohm@923
   333
        | t_inducting [] = "";
clasohm@923
   334
clasohm@923
   335
      fun t_induct cl typ_name =
clasohm@923
   336
        "[|" ^ t_inducting cl ^ "|] ==> P(" ^ typ_name ^ ")";
clasohm@923
   337
clasohm@923
   338
      fun gen_typlist typevar f ((_, _, ts, _, _) :: cs) =
clasohm@1465
   339
        let val h = if (length ts) > 0
clasohm@1465
   340
                      then pp_typlist2(f ts) ^ "=>"
clasohm@1465
   341
                    else ""
clasohm@1465
   342
        in h ^ typevar ^  "," ^ (gen_typlist typevar f cs) end
clasohm@923
   343
        | gen_typlist _ _ [] = "";
clasohm@923
   344
clasohm@923
   345
clasohm@923
   346
(* -------------------------------------------------------------------- *)
clasohm@1465
   347
(* The case constant and rules                                          *)
clasohm@1465
   348
                
clasohm@923
   349
      val t_case = tname ^ "_case";
clasohm@923
   350
clasohm@923
   351
      fun case_rule n (id, name, _, vns, _) =
clasohm@1465
   352
        let val args = if vns = [] then "" else " " ^ space_implode " " vns
clasohm@1465
   353
        in (t_case ^ "_" ^ id,
clasohm@1465
   354
            t_case ^ " " ^ Args("f", " ", 1, num_of_cons)
clasohm@1465
   355
            ^ " (" ^ name ^ args ^ ") = f"^string_of_int(n) ^ args)
clasohm@1465
   356
        end
clasohm@923
   357
clasohm@923
   358
      fun case_rules n (c :: cs) = case_rule n c :: case_rules(n+1) cs
clasohm@923
   359
        | case_rules _ [] = [];
clasohm@923
   360
clasohm@923
   361
      val datatype_arity = length typevars;
clasohm@923
   362
clasohm@923
   363
      val types = [(tname, datatype_arity, NoSyn)];
clasohm@923
   364
clasohm@923
   365
      val arities = 
clasohm@923
   366
        let val term_list = replicate datatype_arity termS;
clasohm@923
   367
        in [(tname, term_list, termS)] 
clasohm@1465
   368
        end;
clasohm@923
   369
clasohm@923
   370
      val datatype_name = pp_typlist1 typevars ^ tname;
clasohm@923
   371
clasohm@923
   372
      val new_tvar_name = variant (map (fn dtVar s => s) typevars) "'z";
clasohm@923
   373
clasohm@923
   374
      val case_const =
clasohm@1465
   375
        (t_case,
clasohm@1465
   376
         "[" ^ gen_typlist new_tvar_name I cons_list 
clasohm@1465
   377
         ^  pp_typlist1 typevars ^ tname ^ "] =>" ^ new_tvar_name^"::term",
clasohm@1465
   378
         NoSyn);
clasohm@923
   379
clasohm@923
   380
      val rules_case = case_rules 1 cons_list;
clasohm@923
   381
clasohm@923
   382
(* -------------------------------------------------------------------- *)
clasohm@1465
   383
(* The prim-rec combinator                                              *) 
clasohm@923
   384
clasohm@923
   385
      val t_rec = tname ^ "_rec"
clasohm@923
   386
clasohm@923
   387
(* adding type variables for dtRek types to end of list of dt_types      *)   
clasohm@923
   388
clasohm@923
   389
      fun add_reks ts = 
clasohm@1465
   390
        ts @ map (fn _ => dtVar new_tvar_name) (filter is_dtRek ts); 
clasohm@923
   391
clasohm@923
   392
(* positions of the dtRek types in a list of dt_types, starting from 1  *)
paulson@2270
   393
      fun rek_vars ts vns = map #2 (filter (is_dtRek o fst) (ts ~~ vns))
clasohm@923
   394
clasohm@923
   395
      fun rec_rule n (id,name,ts,vns,_) = 
clasohm@1465
   396
        let val args = opt_parens(space_implode ") (" vns)
clasohm@1465
   397
          val fargs = opt_parens(Args("f", ") (", 1, num_of_cons))
clasohm@1465
   398
          fun rarg vn = t_rec ^ fargs ^ " (" ^ vn ^ ")"
clasohm@1465
   399
          val rargs = opt_parens(space_implode ") ("
clasohm@964
   400
                                 (map rarg (rek_vars ts vns)))
clasohm@1465
   401
        in
clasohm@1465
   402
          (t_rec ^ "_" ^ id,
clasohm@1465
   403
           t_rec ^ fargs ^ " (" ^ name ^ args ^ ") = f"
clasohm@1465
   404
           ^ string_of_int(n) ^ args ^ rargs)
clasohm@1465
   405
        end
clasohm@923
   406
clasohm@923
   407
      fun rec_rules n (c::cs) = rec_rule n c :: rec_rules (n+1) cs 
clasohm@1465
   408
        | rec_rules _ [] = [];
clasohm@923
   409
clasohm@923
   410
      val rec_const =
clasohm@1465
   411
        (t_rec,
clasohm@1465
   412
         "[" ^ (gen_typlist new_tvar_name add_reks cons_list) 
clasohm@1465
   413
         ^ (pp_typlist1 typevars) ^ tname ^ "] =>" ^ new_tvar_name^"::term",
clasohm@1465
   414
         NoSyn);
clasohm@923
   415
clasohm@923
   416
      val rules_rec = rec_rules 1 cons_list
clasohm@923
   417
clasohm@923
   418
(* -------------------------------------------------------------------- *)
nipkow@3308
   419
(* The size function                                                    *) 
nipkow@3308
   420
nipkow@3308
   421
      fun size_eqn(_,name,types,vns,_) =
nipkow@3308
   422
        let fun sum((T,vn)::args) =
nipkow@3308
   423
                  if is_dtRek T then "size(" ^ vn ^ ") + " ^ sum(args)
nipkow@3308
   424
                  else sum args
nipkow@3308
   425
              | sum [] = "1"
nipkow@3308
   426
            val rhs = if exists is_dtRek types then sum(types~~vns) else "0"
nipkow@3308
   427
        in ("", "size(" ^ C_exp name vns ^ ") = " ^ rhs) end;
nipkow@3308
   428
nipkow@3308
   429
      val size_eqns  = map size_eqn cons_list;
nipkow@3308
   430
nipkow@3308
   431
(* -------------------------------------------------------------------- *)
nipkow@4032
   432
(* The split equation                                                   *) 
nipkow@4032
   433
nipkow@4032
   434
      local
nipkow@4032
   435
      val fs = map (fn i => "f"^(string_of_int i)) (1 upto num_of_cons);
nipkow@4032
   436
nipkow@4184
   437
      fun split1case concl ((_,name,_,vns,_),fi) =
nipkow@4032
   438
        let val svns = " " ^ (space_implode " " vns);
nipkow@4184
   439
            val quant = if concl then "!" else "?";
nipkow@4184
   440
            val impl = if concl then " --> " else " & ~";
nipkow@4184
   441
            val all = if null vns then "" else quant ^ svns ^ ". "
nipkow@4184
   442
        in "("^all^tname^"0 = "^C_exp name vns^impl^"P("^fi^svns^"))" end;
nipkow@4032
   443
nipkow@4184
   444
      fun rhss concl = map (split1case concl) (cons_list ~~ fs);
nipkow@4184
   445
      fun rhs concl= space_implode(if concl then " & " else " | ")(rhss concl);
nipkow@4032
   446
      val lhs = "P(" ^ t_case ^ " " ^ (space_implode " " fs) ^" "^ tname^"0)"
nipkow@4032
   447
      in
nipkow@4184
   448
      val split_eqn = lhs ^ " = (" ^ rhs true ^ ")"
nipkow@4184
   449
      val split_eqn_prem = lhs ^ " = ( ~ (" ^ rhs false ^ "))"
nipkow@4032
   450
      end;
nipkow@4032
   451
nipkow@4032
   452
(* -------------------------------------------------------------------- *)
nipkow@4032
   453
clasohm@923
   454
      val consts = 
clasohm@1465
   455
        map const_type cons_list
clasohm@1465
   456
        @ (if num_of_cons < dtK then []
clasohm@1465
   457
           else [(tname ^ "_ord", datatype_name ^ "=>nat", NoSyn)])
clasohm@1465
   458
        @ [case_const,rec_const];
clasohm@923
   459
clasohm@923
   460
clasohm@923
   461
      fun Ci_ing ((id, name, _, vns, _) :: cs) =
clasohm@1465
   462
           if null vns then Ci_ing cs
clasohm@1465
   463
           else let val vns' = variantlist(vns,vns)
clasohm@923
   464
                in ("inject_" ^ id,
clasohm@1465
   465
                    "(" ^ (C_exp name vns) ^ "=" ^ (C_exp name vns')
clasohm@1465
   466
                    ^ ") = (" ^ (arg_eqs vns vns') ^ ")") :: (Ci_ing cs)
clasohm@923
   467
                end
clasohm@1465
   468
        | Ci_ing [] = [];
clasohm@923
   469
clasohm@923
   470
      fun Ci_negOne (id1,name1,_,vns1,_) (id2,name2,_,vns2,_) =
clasohm@923
   471
            let val vns2' = variantlist(vns2,vns1)
clasohm@923
   472
                val ax = C_exp name1 vns1 ^ "~=" ^ C_exp name2 vns2'
clasohm@1465
   473
        in (id1 ^ "_not_" ^ id2, ax) end;
clasohm@923
   474
clasohm@923
   475
      fun Ci_neg1 [] = []
clasohm@1465
   476
        | Ci_neg1 (c1::cs) = (map (Ci_negOne c1) cs) @ Ci_neg1 cs;
clasohm@923
   477
clasohm@923
   478
      fun suc_expr n = 
clasohm@1465
   479
        if n=0 then "0" else "Suc(" ^ suc_expr(n-1) ^ ")";
clasohm@923
   480
clasohm@923
   481
      fun Ci_neg2() =
clasohm@1465
   482
        let val ord_t = tname ^ "_ord";
paulson@2270
   483
          val cis = ListPair.zip (cons_list, 0 upto (num_of_cons - 1))
clasohm@1465
   484
          fun Ci_neg2equals ((id, name, _, vns, _), n) =
clasohm@1465
   485
            let val ax = ord_t ^ "(" ^ (C_exp name vns) ^ ") = " ^ (suc_expr n)
clasohm@1465
   486
            in (ord_t ^ "_" ^ id, ax) end
clasohm@1465
   487
        in (ord_t ^ "_distinct", ord_t^"(x) ~= "^ord_t^"(y) ==> x ~= y") ::
clasohm@1465
   488
          (map Ci_neg2equals cis)
clasohm@1465
   489
        end;
clasohm@923
   490
clasohm@923
   491
      val rules_distinct = if num_of_cons < dtK then Ci_neg1 cons_list
clasohm@1465
   492
                           else Ci_neg2();
clasohm@923
   493
clasohm@923
   494
      val rules_inject = Ci_ing cons_list;
clasohm@923
   495
clasohm@923
   496
      val rule_induct = (tname ^ "_induct", t_induct cons_list tname);
clasohm@923
   497
clasohm@923
   498
      val rules = rule_induct ::
clasohm@1465
   499
        (rules_inject @ rules_distinct @ rules_case @ rules_rec);
clasohm@923
   500
clasohm@923
   501
      fun add_primrec eqns thy =
clasohm@1465
   502
        let val rec_comb = Const(t_rec,dummyT)
clasohm@1465
   503
          val teqns = map (fn neq => snd(read_axm (sign_of thy) neq)) eqns
clasohm@1465
   504
          val (fname,ls,fns) = trans_recs thy cons_list teqns
clasohm@1465
   505
          val rhs = 
clasohm@1465
   506
            list_abs_free
clasohm@1465
   507
            (ls @ [(tname,dummyT)]
clasohm@1465
   508
             ,list_comb(rec_comb
clasohm@1465
   509
                        , fns @ map Bound (0 ::(length ls downto 1))));
clasohm@923
   510
          val sg = sign_of thy;
clasohm@1574
   511
          val defpair = (fname ^ "_" ^ tname ^ "_def",
clasohm@1574
   512
                         Logic.mk_equals (Const(fname,dummyT), rhs))
clasohm@1465
   513
          val defpairT as (_, _ $ Const(_,T) $ _ ) = inferT_axm sg defpair;
clasohm@1465
   514
          val varT = Type.varifyT T;
wenzelm@3945
   515
          val ftyp = the (Sign.const_type sg (Sign.intern_const sg fname));
wenzelm@4040
   516
        in PureThy.add_store_defs_i [defpairT] thy end;
clasohm@923
   517
clasohm@1360
   518
    in
wenzelm@3768
   519
      (thy |> Theory.add_types types
wenzelm@3768
   520
           |> Theory.add_arities arities
wenzelm@3768
   521
           |> Theory.add_consts consts
wenzelm@3768
   522
           |> Theory.add_trrules xrules
nipkow@4184
   523
           |> PureThy.add_store_axioms rules,
nipkow@4184
   524
       add_primrec, size_eqns, (split_eqn,split_eqn_prem))
clasohm@923
   525
    end
nipkow@3040
   526
paulson@3564
   527
(*Warn if the (induction) variable occurs Free among the premises, which
paulson@3564
   528
  usually signals a mistake.  But calls the tactic either way!*)
paulson@3564
   529
fun occs_in_prems tacf a = 
paulson@3564
   530
  SUBGOAL (fn (Bi,i) =>
paulson@3564
   531
	   (if  exists (fn Free(a',_) => a=a')
paulson@3564
   532
	              (foldr add_term_frees (#2 (strip_context Bi), []))
paulson@3564
   533
	     then warning "Induction variable occurs also among premises!"
paulson@3564
   534
	     else ();
paulson@3564
   535
	    tacf a i));
nipkow@3040
   536
nipkow@3040
   537
end;
nipkow@3040
   538
nipkow@3040
   539
end;
clasohm@923
   540
clasohm@923
   541
(*
clasohm@923
   542
Informal description of functions used in datatype.ML for the Isabelle/HOL
clasohm@923
   543
implementation of prim. rec. function definitions. (N. Voelker, Feb. 1995) 
clasohm@923
   544
clasohm@923
   545
* subst_apps (fname,rpos) pairs t:
clasohm@923
   546
   substitute the term 
clasohm@923
   547
       fname(ls,xk,rs) 
clasohm@923
   548
   by 
clasohm@923
   549
      yk(ls,rs) 
clasohm@923
   550
   in t for (xk,yk) in pairs, where rpos = length ls. 
clasohm@923
   551
   Applied with : 
clasohm@923
   552
     fname = function name 
clasohm@923
   553
     rpos = position of recursive argument 
clasohm@923
   554
     pairs = list of pairs (xk,yk), where 
clasohm@923
   555
          xk are the rec. arguments of the constructor in the pattern,
clasohm@923
   556
          yk is a variable with name derived from xk 
clasohm@923
   557
     t = rhs of equation 
clasohm@923
   558
clasohm@923
   559
* abst_rec (fname,rpos,tc,ls,cargs,rs,rhs)
clasohm@923
   560
  - filter recursive arguments from constructor arguments cargs,
clasohm@923
   561
  - perform substitutions on rhs, 
clasohm@923
   562
  - derive list subs of new variable names yk for use in subst_apps, 
clasohm@923
   563
  - abstract rhs with respect to cargs, subs, ls and rs. 
clasohm@923
   564
clasohm@923
   565
* dest_eq t 
clasohm@923
   566
  destruct a term denoting an equation into lhs and rhs. 
clasohm@923
   567
clasohm@923
   568
* dest_req eq 
clasohm@923
   569
  destruct an equation of the form 
clasohm@923
   570
      name (vl1..vlrpos, Ci(vi1..vin), vr1..vrn) = rhs
clasohm@923
   571
  into 
clasohm@923
   572
  - function name  (name) 
clasohm@923
   573
  - position of the first non-variable parameter  (rpos)
clasohm@923
   574
  - the list of first rpos parameters (ls = [vl1..vlrpos]) 
clasohm@923
   575
  - the constructor (fst( dest_Const c) = Ci)
clasohm@923
   576
  - the arguments of the constructor (cargs = [vi1..vin])
clasohm@923
   577
  - the rest of the variables in the pattern (rs = [vr1..vrn])
clasohm@923
   578
  - the right hand side of the equation (rhs).  
clasohm@923
   579
 
clasohm@923
   580
* check_and_sort (n,its)
clasohm@923
   581
  check that  n = length its holds, and sort elements of its by 
clasohm@923
   582
  first component. 
clasohm@923
   583
clasohm@923
   584
* trans_recs thy cs' (eq1::eqs)
clasohm@923
   585
  destruct eq1 into name1, rpos1, ls1, etc.. 
clasohm@923
   586
  get constructor list with and without type (tcs resp. cs) from cs',  
clasohm@923
   587
  for every equation:  
clasohm@923
   588
    destruct it into (name,rpos,ls,c,cargs,rs,rhs)
clasohm@923
   589
    get typed constructor tc from c and tcs 
clasohm@923
   590
    determine the index i of the constructor 
clasohm@923
   591
    check function name and position of rec. argument by comparison
clasohm@923
   592
    with first equation 
clasohm@923
   593
    check for repeated variable names in pattern
clasohm@923
   594
    derive function term f_i which is used as argument of the rec. combinator
clasohm@923
   595
    sort the terms f_i according to i and return them together
clasohm@923
   596
      with the function name and the parameter of the definition (ls). 
clasohm@923
   597
clasohm@923
   598
* Application:
clasohm@923
   599
clasohm@923
   600
  The rec. combinator is applied to the function terms resulting from
clasohm@923
   601
  trans_rec. This results in a function which takes the recursive arg. 
clasohm@923
   602
  as first parameter and then the arguments corresponding to ls. The
clasohm@923
   603
  order of parameters is corrected by setting the rhs equal to 
clasohm@923
   604
clasohm@923
   605
  list_abs_free
clasohm@1465
   606
            (ls @ [(tname,dummyT)]
clasohm@1465
   607
             ,list_comb(rec_comb
clasohm@1465
   608
                        , fns @ map Bound (0 ::(length ls downto 1))));
clasohm@923
   609
clasohm@923
   610
  Note the de-Bruijn indices counting the number of lambdas between the
clasohm@923
   611
  variable and its binding. 
clasohm@923
   612
*)
clasohm@1668
   613
clasohm@1668
   614
clasohm@1668
   615
clasohm@1668
   616
(* ----------------------------------------------- *)
clasohm@1668
   617
(* The following has been written by Konrad Slind. *)
clasohm@1668
   618
clasohm@1668
   619
nipkow@3040
   620
(* type dtype_info is defined in simpdata.ML *)
clasohm@1668
   621
clasohm@1668
   622
signature Dtype_sig =
clasohm@1668
   623
sig
clasohm@1668
   624
  val build_case_cong: Sign.sg -> thm list -> cterm
clasohm@1668
   625
  val build_nchotomy: Sign.sg -> thm list -> cterm
clasohm@1668
   626
clasohm@1668
   627
  val prove_case_cong: thm -> thm list -> cterm -> thm
clasohm@1690
   628
  val prove_nchotomy: (string -> int -> tactic) -> cterm -> thm
clasohm@1668
   629
clasohm@1668
   630
  val case_thms : Sign.sg -> thm list -> (string -> int -> tactic)
clasohm@1668
   631
                   -> {nchotomy:thm, case_cong:thm}
clasohm@1668
   632
wenzelm@4107
   633
  val build_record: theory * (string * string list) * (string -> int -> tactic)
wenzelm@4107
   634
    -> string * datatype_info
wenzelm@4107
   635
  val add_record: string * string list * (string -> int -> tactic) -> theory -> theory
wenzelm@4107
   636
  val add_datatype_info: string * datatype_info -> theory -> theory
clasohm@1668
   637
end;
clasohm@1668
   638
clasohm@1668
   639
clasohm@1668
   640
(*---------------------------------------------------------------------------
clasohm@1668
   641
 * This structure is support for the Isabelle datatype package. It provides
clasohm@1668
   642
 * entrypoints for 1) building and proving the case congruence theorem for
clasohm@1668
   643
 * a datatype and 2) building and proving the "exhaustion" theorem for
clasohm@1668
   644
 * a datatype (I have called this theorem "nchotomy" for no good reason).
clasohm@1668
   645
 *
clasohm@1668
   646
 * It also brings all these together in the function "build_record", which
clasohm@1668
   647
 * is probably what will be used.
clasohm@1668
   648
 *
clasohm@1668
   649
 * Since these routines are required in order to support TFL, they have
clasohm@1668
   650
 * been written so they will compile "stand-alone", i.e., in Isabelle-HOL
clasohm@1668
   651
 * without any TFL code around.
clasohm@1668
   652
 *---------------------------------------------------------------------------*)
clasohm@1668
   653
structure Dtype : Dtype_sig =
clasohm@1668
   654
struct
clasohm@1668
   655
clasohm@1668
   656
exception DTYPE_ERR of {func:string, mesg:string};
clasohm@1668
   657
clasohm@1668
   658
(*---------------------------------------------------------------------------
clasohm@1668
   659
 * General support routines
clasohm@1668
   660
 *---------------------------------------------------------------------------*)
clasohm@1668
   661
fun itlist f L base_value =
clasohm@1668
   662
   let fun it [] = base_value
clasohm@1668
   663
         | it (a::rst) = f a (it rst)
clasohm@1668
   664
   in it L 
clasohm@1668
   665
   end;
clasohm@1668
   666
clasohm@1668
   667
fun end_itlist f =
clasohm@1668
   668
let fun endit [] = raise DTYPE_ERR{func="end_itlist", mesg="list too short"}
clasohm@1668
   669
      | endit alist = 
clasohm@1668
   670
         let val (base::ralist) = rev alist
clasohm@1668
   671
         in itlist f (rev ralist) base  end
clasohm@1668
   672
in endit
clasohm@1668
   673
end;
clasohm@1668
   674
clasohm@1668
   675
fun unzip L = itlist (fn (x,y) => fn (l1,l2) =>((x::l1),(y::l2))) L ([],[]);
clasohm@1668
   676
clasohm@1668
   677
clasohm@1668
   678
(*---------------------------------------------------------------------------
clasohm@1668
   679
 * Miscellaneous Syntax manipulation
clasohm@1668
   680
 *---------------------------------------------------------------------------*)
clasohm@1668
   681
val mk_var = Free;
clasohm@1668
   682
val mk_const = Const
clasohm@1668
   683
fun mk_comb(Rator,Rand) = Rator $ Rand;
clasohm@1668
   684
fun mk_abs(r as (Var((s,_),ty),_))  = Abs(s,ty,abstract_over r)
clasohm@1668
   685
  | mk_abs(r as (Free(s,ty),_))     = Abs(s,ty,abstract_over r)
clasohm@1668
   686
  | mk_abs _ = raise DTYPE_ERR{func="mk_abs", mesg="1st not a variable"};
clasohm@1668
   687
clasohm@1668
   688
fun dest_var(Var((s,i),ty)) = (s,ty)
clasohm@1668
   689
  | dest_var(Free(s,ty))    = (s,ty)
clasohm@1668
   690
  | dest_var _ = raise DTYPE_ERR{func="dest_var", mesg="not a variable"};
clasohm@1668
   691
clasohm@1668
   692
fun dest_const(Const p) = p
clasohm@1668
   693
  | dest_const _ = raise DTYPE_ERR{func="dest_const", mesg="not a constant"};
clasohm@1668
   694
clasohm@1668
   695
fun dest_comb(t1 $ t2) = (t1,t2)
clasohm@1668
   696
  | dest_comb _ =  raise DTYPE_ERR{func = "dest_comb", mesg = "not a comb"};
clasohm@1668
   697
val rand = #2 o dest_comb;
clasohm@1668
   698
val rator = #1 o dest_comb;
clasohm@1668
   699
clasohm@1668
   700
fun dest_abs(a as Abs(s,ty,M)) = 
clasohm@1668
   701
     let val v = Free(s, ty)
clasohm@1668
   702
      in (v, betapply (a,v)) end
clasohm@1668
   703
  | dest_abs _ =  raise DTYPE_ERR{func="dest_abs", mesg="not an abstraction"};
clasohm@1668
   704
clasohm@1668
   705
clasohm@1668
   706
val bool = Type("bool",[])
clasohm@1668
   707
and prop = Type("prop",[]);
clasohm@1668
   708
clasohm@1668
   709
fun mk_eq(lhs,rhs) = 
clasohm@1668
   710
   let val ty = type_of lhs
clasohm@1668
   711
       val c = mk_const("op =", ty --> ty --> bool)
clasohm@1668
   712
   in list_comb(c,[lhs,rhs])
clasohm@1668
   713
   end
clasohm@1668
   714
clasohm@1668
   715
fun dest_eq(Const("op =",_) $ M $ N) = (M, N)
clasohm@1668
   716
  | dest_eq _ = raise DTYPE_ERR{func="dest_eq", mesg="not an equality"};
clasohm@1668
   717
clasohm@1668
   718
fun mk_disj(disj1,disj2) =
clasohm@1668
   719
   let val c = Const("op |", bool --> bool --> bool)
clasohm@1668
   720
   in list_comb(c,[disj1,disj2])
clasohm@1668
   721
   end;
clasohm@1668
   722
clasohm@1668
   723
fun mk_forall (r as (Bvar,_)) = 
clasohm@1668
   724
  let val ty = type_of Bvar
clasohm@1668
   725
      val c = Const("All", (ty --> bool) --> bool)
clasohm@1668
   726
  in mk_comb(c, mk_abs r)
clasohm@1668
   727
  end;
clasohm@1668
   728
clasohm@1668
   729
fun mk_exists (r as (Bvar,_)) = 
clasohm@1668
   730
  let val ty = type_of Bvar 
clasohm@1668
   731
      val c = Const("Ex", (ty --> bool) --> bool)
clasohm@1668
   732
  in mk_comb(c, mk_abs r)
clasohm@1668
   733
  end;
clasohm@1668
   734
clasohm@1668
   735
fun mk_prop (tm as Const("Trueprop",_) $ _) = tm
clasohm@1668
   736
  | mk_prop tm = mk_comb(Const("Trueprop", bool --> prop),tm);
clasohm@1668
   737
clasohm@1668
   738
fun drop_prop (Const("Trueprop",_) $ X) = X
clasohm@1668
   739
  | drop_prop X = X;
clasohm@1668
   740
clasohm@1668
   741
fun mk_all (r as (Bvar,_)) = mk_comb(all (type_of Bvar), mk_abs r);
clasohm@1668
   742
fun list_mk_all(V,t) = itlist(fn v => fn b => mk_all(v,b)) V t;
clasohm@1668
   743
fun list_mk_exists(V,t) = itlist(fn v => fn b => mk_exists(v,b)) V t;
clasohm@1668
   744
val list_mk_disj = end_itlist(fn d1 => fn tm => mk_disj(d1,tm))
clasohm@1668
   745
clasohm@1668
   746
clasohm@1668
   747
fun dest_thm thm = 
clasohm@1668
   748
   let val {prop,hyps,...} = rep_thm thm
clasohm@1668
   749
   in (map drop_prop hyps, drop_prop prop)
clasohm@1668
   750
   end;
clasohm@1668
   751
clasohm@1668
   752
val concl = #2 o dest_thm;
clasohm@1668
   753
clasohm@1668
   754
clasohm@1668
   755
(*---------------------------------------------------------------------------
clasohm@1668
   756
 * Names of all variables occurring in a term, including bound ones. These
clasohm@1668
   757
 * are added into the second argument.
nipkow@3265
   758
 *---------------------------------------------------------------------------
clasohm@1668
   759
fun add_term_names tm =
clasohm@1668
   760
let fun insert (x:string) = 
clasohm@1668
   761
     let fun canfind[] = [x] 
clasohm@1668
   762
           | canfind(alist as (y::rst)) = 
clasohm@1668
   763
              if (x<y) then x::alist
clasohm@1668
   764
              else if (x=y) then y::rst
clasohm@1668
   765
              else y::canfind rst 
clasohm@1668
   766
     in canfind end
clasohm@1668
   767
    fun add (Free(s,_)) V = insert s V
clasohm@1668
   768
      | add (Var((s,_),_)) V = insert s V
clasohm@1668
   769
      | add (Abs(s,_,body)) V = add body (insert s V)
clasohm@1668
   770
      | add (f$t) V = add t (add f V)
clasohm@1668
   771
      | add _ V = V
clasohm@1668
   772
in add tm
clasohm@1668
   773
end;
nipkow@3265
   774
Why bound ones???
nipkow@3265
   775
*)
clasohm@1668
   776
clasohm@1668
   777
(*---------------------------------------------------------------------------
clasohm@1668
   778
 * We need to make everything free, so that we can put the term into a
clasohm@1668
   779
 * goalstack, or submit it as an argument to prove_goalw_cterm.
clasohm@1668
   780
 *---------------------------------------------------------------------------*)
clasohm@1668
   781
fun make_free_ty(Type(s,alist)) = Type(s,map make_free_ty alist)
clasohm@1668
   782
  | make_free_ty(TVar((s,i),srt)) = TFree(s,srt)
clasohm@1668
   783
  | make_free_ty x = x;
clasohm@1668
   784
clasohm@1668
   785
fun make_free (Var((s,_),ty)) = Free(s,make_free_ty ty)
clasohm@1668
   786
  | make_free (Abs(s,x,body)) = Abs(s,make_free_ty x, make_free body)
clasohm@1668
   787
  | make_free (f$t) = (make_free f $ make_free t)
clasohm@1668
   788
  | make_free (Const(s,ty)) = Const(s, make_free_ty ty)
clasohm@1668
   789
  | make_free (Free(s,ty)) = Free(s, make_free_ty ty)
clasohm@1668
   790
  | make_free b = b;
clasohm@1668
   791
clasohm@1668
   792
clasohm@1668
   793
(*---------------------------------------------------------------------------
clasohm@1668
   794
 * Structure of case congruence theorem looks like this:
clasohm@1668
   795
 *
clasohm@1668
   796
 *    (M = M') 
clasohm@1668
   797
 *    ==> (!!x1,...,xk. (M' = C1 x1..xk) ==> (f1 x1..xk = f1' x1..xk)) 
clasohm@1668
   798
 *    ==> ... 
clasohm@1668
   799
 *    ==> (!!x1,...,xj. (M' = Cn x1..xj) ==> (fn x1..xj = fn' x1..xj)) 
clasohm@1668
   800
 *    ==>
clasohm@1668
   801
 *      (ty_case f1..fn M = ty_case f1'..fn' m')
clasohm@1668
   802
 *
clasohm@1668
   803
 * The input is the list of rules for the case construct for the type, i.e.,
clasohm@1668
   804
 * that found in the "ty.cases" field of a theory where datatype "ty" is
clasohm@1668
   805
 * defined.
clasohm@1668
   806
 *---------------------------------------------------------------------------*)
clasohm@1668
   807
clasohm@1668
   808
fun build_case_cong sign case_rewrites =
clasohm@1668
   809
 let val clauses = map concl case_rewrites
clasohm@1668
   810
     val clause1 = hd clauses
clasohm@1668
   811
     val left = (#1 o dest_eq) clause1
clasohm@1668
   812
     val ty = type_of ((#2 o dest_comb) left)
nipkow@3265
   813
     val varnames = foldr add_term_names (clauses, [])
clasohm@1668
   814
     val M = variant varnames "M"
clasohm@1668
   815
     val Mvar = Free(M, ty)
clasohm@1668
   816
     val M' = variant (M::varnames) M
clasohm@1668
   817
     val M'var = Free(M', ty)
clasohm@1668
   818
     fun mk_clause clause =
clasohm@1668
   819
       let val (lhs,rhs) = dest_eq clause
clasohm@1668
   820
           val func = (#1 o strip_comb) rhs
clasohm@1668
   821
           val (constr,xbar) = strip_comb(rand lhs)
clasohm@1668
   822
           val (Name,Ty) = dest_var func
clasohm@1668
   823
           val func'name = variant (M::M'::varnames) (Name^"a")
clasohm@1668
   824
           val func' = mk_var(func'name,Ty)
clasohm@1668
   825
       in (func', list_mk_all
clasohm@1668
   826
                  (xbar, Logic.mk_implies
clasohm@1668
   827
                         (mk_prop(mk_eq(M'var, list_comb(constr,xbar))),
clasohm@1668
   828
                          mk_prop(mk_eq(list_comb(func, xbar),
clasohm@1668
   829
                                        list_comb(func',xbar))))))   end
clasohm@1668
   830
     val (funcs',clauses') = unzip (map mk_clause clauses)
clasohm@1668
   831
     val lhsM = mk_comb(rator left, Mvar)
clasohm@1668
   832
     val c = #1(strip_comb left)
clasohm@1668
   833
 in
clasohm@1668
   834
 cterm_of sign
clasohm@1668
   835
  (make_free
clasohm@1668
   836
   (Logic.list_implies(mk_prop(mk_eq(Mvar, M'var))::clauses',
clasohm@1668
   837
                       mk_prop(mk_eq(lhsM, list_comb(c,(funcs'@[M'var])))))))
clasohm@1668
   838
 end
clasohm@1668
   839
 handle _ => raise DTYPE_ERR{func="build_case_cong",mesg="failed"};
clasohm@1668
   840
clasohm@1668
   841
  
clasohm@1668
   842
(*---------------------------------------------------------------------------
clasohm@1668
   843
 * Proves the result of "build_case_cong". 
berghofe@1897
   844
 * This one solves it a disjunct at a time, and builds the ss only once.
clasohm@1668
   845
 *---------------------------------------------------------------------------*)
clasohm@1668
   846
fun prove_case_cong nchotomy case_rewrites ctm =
clasohm@1668
   847
 let val {sign,t,...} = rep_cterm ctm
clasohm@1668
   848
     val (Const("==>",_) $ tm $ _) = t
clasohm@1668
   849
     val (Const("Trueprop",_) $ (Const("op =",_) $ _ $ Ma)) = tm
clasohm@1668
   850
     val (Free(str,_)) = Ma
clasohm@1668
   851
     val thm = prove_goalw_cterm[] ctm
berghofe@1897
   852
      (fn prems => 
berghofe@1897
   853
        let val simplify = asm_simp_tac(HOL_ss addsimps (prems@case_rewrites))
berghofe@1897
   854
        in [simp_tac (HOL_ss addsimps [hd prems]) 1,
berghofe@1897
   855
            cut_inst_tac [("x",str)] (nchotomy RS spec) 1,
berghofe@1897
   856
            REPEAT (etac disjE 1 THEN REPEAT (etac exE 1) THEN simplify 1),
berghofe@1897
   857
            REPEAT (etac exE 1) THEN simplify 1 (* Get last disjunct *)]
berghofe@1897
   858
        end) 
clasohm@1668
   859
 in standard (thm RS eq_reflection)
clasohm@1668
   860
 end
clasohm@1668
   861
 handle _ => raise DTYPE_ERR{func="prove_case_cong",mesg="failed"};
clasohm@1668
   862
clasohm@1668
   863
clasohm@1668
   864
(*---------------------------------------------------------------------------
clasohm@1668
   865
 * Structure of exhaustion theorem looks like this:
clasohm@1668
   866
 *
clasohm@1668
   867
 *    !v. (EX y1..yi. v = C1 y1..yi) | ... | (EX y1..yj. v = Cn y1..yj)
clasohm@1668
   868
 *
clasohm@1668
   869
 * As for "build_case_cong", the input is the list of rules for the case 
clasohm@1668
   870
 * construct (the case "rewrites").
clasohm@1668
   871
 *---------------------------------------------------------------------------*)
clasohm@1668
   872
fun build_nchotomy sign case_rewrites =
clasohm@1668
   873
 let val clauses = map concl case_rewrites
clasohm@1668
   874
     val C_ybars = map (rand o #1 o dest_eq) clauses
nipkow@3265
   875
     val varnames = foldr add_term_names (C_ybars, [])
clasohm@1668
   876
     val vname = variant varnames "v"
clasohm@1668
   877
     val ty = type_of (hd C_ybars)
clasohm@1668
   878
     val v = mk_var(vname,ty)
clasohm@1668
   879
     fun mk_disj C_ybar =
clasohm@1668
   880
       let val ybar = #2(strip_comb C_ybar)
clasohm@1668
   881
       in list_mk_exists(ybar, mk_eq(v,C_ybar))
clasohm@1668
   882
       end
clasohm@1668
   883
 in
clasohm@1668
   884
 cterm_of sign
clasohm@1668
   885
   (make_free(mk_prop (mk_forall(v, list_mk_disj (map mk_disj C_ybars)))))
clasohm@1668
   886
 end
clasohm@1668
   887
 handle _ => raise DTYPE_ERR{func="build_nchotomy",mesg="failed"};
clasohm@1668
   888
clasohm@1668
   889
clasohm@1668
   890
(*---------------------------------------------------------------------------
clasohm@1668
   891
 * Takes the induction tactic for the datatype, and the result from 
clasohm@1690
   892
 * "build_nchotomy" 
clasohm@1690
   893
 *
clasohm@1690
   894
 *    !v. (EX y1..yi. v = C1 y1..yi) | ... | (EX y1..yj. v = Cn y1..yj)
clasohm@1690
   895
 *
clasohm@1690
   896
 * and proves the theorem. The proof works along a diagonal: the nth 
clasohm@1690
   897
 * disjunct in the nth subgoal is easy to solve. Thus this routine depends 
clasohm@1690
   898
 * on the order of goals arising out of the application of the induction 
clasohm@1690
   899
 * tactic. A more general solution would have to use injectiveness and 
clasohm@1690
   900
 * distinctness rewrite rules.
clasohm@1668
   901
 *---------------------------------------------------------------------------*)
clasohm@1690
   902
fun prove_nchotomy induct_tac ctm =
clasohm@1690
   903
 let val (Const ("Trueprop",_) $ g) = #t(rep_cterm ctm)
clasohm@1668
   904
     val (Const ("All",_) $ Abs (v,_,_)) = g
clasohm@1690
   905
     (* For goal i, select the correct disjunct to attack, then prove it *)
clasohm@1690
   906
     fun tac i 0 = (rtac disjI1 i ORELSE all_tac) THEN
clasohm@1690
   907
                   REPEAT (rtac exI i) THEN (rtac refl i)
clasohm@1690
   908
       | tac i n = rtac disjI2 i THEN tac i (n-1)
clasohm@1668
   909
 in 
clasohm@1668
   910
 prove_goalw_cterm[] ctm
clasohm@1668
   911
     (fn _ => [rtac allI 1,
clasohm@1668
   912
               induct_tac v 1,
clasohm@1690
   913
               ALLGOALS (fn i => tac i (i-1))])
clasohm@1668
   914
 end
clasohm@1668
   915
 handle _ => raise DTYPE_ERR {func="prove_nchotomy", mesg="failed"};
clasohm@1668
   916
nipkow@3282
   917
(*---------------------------------------------------------------------------
nipkow@3282
   918
 * Turn nchotomy into exhaustion:
nipkow@3282
   919
 *    [| !!y1..yi. v = C1 y1..yi ==> P; ...; !!y1..yj. v = Cn y1..yj ==> P |]
nipkow@3282
   920
 *    ==> P
nipkow@3282
   921
 *---------------------------------------------------------------------------*)
nipkow@3282
   922
fun mk_exhaust nchotomy =
nipkow@3282
   923
  let val tac = rtac impI 1 THEN
nipkow@3282
   924
                REPEAT(SOMEGOAL(eresolve_tac [disjE,exE]))
nipkow@3282
   925
  in standard(rule_by_tactic tac (nchotomy RS spec RS rev_mp)) end;
nipkow@3282
   926
nipkow@3282
   927
(* find name of v in exhaustion: *)
nipkow@3282
   928
fun exhaust_var thm =
nipkow@3282
   929
  let val _ $ ( _ $ Var((x,_),_) $ _ ) =
nipkow@3282
   930
        hd(Logic.strip_assums_hyp(hd(prems_of thm)))
nipkow@3282
   931
  in x end;
clasohm@1668
   932
clasohm@1668
   933
(*---------------------------------------------------------------------------
clasohm@1668
   934
 * Brings the preceeding functions together.
clasohm@1668
   935
 *---------------------------------------------------------------------------*)
clasohm@1668
   936
fun case_thms sign case_rewrites induct_tac =
clasohm@1690
   937
  let val nchotomy = prove_nchotomy induct_tac
clasohm@1690
   938
                                    (build_nchotomy sign case_rewrites)
clasohm@1668
   939
      val cong = prove_case_cong nchotomy case_rewrites
clasohm@1668
   940
                                 (build_case_cong sign case_rewrites)
clasohm@1668
   941
  in {nchotomy=nchotomy, case_cong=cong}
clasohm@1668
   942
  end;
clasohm@1668
   943
clasohm@1690
   944
clasohm@1668
   945
(*---------------------------------------------------------------------------
clasohm@1668
   946
 * Tests
clasohm@1668
   947
 *
clasohm@1668
   948
 * 
clasohm@1668
   949
     Dtype.case_thms (sign_of List.thy) List.list.cases List.list.induct_tac;
clasohm@1668
   950
     Dtype.case_thms (sign_of Prod.thy) [split] 
clasohm@1668
   951
                     (fn s => res_inst_tac [("p",s)] PairE_lemma);
clasohm@1668
   952
     Dtype.case_thms (sign_of Nat.thy) [nat_case_0, nat_case_Suc] nat_ind_tac;
clasohm@1668
   953
clasohm@1668
   954
 *
clasohm@1668
   955
 *---------------------------------------------------------------------------*)
clasohm@1668
   956
clasohm@1668
   957
clasohm@1668
   958
(*---------------------------------------------------------------------------
clasohm@1668
   959
 * Given a theory and the name (and constructors) of a datatype declared in 
clasohm@1668
   960
 * an ancestor of that theory and an induction tactic for that datatype, 
clasohm@1668
   961
 * return the information that TFL needs. This should only be called once for
clasohm@1668
   962
 * a datatype, because "build_record" proves various facts, and thus is slow. 
clasohm@1668
   963
 * It fails on the datatype of pairs, which must be included for TFL to work. 
clasohm@1668
   964
 * The test shows how to  build the record for pairs.
clasohm@1668
   965
 *---------------------------------------------------------------------------*)
clasohm@1668
   966
clasohm@1668
   967
local fun mk_rw th = (th RS eq_reflection) handle _ => th
clasohm@1668
   968
      fun get_fact thy s = (get_axiom thy s handle _ => get_thm thy s)
clasohm@1668
   969
in
clasohm@1668
   970
fun build_record (thy,(ty,cl),itac) =
clasohm@1668
   971
 let val sign = sign_of thy
wenzelm@3945
   972
     val intern_const = Sign.intern_const sign;
wenzelm@3945
   973
     fun const s =
wenzelm@3945
   974
       let val s' = intern_const s
wenzelm@3945
   975
       in Const(s', the (Sign.const_type sign s')) end
clasohm@1668
   976
     val case_rewrites = map (fn c => get_fact thy (ty^"_case_"^c)) cl
clasohm@1668
   977
     val {nchotomy,case_cong} = case_thms sign case_rewrites itac
nipkow@3282
   978
     val exhaustion = mk_exhaust nchotomy
nipkow@3282
   979
     val exh_var = exhaust_var exhaustion;
nipkow@3292
   980
     fun exhaust_tac a =
nipkow@3292
   981
           ALLNEWSUBGOALS (res_inst_tac [(exh_var,a)] exhaustion)
nipkow@3292
   982
                          (rotate_tac ~1);
paulson@3564
   983
     val induct_tac = Datatype.occs_in_prems itac 
clasohm@1668
   984
 in
clasohm@1668
   985
  (ty, {constructors = map(fn s => const s handle _ => const("op "^s)) cl,
clasohm@1668
   986
        case_const = const (ty^"_case"),
clasohm@1668
   987
        case_rewrites = map mk_rw case_rewrites,
nipkow@3040
   988
        induct_tac = induct_tac,
clasohm@1668
   989
        nchotomy = nchotomy,
nipkow@3282
   990
        exhaustion = exhaustion,
nipkow@3282
   991
        exhaust_tac = exhaust_tac,
clasohm@1668
   992
        case_cong = case_cong})
clasohm@1668
   993
 end
clasohm@1668
   994
end;
clasohm@1668
   995
clasohm@1668
   996
wenzelm@4107
   997
fun add_datatype_info info thy = thy |>
wenzelm@4107
   998
  ThyData.put_datatypes (Symtab.update (info, ThyData.get_datatypes thy));
wenzelm@4107
   999
wenzelm@4107
  1000
fun add_record (ty, cl, itac) thy = thy |>
wenzelm@4107
  1001
  add_datatype_info (build_record (thy, (ty, cl), itac));
wenzelm@4107
  1002
wenzelm@4107
  1003
wenzelm@4107
  1004
wenzelm@4107
  1005
clasohm@1668
  1006
(*---------------------------------------------------------------------------
clasohm@1668
  1007
 * Test
clasohm@1668
  1008
 *
clasohm@1668
  1009
 * 
clasohm@1668
  1010
    map Dtype.build_record 
clasohm@1668
  1011
          [(Nat.thy, ("nat",["0", "Suc"]), nat_ind_tac),
clasohm@1668
  1012
           (List.thy,("list",["[]", "#"]), List.list.induct_tac)]
clasohm@1668
  1013
    @
clasohm@1668
  1014
    [let val prod_case_thms = Dtype.case_thms (sign_of Prod.thy) [split] 
clasohm@1668
  1015
                                 (fn s => res_inst_tac [("p",s)] PairE_lemma)
clasohm@1668
  1016
         fun const s = Const(s, the(Sign.const_type (sign_of Prod.thy) s))
clasohm@1668
  1017
     in ("*", 
clasohm@1668
  1018
         {constructors = [const "Pair"],
clasohm@1668
  1019
            case_const = const "split",
clasohm@1668
  1020
         case_rewrites = [split RS eq_reflection],
clasohm@1668
  1021
             case_cong = #case_cong prod_case_thms,
clasohm@1668
  1022
              nchotomy = #nchotomy prod_case_thms}) end];
clasohm@1668
  1023
clasohm@1668
  1024
 *
clasohm@1668
  1025
 *---------------------------------------------------------------------------*)
clasohm@1668
  1026
clasohm@1668
  1027
end;