uniformly capitialized names for subdirectories
authorhaftmann
Tue Jun 23 12:09:30 2009 +0200 (2009-06-23)
changeset 317752b04504fcb69
parent 31774 5c8cfaed32e6
child 31776 151c3f5f28f9
child 31781 861e675f01e6
uniformly capitialized names for subdirectories
src/HOL/Fun.thy
src/HOL/FunDef.thy
src/HOL/Inductive.thy
src/HOL/Product_Type.thy
src/HOL/Tools/Datatype/datatype.ML
src/HOL/Tools/Datatype/datatype_abs_proofs.ML
src/HOL/Tools/Datatype/datatype_aux.ML
src/HOL/Tools/Datatype/datatype_case.ML
src/HOL/Tools/Datatype/datatype_codegen.ML
src/HOL/Tools/Datatype/datatype_prop.ML
src/HOL/Tools/Datatype/datatype_realizer.ML
src/HOL/Tools/Datatype/datatype_rep_proofs.ML
src/HOL/Tools/Function/auto_term.ML
src/HOL/Tools/Function/context_tree.ML
src/HOL/Tools/Function/decompose.ML
src/HOL/Tools/Function/descent.ML
src/HOL/Tools/Function/fundef.ML
src/HOL/Tools/Function/fundef_common.ML
src/HOL/Tools/Function/fundef_core.ML
src/HOL/Tools/Function/fundef_datatype.ML
src/HOL/Tools/Function/fundef_lib.ML
src/HOL/Tools/Function/induction_scheme.ML
src/HOL/Tools/Function/inductive_wrap.ML
src/HOL/Tools/Function/lexicographic_order.ML
src/HOL/Tools/Function/measure_functions.ML
src/HOL/Tools/Function/mutual.ML
src/HOL/Tools/Function/pattern_split.ML
src/HOL/Tools/Function/scnp_reconstruct.ML
src/HOL/Tools/Function/scnp_solve.ML
src/HOL/Tools/Function/size.ML
src/HOL/Tools/Function/sum_tree.ML
src/HOL/Tools/Function/termination.ML
src/HOL/Tools/datatype_package/datatype.ML
src/HOL/Tools/datatype_package/datatype_abs_proofs.ML
src/HOL/Tools/datatype_package/datatype_aux.ML
src/HOL/Tools/datatype_package/datatype_case.ML
src/HOL/Tools/datatype_package/datatype_codegen.ML
src/HOL/Tools/datatype_package/datatype_prop.ML
src/HOL/Tools/datatype_package/datatype_realizer.ML
src/HOL/Tools/datatype_package/datatype_rep_proofs.ML
src/HOL/Tools/function_package/auto_term.ML
src/HOL/Tools/function_package/context_tree.ML
src/HOL/Tools/function_package/decompose.ML
src/HOL/Tools/function_package/descent.ML
src/HOL/Tools/function_package/fundef.ML
src/HOL/Tools/function_package/fundef_common.ML
src/HOL/Tools/function_package/fundef_core.ML
src/HOL/Tools/function_package/fundef_datatype.ML
src/HOL/Tools/function_package/fundef_lib.ML
src/HOL/Tools/function_package/induction_scheme.ML
src/HOL/Tools/function_package/inductive_wrap.ML
src/HOL/Tools/function_package/lexicographic_order.ML
src/HOL/Tools/function_package/measure_functions.ML
src/HOL/Tools/function_package/mutual.ML
src/HOL/Tools/function_package/pattern_split.ML
src/HOL/Tools/function_package/scnp_reconstruct.ML
src/HOL/Tools/function_package/scnp_solve.ML
src/HOL/Tools/function_package/size.ML
src/HOL/Tools/function_package/sum_tree.ML
src/HOL/Tools/function_package/termination.ML
src/HOL/Wellfounded.thy
src/Tools/Code/code_haskell.ML
src/Tools/Code/code_ml.ML
src/Tools/Code/code_preproc.ML
src/Tools/Code/code_printer.ML
src/Tools/Code/code_target.ML
src/Tools/Code/code_thingol.ML
src/Tools/Code_Generator.thy
src/Tools/code/code_haskell.ML
src/Tools/code/code_ml.ML
src/Tools/code/code_preproc.ML
src/Tools/code/code_printer.ML
src/Tools/code/code_target.ML
src/Tools/code/code_thingol.ML
     1.1 --- a/src/HOL/Fun.thy	Tue Jun 23 12:09:14 2009 +0200
     1.2 +++ b/src/HOL/Fun.thy	Tue Jun 23 12:09:30 2009 +0200
     1.3 @@ -133,7 +133,7 @@
     1.4    shows "inj f"
     1.5    using assms unfolding inj_on_def by auto
     1.6  
     1.7 -text{*For Proofs in @{text "Tools/datatype_package/datatype_rep_proofs"}*}
     1.8 +text{*For Proofs in @{text "Tools/Datatype/datatype_rep_proofs"}*}
     1.9  lemma datatype_injI:
    1.10      "(!! x. ALL y. f(x) = f(y) --> x=y) ==> inj(f)"
    1.11  by (simp add: inj_on_def)
     2.1 --- a/src/HOL/FunDef.thy	Tue Jun 23 12:09:14 2009 +0200
     2.2 +++ b/src/HOL/FunDef.thy	Tue Jun 23 12:09:30 2009 +0200
     2.3 @@ -9,25 +9,25 @@
     2.4  uses
     2.5    "Tools/prop_logic.ML"
     2.6    "Tools/sat_solver.ML"
     2.7 -  ("Tools/function_package/fundef_lib.ML")
     2.8 -  ("Tools/function_package/fundef_common.ML")
     2.9 -  ("Tools/function_package/inductive_wrap.ML")
    2.10 -  ("Tools/function_package/context_tree.ML")
    2.11 -  ("Tools/function_package/fundef_core.ML")
    2.12 -  ("Tools/function_package/sum_tree.ML")
    2.13 -  ("Tools/function_package/mutual.ML")
    2.14 -  ("Tools/function_package/pattern_split.ML")
    2.15 -  ("Tools/function_package/fundef.ML")
    2.16 -  ("Tools/function_package/auto_term.ML")
    2.17 -  ("Tools/function_package/measure_functions.ML")
    2.18 -  ("Tools/function_package/lexicographic_order.ML")
    2.19 -  ("Tools/function_package/fundef_datatype.ML")
    2.20 -  ("Tools/function_package/induction_scheme.ML")
    2.21 -  ("Tools/function_package/termination.ML")
    2.22 -  ("Tools/function_package/decompose.ML")
    2.23 -  ("Tools/function_package/descent.ML")
    2.24 -  ("Tools/function_package/scnp_solve.ML")
    2.25 -  ("Tools/function_package/scnp_reconstruct.ML")
    2.26 +  ("Tools/Function/fundef_lib.ML")
    2.27 +  ("Tools/Function/fundef_common.ML")
    2.28 +  ("Tools/Function/inductive_wrap.ML")
    2.29 +  ("Tools/Function/context_tree.ML")
    2.30 +  ("Tools/Function/fundef_core.ML")
    2.31 +  ("Tools/Function/sum_tree.ML")
    2.32 +  ("Tools/Function/mutual.ML")
    2.33 +  ("Tools/Function/pattern_split.ML")
    2.34 +  ("Tools/Function/fundef.ML")
    2.35 +  ("Tools/Function/auto_term.ML")
    2.36 +  ("Tools/Function/measure_functions.ML")
    2.37 +  ("Tools/Function/lexicographic_order.ML")
    2.38 +  ("Tools/Function/fundef_datatype.ML")
    2.39 +  ("Tools/Function/induction_scheme.ML")
    2.40 +  ("Tools/Function/termination.ML")
    2.41 +  ("Tools/Function/decompose.ML")
    2.42 +  ("Tools/Function/descent.ML")
    2.43 +  ("Tools/Function/scnp_solve.ML")
    2.44 +  ("Tools/Function/scnp_reconstruct.ML")
    2.45  begin
    2.46  
    2.47  subsection {* Definitions with default value. *}
    2.48 @@ -103,18 +103,18 @@
    2.49    "wf R \<Longrightarrow> wfP (in_rel R)"
    2.50    by (simp add: wfP_def)
    2.51  
    2.52 -use "Tools/function_package/fundef_lib.ML"
    2.53 -use "Tools/function_package/fundef_common.ML"
    2.54 -use "Tools/function_package/inductive_wrap.ML"
    2.55 -use "Tools/function_package/context_tree.ML"
    2.56 -use "Tools/function_package/fundef_core.ML"
    2.57 -use "Tools/function_package/sum_tree.ML"
    2.58 -use "Tools/function_package/mutual.ML"
    2.59 -use "Tools/function_package/pattern_split.ML"
    2.60 -use "Tools/function_package/auto_term.ML"
    2.61 -use "Tools/function_package/fundef.ML"
    2.62 -use "Tools/function_package/fundef_datatype.ML"
    2.63 -use "Tools/function_package/induction_scheme.ML"
    2.64 +use "Tools/Function/fundef_lib.ML"
    2.65 +use "Tools/Function/fundef_common.ML"
    2.66 +use "Tools/Function/inductive_wrap.ML"
    2.67 +use "Tools/Function/context_tree.ML"
    2.68 +use "Tools/Function/fundef_core.ML"
    2.69 +use "Tools/Function/sum_tree.ML"
    2.70 +use "Tools/Function/mutual.ML"
    2.71 +use "Tools/Function/pattern_split.ML"
    2.72 +use "Tools/Function/auto_term.ML"
    2.73 +use "Tools/Function/fundef.ML"
    2.74 +use "Tools/Function/fundef_datatype.ML"
    2.75 +use "Tools/Function/induction_scheme.ML"
    2.76  
    2.77  setup {* 
    2.78    Fundef.setup 
    2.79 @@ -127,7 +127,7 @@
    2.80  inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
    2.81  where is_measure_trivial: "is_measure f"
    2.82  
    2.83 -use "Tools/function_package/measure_functions.ML"
    2.84 +use "Tools/Function/measure_functions.ML"
    2.85  setup MeasureFunctions.setup
    2.86  
    2.87  lemma measure_size[measure_function]: "is_measure size"
    2.88 @@ -138,7 +138,7 @@
    2.89  lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
    2.90  by (rule is_measure_trivial)
    2.91  
    2.92 -use "Tools/function_package/lexicographic_order.ML"
    2.93 +use "Tools/Function/lexicographic_order.ML"
    2.94  setup LexicographicOrder.setup 
    2.95  
    2.96  
    2.97 @@ -307,11 +307,11 @@
    2.98  
    2.99  subsection {* Tool setup *}
   2.100  
   2.101 -use "Tools/function_package/termination.ML"
   2.102 -use "Tools/function_package/decompose.ML"
   2.103 -use "Tools/function_package/descent.ML"
   2.104 -use "Tools/function_package/scnp_solve.ML"
   2.105 -use "Tools/function_package/scnp_reconstruct.ML"
   2.106 +use "Tools/Function/termination.ML"
   2.107 +use "Tools/Function/decompose.ML"
   2.108 +use "Tools/Function/descent.ML"
   2.109 +use "Tools/Function/scnp_solve.ML"
   2.110 +use "Tools/Function/scnp_reconstruct.ML"
   2.111  
   2.112  setup {* ScnpReconstruct.setup *}
   2.113  
     3.1 --- a/src/HOL/Inductive.thy	Tue Jun 23 12:09:14 2009 +0200
     3.2 +++ b/src/HOL/Inductive.thy	Tue Jun 23 12:09:30 2009 +0200
     3.3 @@ -10,15 +10,15 @@
     3.4    ("Tools/inductive.ML")
     3.5    "Tools/dseq.ML"
     3.6    ("Tools/inductive_codegen.ML")
     3.7 -  ("Tools/datatype_package/datatype_aux.ML")
     3.8 -  ("Tools/datatype_package/datatype_prop.ML")
     3.9 -  ("Tools/datatype_package/datatype_rep_proofs.ML")
    3.10 -  ("Tools/datatype_package/datatype_abs_proofs.ML")
    3.11 -  ("Tools/datatype_package/datatype_case.ML")
    3.12 -  ("Tools/datatype_package/datatype.ML")
    3.13 +  ("Tools/Datatype/datatype_aux.ML")
    3.14 +  ("Tools/Datatype/datatype_prop.ML")
    3.15 +  ("Tools/Datatype/datatype_rep_proofs.ML")
    3.16 +  ("Tools/Datatype/datatype_abs_proofs.ML")
    3.17 +  ("Tools/Datatype/datatype_case.ML")
    3.18 +  ("Tools/Datatype/datatype.ML")
    3.19    ("Tools/old_primrec.ML")
    3.20    ("Tools/primrec.ML")
    3.21 -  ("Tools/datatype_package/datatype_codegen.ML")
    3.22 +  ("Tools/Datatype/datatype_codegen.ML")
    3.23  begin
    3.24  
    3.25  subsection {* Least and greatest fixed points *}
    3.26 @@ -335,18 +335,18 @@
    3.27  
    3.28  text {* Package setup. *}
    3.29  
    3.30 -use "Tools/datatype_package/datatype_aux.ML"
    3.31 -use "Tools/datatype_package/datatype_prop.ML"
    3.32 -use "Tools/datatype_package/datatype_rep_proofs.ML"
    3.33 -use "Tools/datatype_package/datatype_abs_proofs.ML"
    3.34 -use "Tools/datatype_package/datatype_case.ML"
    3.35 -use "Tools/datatype_package/datatype.ML"
    3.36 +use "Tools/Datatype/datatype_aux.ML"
    3.37 +use "Tools/Datatype/datatype_prop.ML"
    3.38 +use "Tools/Datatype/datatype_rep_proofs.ML"
    3.39 +use "Tools/Datatype/datatype_abs_proofs.ML"
    3.40 +use "Tools/Datatype/datatype_case.ML"
    3.41 +use "Tools/Datatype/datatype.ML"
    3.42  setup Datatype.setup
    3.43  
    3.44  use "Tools/old_primrec.ML"
    3.45  use "Tools/primrec.ML"
    3.46  
    3.47 -use "Tools/datatype_package/datatype_codegen.ML"
    3.48 +use "Tools/Datatype/datatype_codegen.ML"
    3.49  setup DatatypeCodegen.setup
    3.50  
    3.51  use "Tools/inductive_codegen.ML"
     4.1 --- a/src/HOL/Product_Type.thy	Tue Jun 23 12:09:14 2009 +0200
     4.2 +++ b/src/HOL/Product_Type.thy	Tue Jun 23 12:09:30 2009 +0200
     4.3 @@ -11,7 +11,7 @@
     4.4    ("Tools/split_rule.ML")
     4.5    ("Tools/inductive_set.ML")
     4.6    ("Tools/inductive_realizer.ML")
     4.7 -  ("Tools/datatype_package/datatype_realizer.ML")
     4.8 +  ("Tools/Datatype/datatype_realizer.ML")
     4.9  begin
    4.10  
    4.11  subsection {* @{typ bool} is a datatype *}
    4.12 @@ -399,7 +399,7 @@
    4.13    by (simp add: split_def id_def)
    4.14  
    4.15  lemma split_eta: "(\<lambda>(x, y). f (x, y)) = f"
    4.16 -  -- {* Subsumes the old @{text split_Pair} when @{term f} is the identity function. *}
    4.17 +  -- {* Subsumes the old @{text split_Pair} when @{term f} is the identity Datatype. *}
    4.18    by (rule ext) auto
    4.19  
    4.20  lemma split_comp: "split (f \<circ> g) x = f (g (fst x)) (snd x)"
    4.21 @@ -734,7 +734,7 @@
    4.22  
    4.23  text {*
    4.24    @{term prod_fun} --- action of the product functor upon
    4.25 -  functions.
    4.26 +  Datatypes.
    4.27  *}
    4.28  
    4.29  definition prod_fun :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'd" where
    4.30 @@ -1154,7 +1154,7 @@
    4.31  use "Tools/inductive_set.ML"
    4.32  setup Inductive_Set.setup
    4.33  
    4.34 -use "Tools/datatype_package/datatype_realizer.ML"
    4.35 +use "Tools/Datatype/datatype_realizer.ML"
    4.36  setup DatatypeRealizer.setup
    4.37  
    4.38  end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Tools/Datatype/datatype.ML	Tue Jun 23 12:09:30 2009 +0200
     5.3 @@ -0,0 +1,704 @@
     5.4 +(*  Title:      HOL/Tools/datatype.ML
     5.5 +    Author:     Stefan Berghofer, TU Muenchen
     5.6 +
     5.7 +Datatype package for Isabelle/HOL.
     5.8 +*)
     5.9 +
    5.10 +signature DATATYPE =
    5.11 +sig
    5.12 +  include DATATYPE_COMMON
    5.13 +  type rules = {distinct : thm list list,
    5.14 +    inject : thm list list,
    5.15 +    exhaustion : thm list,
    5.16 +    rec_thms : thm list,
    5.17 +    case_thms : thm list list,
    5.18 +    split_thms : (thm * thm) list,
    5.19 +    induction : thm,
    5.20 +    simps : thm list}
    5.21 +  val add_datatype : config -> string list -> (string list * binding * mixfix *
    5.22 +    (binding * typ list * mixfix) list) list -> theory -> rules * theory
    5.23 +  val datatype_cmd : string list -> (string list * binding * mixfix *
    5.24 +    (binding * string list * mixfix) list) list -> theory -> theory
    5.25 +  val rep_datatype : config -> (rules -> Proof.context -> Proof.context)
    5.26 +    -> string list option -> term list -> theory -> Proof.state
    5.27 +  val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
    5.28 +  val get_datatypes : theory -> info Symtab.table
    5.29 +  val get_datatype : theory -> string -> info option
    5.30 +  val the_datatype : theory -> string -> info
    5.31 +  val datatype_of_constr : theory -> string -> info option
    5.32 +  val datatype_of_case : theory -> string -> info option
    5.33 +  val the_datatype_spec : theory -> string -> (string * sort) list * (string * typ list) list
    5.34 +  val the_datatype_descr : theory -> string list
    5.35 +    -> descr * (string * sort) list * string list
    5.36 +      * (string list * string list) * (typ list * typ list)
    5.37 +  val get_datatype_constrs : theory -> string -> (string * typ) list option
    5.38 +  val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
    5.39 +  val distinct_simproc : simproc
    5.40 +  val make_case :  Proof.context -> bool -> string list -> term ->
    5.41 +    (term * term) list -> term * (term * (int * bool)) list
    5.42 +  val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
    5.43 +  val read_typ: theory ->
    5.44 +    (typ list * (string * sort) list) * string -> typ list * (string * sort) list
    5.45 +  val setup: theory -> theory
    5.46 +end;
    5.47 +
    5.48 +structure Datatype : DATATYPE =
    5.49 +struct
    5.50 +
    5.51 +open DatatypeAux;
    5.52 +
    5.53 +
    5.54 +(* theory data *)
    5.55 +
    5.56 +structure DatatypesData = TheoryDataFun
    5.57 +(
    5.58 +  type T =
    5.59 +    {types: info Symtab.table,
    5.60 +     constrs: info Symtab.table,
    5.61 +     cases: info Symtab.table};
    5.62 +
    5.63 +  val empty =
    5.64 +    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
    5.65 +  val copy = I;
    5.66 +  val extend = I;
    5.67 +  fun merge _
    5.68 +    ({types = types1, constrs = constrs1, cases = cases1},
    5.69 +     {types = types2, constrs = constrs2, cases = cases2}) =
    5.70 +    {types = Symtab.merge (K true) (types1, types2),
    5.71 +     constrs = Symtab.merge (K true) (constrs1, constrs2),
    5.72 +     cases = Symtab.merge (K true) (cases1, cases2)};
    5.73 +);
    5.74 +
    5.75 +val get_datatypes = #types o DatatypesData.get;
    5.76 +val map_datatypes = DatatypesData.map;
    5.77 +
    5.78 +
    5.79 +(** theory information about datatypes **)
    5.80 +
    5.81 +fun put_dt_infos (dt_infos : (string * info) list) =
    5.82 +  map_datatypes (fn {types, constrs, cases} =>
    5.83 +    {types = fold Symtab.update dt_infos types,
    5.84 +     constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
    5.85 +       (maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
    5.86 +          (#3 (the (AList.lookup op = descr index)))) dt_infos) constrs,
    5.87 +     cases = fold Symtab.update
    5.88 +       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
    5.89 +       cases});
    5.90 +
    5.91 +val get_datatype = Symtab.lookup o get_datatypes;
    5.92 +
    5.93 +fun the_datatype thy name = (case get_datatype thy name of
    5.94 +      SOME info => info
    5.95 +    | NONE => error ("Unknown datatype " ^ quote name));
    5.96 +
    5.97 +val datatype_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
    5.98 +val datatype_of_case = Symtab.lookup o #cases o DatatypesData.get;
    5.99 +
   5.100 +fun get_datatype_descr thy dtco =
   5.101 +  get_datatype thy dtco
   5.102 +  |> Option.map (fn info as { descr, index, ... } =>
   5.103 +       (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
   5.104 +
   5.105 +fun the_datatype_spec thy dtco =
   5.106 +  let
   5.107 +    val info as { descr, index, sorts = raw_sorts, ... } = the_datatype thy dtco;
   5.108 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
   5.109 +    val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
   5.110 +      o DatatypeAux.dest_DtTFree) dtys;
   5.111 +    val cos = map
   5.112 +      (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
   5.113 +  in (sorts, cos) end;
   5.114 +
   5.115 +fun the_datatype_descr thy (raw_tycos as raw_tyco :: _) =
   5.116 +  let
   5.117 +    val info = the_datatype thy raw_tyco;
   5.118 +    val descr = #descr info;
   5.119 +
   5.120 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
   5.121 +    val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
   5.122 +      o dest_DtTFree) dtys;
   5.123 +
   5.124 +    fun is_DtTFree (DtTFree _) = true
   5.125 +      | is_DtTFree _ = false
   5.126 +    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
   5.127 +    val protoTs as (dataTs, _) = chop k descr
   5.128 +      |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
   5.129 +    
   5.130 +    val tycos = map fst dataTs;
   5.131 +    val _ = if gen_eq_set (op =) (tycos, raw_tycos) then ()
   5.132 +      else error ("Type constructors " ^ commas (map quote raw_tycos)
   5.133 +        ^ "do not belong exhaustively to one mutual recursive datatype");
   5.134 +
   5.135 +    val (Ts, Us) = (pairself o map) Type protoTs;
   5.136 +
   5.137 +    val names = map Long_Name.base_name (the_default tycos (#alt_names info));
   5.138 +    val (auxnames, _) = Name.make_context names
   5.139 +      |> fold_map (yield_singleton Name.variants o name_of_typ) Us
   5.140 +
   5.141 +  in (descr, vs, tycos, (names, auxnames), (Ts, Us)) end;
   5.142 +
   5.143 +fun get_datatype_constrs thy dtco =
   5.144 +  case try (the_datatype_spec thy) dtco
   5.145 +   of SOME (sorts, cos) =>
   5.146 +        let
   5.147 +          fun subst (v, sort) = TVar ((v, 0), sort);
   5.148 +          fun subst_ty (TFree v) = subst v
   5.149 +            | subst_ty ty = ty;
   5.150 +          val dty = Type (dtco, map subst sorts);
   5.151 +          fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
   5.152 +        in SOME (map mk_co cos) end
   5.153 +    | NONE => NONE;
   5.154 +
   5.155 +
   5.156 +(** induct method setup **)
   5.157 +
   5.158 +(* case names *)
   5.159 +
   5.160 +local
   5.161 +
   5.162 +fun dt_recs (DtTFree _) = []
   5.163 +  | dt_recs (DtType (_, dts)) = maps dt_recs dts
   5.164 +  | dt_recs (DtRec i) = [i];
   5.165 +
   5.166 +fun dt_cases (descr: descr) (_, args, constrs) =
   5.167 +  let
   5.168 +    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
   5.169 +    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
   5.170 +  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   5.171 +
   5.172 +
   5.173 +fun induct_cases descr =
   5.174 +  DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
   5.175 +
   5.176 +fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
   5.177 +
   5.178 +in
   5.179 +
   5.180 +fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
   5.181 +
   5.182 +fun mk_case_names_exhausts descr new =
   5.183 +  map (RuleCases.case_names o exhaust_cases descr o #1)
   5.184 +    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
   5.185 +
   5.186 +end;
   5.187 +
   5.188 +fun add_rules simps case_thms rec_thms inject distinct
   5.189 +                  weak_case_congs cong_att =
   5.190 +  PureThy.add_thmss [((Binding.name "simps", simps), []),
   5.191 +    ((Binding.empty, flat case_thms @
   5.192 +          flat distinct @ rec_thms), [Simplifier.simp_add]),
   5.193 +    ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
   5.194 +    ((Binding.empty, flat inject), [iff_add]),
   5.195 +    ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
   5.196 +    ((Binding.empty, weak_case_congs), [cong_att])]
   5.197 +  #> snd;
   5.198 +
   5.199 +
   5.200 +(* add_cases_induct *)
   5.201 +
   5.202 +fun add_cases_induct infos induction thy =
   5.203 +  let
   5.204 +    val inducts = ProjectRule.projections (ProofContext.init thy) induction;
   5.205 +
   5.206 +    fun named_rules (name, {index, exhaustion, ...}: info) =
   5.207 +      [((Binding.empty, nth inducts index), [Induct.induct_type name]),
   5.208 +       ((Binding.empty, exhaustion), [Induct.cases_type name])];
   5.209 +    fun unnamed_rule i =
   5.210 +      ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
   5.211 +  in
   5.212 +    thy |> PureThy.add_thms
   5.213 +      (maps named_rules infos @
   5.214 +        map unnamed_rule (length infos upto length inducts - 1)) |> snd
   5.215 +    |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
   5.216 +  end;
   5.217 +
   5.218 +
   5.219 +
   5.220 +(**** simplification procedure for showing distinctness of constructors ****)
   5.221 +
   5.222 +fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
   5.223 +  | stripT p = p;
   5.224 +
   5.225 +fun stripC (i, f $ x) = stripC (i + 1, f)
   5.226 +  | stripC p = p;
   5.227 +
   5.228 +val distinctN = "constr_distinct";
   5.229 +
   5.230 +fun distinct_rule thy ss tname eq_t = case #distinct (the_datatype thy tname) of
   5.231 +    FewConstrs thms => Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
   5.232 +      (EVERY [rtac eq_reflection 1, rtac iffI 1, rtac notE 1,
   5.233 +        atac 2, resolve_tac thms 1, etac FalseE 1]))
   5.234 +  | ManyConstrs (thm, simpset) =>
   5.235 +      let
   5.236 +        val [In0_inject, In1_inject, In0_not_In1, In1_not_In0] =
   5.237 +          map (PureThy.get_thm (ThyInfo.the_theory "Datatype" thy))
   5.238 +            ["In0_inject", "In1_inject", "In0_not_In1", "In1_not_In0"];
   5.239 +      in
   5.240 +        Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
   5.241 +        (EVERY [rtac eq_reflection 1, rtac iffI 1, dtac thm 1,
   5.242 +          full_simp_tac (Simplifier.inherit_context ss simpset) 1,
   5.243 +          REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
   5.244 +          eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1,
   5.245 +          etac FalseE 1]))
   5.246 +      end;
   5.247 +
   5.248 +fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
   5.249 +  (case (stripC (0, t1), stripC (0, t2)) of
   5.250 +     ((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
   5.251 +         (case (stripT (0, T1), stripT (0, T2)) of
   5.252 +            ((i', Type (tname1, _)), (j', Type (tname2, _))) =>
   5.253 +                if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
   5.254 +                   (case (get_datatype_descr thy) tname1 of
   5.255 +                      SOME (_, (_, constrs)) => let val cnames = map fst constrs
   5.256 +                        in if cname1 mem cnames andalso cname2 mem cnames then
   5.257 +                             SOME (distinct_rule thy ss tname1
   5.258 +                               (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
   5.259 +                           else NONE
   5.260 +                        end
   5.261 +                    | NONE => NONE)
   5.262 +                else NONE
   5.263 +          | _ => NONE)
   5.264 +   | _ => NONE)
   5.265 +  | distinct_proc _ _ _ = NONE;
   5.266 +
   5.267 +val distinct_simproc =
   5.268 +  Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
   5.269 +
   5.270 +val dist_ss = HOL_ss addsimprocs [distinct_simproc];
   5.271 +
   5.272 +val simproc_setup =
   5.273 +  Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
   5.274 +
   5.275 +
   5.276 +(**** translation rules for case ****)
   5.277 +
   5.278 +fun make_case ctxt = DatatypeCase.make_case
   5.279 +  (datatype_of_constr (ProofContext.theory_of ctxt)) ctxt;
   5.280 +
   5.281 +fun strip_case ctxt = DatatypeCase.strip_case
   5.282 +  (datatype_of_case (ProofContext.theory_of ctxt));
   5.283 +
   5.284 +fun add_case_tr' case_names thy =
   5.285 +  Sign.add_advanced_trfuns ([], [],
   5.286 +    map (fn case_name =>
   5.287 +      let val case_name' = Sign.const_syntax_name thy case_name
   5.288 +      in (case_name', DatatypeCase.case_tr' datatype_of_case case_name')
   5.289 +      end) case_names, []) thy;
   5.290 +
   5.291 +val trfun_setup =
   5.292 +  Sign.add_advanced_trfuns ([],
   5.293 +    [("_case_syntax", DatatypeCase.case_tr true datatype_of_constr)],
   5.294 +    [], []);
   5.295 +
   5.296 +
   5.297 +(* prepare types *)
   5.298 +
   5.299 +fun read_typ thy ((Ts, sorts), str) =
   5.300 +  let
   5.301 +    val ctxt = ProofContext.init thy
   5.302 +      |> fold (Variable.declare_typ o TFree) sorts;
   5.303 +    val T = Syntax.read_typ ctxt str;
   5.304 +  in (Ts @ [T], Term.add_tfreesT T sorts) end;
   5.305 +
   5.306 +fun cert_typ sign ((Ts, sorts), raw_T) =
   5.307 +  let
   5.308 +    val T = Type.no_tvars (Sign.certify_typ sign raw_T) handle
   5.309 +      TYPE (msg, _, _) => error msg;
   5.310 +    val sorts' = Term.add_tfreesT T sorts;
   5.311 +  in (Ts @ [T],
   5.312 +      case duplicates (op =) (map fst sorts') of
   5.313 +         [] => sorts'
   5.314 +       | dups => error ("Inconsistent sort constraints for " ^ commas dups))
   5.315 +  end;
   5.316 +
   5.317 +
   5.318 +(**** make datatype info ****)
   5.319 +
   5.320 +fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
   5.321 +    (((((((((i, (_, (tname, _, _))), case_name), case_thms),
   5.322 +      exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
   5.323 +  (tname,
   5.324 +   {index = i,
   5.325 +    alt_names = alt_names,
   5.326 +    descr = descr,
   5.327 +    sorts = sorts,
   5.328 +    rec_names = reccomb_names,
   5.329 +    rec_rewrites = rec_thms,
   5.330 +    case_name = case_name,
   5.331 +    case_rewrites = case_thms,
   5.332 +    induction = induct,
   5.333 +    exhaustion = exhaustion_thm,
   5.334 +    distinct = distinct_thm,
   5.335 +    inject = inject,
   5.336 +    nchotomy = nchotomy,
   5.337 +    case_cong = case_cong,
   5.338 +    weak_case_cong = weak_case_cong});
   5.339 +
   5.340 +type rules = {distinct : thm list list,
   5.341 +  inject : thm list list,
   5.342 +  exhaustion : thm list,
   5.343 +  rec_thms : thm list,
   5.344 +  case_thms : thm list list,
   5.345 +  split_thms : (thm * thm) list,
   5.346 +  induction : thm,
   5.347 +  simps : thm list}
   5.348 +
   5.349 +structure DatatypeInterpretation = InterpretationFun
   5.350 +  (type T = config * string list val eq: T * T -> bool = eq_snd op =);
   5.351 +fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
   5.352 +
   5.353 +
   5.354 +(******************* definitional introduction of datatypes *******************)
   5.355 +
   5.356 +fun add_datatype_def (config : config) new_type_names descr sorts types_syntax constr_syntax dt_info
   5.357 +    case_names_induct case_names_exhausts thy =
   5.358 +  let
   5.359 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
   5.360 +
   5.361 +    val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
   5.362 +      DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
   5.363 +        types_syntax constr_syntax case_names_induct;
   5.364 +
   5.365 +    val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
   5.366 +      sorts induct case_names_exhausts thy2;
   5.367 +    val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
   5.368 +      config new_type_names descr sorts dt_info inject dist_rewrites
   5.369 +      (Simplifier.theory_context thy3 dist_ss) induct thy3;
   5.370 +    val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
   5.371 +      config new_type_names descr sorts reccomb_names rec_thms thy4;
   5.372 +    val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
   5.373 +      descr sorts inject dist_rewrites casedist_thms case_thms thy6;
   5.374 +    val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
   5.375 +      descr sorts casedist_thms thy7;
   5.376 +    val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
   5.377 +      descr sorts nchotomys case_thms thy8;
   5.378 +    val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
   5.379 +      descr sorts thy9;
   5.380 +
   5.381 +    val dt_infos = map
   5.382 +      (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
   5.383 +      ((0 upto length (hd descr) - 1) ~~ (hd descr) ~~ case_names ~~ case_thms ~~
   5.384 +        casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
   5.385 +
   5.386 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
   5.387 +
   5.388 +    val thy12 =
   5.389 +      thy10
   5.390 +      |> add_case_tr' case_names
   5.391 +      |> Sign.add_path (space_implode "_" new_type_names)
   5.392 +      |> add_rules simps case_thms rec_thms inject distinct
   5.393 +          weak_case_congs (Simplifier.attrib (op addcongs))
   5.394 +      |> put_dt_infos dt_infos
   5.395 +      |> add_cases_induct dt_infos induct
   5.396 +      |> Sign.parent_path
   5.397 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
   5.398 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
   5.399 +  in
   5.400 +    ({distinct = distinct,
   5.401 +      inject = inject,
   5.402 +      exhaustion = casedist_thms,
   5.403 +      rec_thms = rec_thms,
   5.404 +      case_thms = case_thms,
   5.405 +      split_thms = split_thms,
   5.406 +      induction = induct,
   5.407 +      simps = simps}, thy12)
   5.408 +  end;
   5.409 +
   5.410 +
   5.411 +(*********************** declare existing type as datatype *********************)
   5.412 +
   5.413 +fun prove_rep_datatype (config : config) alt_names new_type_names descr sorts induct inject half_distinct thy =
   5.414 +  let
   5.415 +    val ((_, [induct']), _) =
   5.416 +      Variable.importT_thms [induct] (Variable.thm_context induct);
   5.417 +
   5.418 +    fun err t = error ("Ill-formed predicate in induction rule: " ^
   5.419 +      Syntax.string_of_term_global thy t);
   5.420 +
   5.421 +    fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
   5.422 +          ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
   5.423 +      | get_typ t = err t;
   5.424 +    val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
   5.425 +
   5.426 +    val dt_info = get_datatypes thy;
   5.427 +
   5.428 +    val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
   5.429 +    val (case_names_induct, case_names_exhausts) =
   5.430 +      (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
   5.431 +
   5.432 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
   5.433 +
   5.434 +    val (casedist_thms, thy2) = thy |>
   5.435 +      DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
   5.436 +        case_names_exhausts;
   5.437 +    val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
   5.438 +      config new_type_names [descr] sorts dt_info inject distinct
   5.439 +      (Simplifier.theory_context thy2 dist_ss) induct thy2;
   5.440 +    val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
   5.441 +      config new_type_names [descr] sorts reccomb_names rec_thms thy3;
   5.442 +    val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
   5.443 +      config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
   5.444 +    val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
   5.445 +      [descr] sorts casedist_thms thy5;
   5.446 +    val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
   5.447 +      [descr] sorts nchotomys case_thms thy6;
   5.448 +    val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
   5.449 +      [descr] sorts thy7;
   5.450 +
   5.451 +    val ((_, [induct']), thy10) =
   5.452 +      thy8
   5.453 +      |> store_thmss "inject" new_type_names inject
   5.454 +      ||>> store_thmss "distinct" new_type_names distinct
   5.455 +      ||> Sign.add_path (space_implode "_" new_type_names)
   5.456 +      ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
   5.457 +
   5.458 +    val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
   5.459 +      ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
   5.460 +        map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
   5.461 +
   5.462 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
   5.463 +
   5.464 +    val thy11 =
   5.465 +      thy10
   5.466 +      |> add_case_tr' case_names
   5.467 +      |> add_rules simps case_thms rec_thms inject distinct
   5.468 +           weak_case_congs (Simplifier.attrib (op addcongs))
   5.469 +      |> put_dt_infos dt_infos
   5.470 +      |> add_cases_induct dt_infos induct'
   5.471 +      |> Sign.parent_path
   5.472 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
   5.473 +      |> snd
   5.474 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
   5.475 +  in
   5.476 +    ({distinct = distinct,
   5.477 +      inject = inject,
   5.478 +      exhaustion = casedist_thms,
   5.479 +      rec_thms = rec_thms,
   5.480 +      case_thms = case_thms,
   5.481 +      split_thms = split_thms,
   5.482 +      induction = induct',
   5.483 +      simps = simps}, thy11)
   5.484 +  end;
   5.485 +
   5.486 +fun gen_rep_datatype prep_term (config : config) after_qed alt_names raw_ts thy =
   5.487 +  let
   5.488 +    fun constr_of_term (Const (c, T)) = (c, T)
   5.489 +      | constr_of_term t =
   5.490 +          error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
   5.491 +    fun no_constr (c, T) = error ("Bad constructor: "
   5.492 +      ^ Sign.extern_const thy c ^ "::"
   5.493 +      ^ Syntax.string_of_typ_global thy T);
   5.494 +    fun type_of_constr (cT as (_, T)) =
   5.495 +      let
   5.496 +        val frees = OldTerm.typ_tfrees T;
   5.497 +        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
   5.498 +          handle TYPE _ => no_constr cT
   5.499 +        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
   5.500 +        val _ = if length frees <> length vs then no_constr cT else ();
   5.501 +      in (tyco, (vs, cT)) end;
   5.502 +
   5.503 +    val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
   5.504 +    val _ = case map_filter (fn (tyco, _) =>
   5.505 +        if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs
   5.506 +     of [] => ()
   5.507 +      | tycos => error ("Type(s) " ^ commas (map quote tycos)
   5.508 +          ^ " already represented inductivly");
   5.509 +    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
   5.510 +    val ms = case distinct (op =) (map length raw_vss)
   5.511 +     of [n] => 0 upto n - 1
   5.512 +      | _ => error ("Different types in given constructors");
   5.513 +    fun inter_sort m = map (fn xs => nth xs m) raw_vss
   5.514 +      |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
   5.515 +    val sorts = map inter_sort ms;
   5.516 +    val vs = Name.names Name.context Name.aT sorts;
   5.517 +
   5.518 +    fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
   5.519 +      (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
   5.520 +
   5.521 +    val cs = map (apsnd (map norm_constr)) raw_cs;
   5.522 +    val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
   5.523 +      o fst o strip_type;
   5.524 +    val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
   5.525 +
   5.526 +    fun mk_spec (i, (tyco, constr)) = (i, (tyco,
   5.527 +      map (DtTFree o fst) vs,
   5.528 +      (map o apsnd) dtyps_of_typ constr))
   5.529 +    val descr = map_index mk_spec cs;
   5.530 +    val injs = DatatypeProp.make_injs [descr] vs;
   5.531 +    val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
   5.532 +    val ind = DatatypeProp.make_ind [descr] vs;
   5.533 +    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
   5.534 +
   5.535 +    fun after_qed' raw_thms =
   5.536 +      let
   5.537 +        val [[[induct]], injs, half_distincts] =
   5.538 +          unflat rules (map Drule.zero_var_indexes_list raw_thms);
   5.539 +            (*FIXME somehow dubious*)
   5.540 +      in
   5.541 +        ProofContext.theory_result
   5.542 +          (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
   5.543 +        #-> after_qed
   5.544 +      end;
   5.545 +  in
   5.546 +    thy
   5.547 +    |> ProofContext.init
   5.548 +    |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
   5.549 +  end;
   5.550 +
   5.551 +val rep_datatype = gen_rep_datatype Sign.cert_term;
   5.552 +val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_config (K I);
   5.553 +
   5.554 +
   5.555 +
   5.556 +(******************************** add datatype ********************************)
   5.557 +
   5.558 +fun gen_add_datatype prep_typ (config : config) new_type_names dts thy =
   5.559 +  let
   5.560 +    val _ = Theory.requires thy "Datatype" "datatype definitions";
   5.561 +
   5.562 +    (* this theory is used just for parsing *)
   5.563 +
   5.564 +    val tmp_thy = thy |>
   5.565 +      Theory.copy |>
   5.566 +      Sign.add_types (map (fn (tvs, tname, mx, _) =>
   5.567 +        (tname, length tvs, mx)) dts);
   5.568 +
   5.569 +    val (tyvars, _, _, _)::_ = dts;
   5.570 +    val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
   5.571 +      let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
   5.572 +      in (case duplicates (op =) tvs of
   5.573 +            [] => if eq_set (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
   5.574 +                  else error ("Mutually recursive datatypes must have same type parameters")
   5.575 +          | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
   5.576 +              " : " ^ commas dups))
   5.577 +      end) dts);
   5.578 +
   5.579 +    val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
   5.580 +      [] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
   5.581 +
   5.582 +    fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
   5.583 +      let
   5.584 +        fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
   5.585 +          let
   5.586 +            val (cargs', sorts'') = Library.foldl (prep_typ tmp_thy) (([], sorts'), cargs);
   5.587 +            val _ = (case fold (curry OldTerm.add_typ_tfree_names) cargs' [] \\ tvs of
   5.588 +                [] => ()
   5.589 +              | vs => error ("Extra type variables on rhs: " ^ commas vs))
   5.590 +          in (constrs @ [((if #flat_names config then Sign.full_name tmp_thy else
   5.591 +                Sign.full_name_path tmp_thy tname')
   5.592 +                  (Binding.map_name (Syntax.const_name mx') cname),
   5.593 +                   map (dtyp_of_typ new_dts) cargs')],
   5.594 +              constr_syntax' @ [(cname, mx')], sorts'')
   5.595 +          end handle ERROR msg => cat_error msg
   5.596 +           ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
   5.597 +            " of datatype " ^ quote (Binding.str_of tname));
   5.598 +
   5.599 +        val (constrs', constr_syntax', sorts') =
   5.600 +          fold prep_constr constrs ([], [], sorts)
   5.601 +
   5.602 +      in
   5.603 +        case duplicates (op =) (map fst constrs') of
   5.604 +           [] =>
   5.605 +             (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
   5.606 +                map DtTFree tvs, constrs'))],
   5.607 +              constr_syntax @ [constr_syntax'], sorts', i + 1)
   5.608 +         | dups => error ("Duplicate constructors " ^ commas dups ^
   5.609 +             " in datatype " ^ quote (Binding.str_of tname))
   5.610 +      end;
   5.611 +
   5.612 +    val (dts', constr_syntax, sorts', i) =
   5.613 +      fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
   5.614 +    val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (tyvars \\ map fst sorts'));
   5.615 +    val dt_info = get_datatypes thy;
   5.616 +    val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
   5.617 +    val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
   5.618 +      if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
   5.619 +      else raise exn;
   5.620 +
   5.621 +    val descr' = flat descr;
   5.622 +    val case_names_induct = mk_case_names_induct descr';
   5.623 +    val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
   5.624 +  in
   5.625 +    add_datatype_def
   5.626 +      (config : config) new_type_names descr sorts types_syntax constr_syntax dt_info
   5.627 +      case_names_induct case_names_exhausts thy
   5.628 +  end;
   5.629 +
   5.630 +val add_datatype = gen_add_datatype cert_typ;
   5.631 +val datatype_cmd = snd ooo gen_add_datatype read_typ default_config;
   5.632 +
   5.633 +
   5.634 +
   5.635 +(** package setup **)
   5.636 +
   5.637 +(* setup theory *)
   5.638 +
   5.639 +val setup =
   5.640 +  DatatypeRepProofs.distinctness_limit_setup #>
   5.641 +  simproc_setup #>
   5.642 +  trfun_setup #>
   5.643 +  DatatypeInterpretation.init;
   5.644 +
   5.645 +
   5.646 +(* outer syntax *)
   5.647 +
   5.648 +local
   5.649 +
   5.650 +structure P = OuterParse and K = OuterKeyword
   5.651 +
   5.652 +fun prep_datatype_decls args =
   5.653 +  let
   5.654 +    val names = map
   5.655 +      (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
   5.656 +    val specs = map (fn ((((_, vs), t), mx), cons) =>
   5.657 +      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
   5.658 +  in (names, specs) end;
   5.659 +
   5.660 +val parse_datatype_decl =
   5.661 +  (Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
   5.662 +    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix)));
   5.663 +
   5.664 +val parse_datatype_decls = P.and_list1 parse_datatype_decl >> prep_datatype_decls;
   5.665 +
   5.666 +in
   5.667 +
   5.668 +val _ =
   5.669 +  OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
   5.670 +    (parse_datatype_decls >> (fn (names, specs) => Toplevel.theory (datatype_cmd names specs)));
   5.671 +
   5.672 +val _ =
   5.673 +  OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
   5.674 +    (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
   5.675 +      >> (fn (alt_names, ts) => Toplevel.print
   5.676 +           o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
   5.677 +
   5.678 +end;
   5.679 +
   5.680 +
   5.681 +(* document antiquotation *)
   5.682 +
   5.683 +val _ = ThyOutput.antiquotation "datatype" Args.tyname
   5.684 +  (fn {source = src, context = ctxt, ...} => fn dtco =>
   5.685 +    let
   5.686 +      val thy = ProofContext.theory_of ctxt;
   5.687 +      val (vs, cos) = the_datatype_spec thy dtco;
   5.688 +      val ty = Type (dtco, map TFree vs);
   5.689 +      fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
   5.690 +            Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
   5.691 +        | pretty_typ_bracket ty =
   5.692 +            Syntax.pretty_typ ctxt ty;
   5.693 +      fun pretty_constr (co, tys) =
   5.694 +        (Pretty.block o Pretty.breaks)
   5.695 +          (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
   5.696 +            map pretty_typ_bracket tys);
   5.697 +      val pretty_datatype =
   5.698 +        Pretty.block
   5.699 +          (Pretty.command "datatype" :: Pretty.brk 1 ::
   5.700 +           Syntax.pretty_typ ctxt ty ::
   5.701 +           Pretty.str " =" :: Pretty.brk 1 ::
   5.702 +           flat (separate [Pretty.brk 1, Pretty.str "| "]
   5.703 +             (map (single o pretty_constr) cos)));
   5.704 +    in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
   5.705 +
   5.706 +end;
   5.707 +
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Tools/Datatype/datatype_abs_proofs.ML	Tue Jun 23 12:09:30 2009 +0200
     6.3 @@ -0,0 +1,447 @@
     6.4 +(*  Title:      HOL/Tools/datatype_abs_proofs.ML
     6.5 +    Author:     Stefan Berghofer, TU Muenchen
     6.6 +
     6.7 +Proofs and defintions independent of concrete representation
     6.8 +of datatypes  (i.e. requiring only abstract properties such as
     6.9 +injectivity / distinctness of constructors and induction)
    6.10 +
    6.11 + - case distinction (exhaustion) theorems
    6.12 + - characteristic equations for primrec combinators
    6.13 + - characteristic equations for case combinators
    6.14 + - equations for splitting "P (case ...)" expressions
    6.15 + - "nchotomy" and "case_cong" theorems for TFL
    6.16 +*)
    6.17 +
    6.18 +signature DATATYPE_ABS_PROOFS =
    6.19 +sig
    6.20 +  include DATATYPE_COMMON
    6.21 +  val prove_casedist_thms : config -> string list ->
    6.22 +    descr list -> (string * sort) list -> thm ->
    6.23 +    attribute list -> theory -> thm list * theory
    6.24 +  val prove_primrec_thms : config -> string list ->
    6.25 +    descr list -> (string * sort) list ->
    6.26 +      info Symtab.table -> thm list list -> thm list list ->
    6.27 +        simpset -> thm -> theory -> (string list * thm list) * theory
    6.28 +  val prove_case_thms : config -> string list ->
    6.29 +    descr list -> (string * sort) list ->
    6.30 +      string list -> thm list -> theory -> (thm list list * string list) * theory
    6.31 +  val prove_split_thms : config -> string list ->
    6.32 +    descr list -> (string * sort) list ->
    6.33 +      thm list list -> thm list list -> thm list -> thm list list -> theory ->
    6.34 +        (thm * thm) list * theory
    6.35 +  val prove_nchotomys : config -> string list -> descr list ->
    6.36 +    (string * sort) list -> thm list -> theory -> thm list * theory
    6.37 +  val prove_weak_case_congs : string list -> descr list ->
    6.38 +    (string * sort) list -> theory -> thm list * theory
    6.39 +  val prove_case_congs : string list ->
    6.40 +    descr list -> (string * sort) list ->
    6.41 +      thm list -> thm list list -> theory -> thm list * theory
    6.42 +end;
    6.43 +
    6.44 +structure DatatypeAbsProofs: DATATYPE_ABS_PROOFS =
    6.45 +struct
    6.46 +
    6.47 +open DatatypeAux;
    6.48 +
    6.49 +(************************ case distinction theorems ***************************)
    6.50 +
    6.51 +fun prove_casedist_thms (config : config) new_type_names descr sorts induct case_names_exhausts thy =
    6.52 +  let
    6.53 +    val _ = message config "Proving case distinction theorems ...";
    6.54 +
    6.55 +    val descr' = List.concat descr;
    6.56 +    val recTs = get_rec_types descr' sorts;
    6.57 +    val newTs = Library.take (length (hd descr), recTs);
    6.58 +
    6.59 +    val {maxidx, ...} = rep_thm induct;
    6.60 +    val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
    6.61 +
    6.62 +    fun prove_casedist_thm ((i, t), T) =
    6.63 +      let
    6.64 +        val dummyPs = map (fn (Var (_, Type (_, [T', T'']))) =>
    6.65 +          Abs ("z", T', Const ("True", T''))) induct_Ps;
    6.66 +        val P = Abs ("z", T, HOLogic.imp $ HOLogic.mk_eq (Var (("a", maxidx+1), T), Bound 0) $
    6.67 +          Var (("P", 0), HOLogic.boolT))
    6.68 +        val insts = Library.take (i, dummyPs) @ (P::(Library.drop (i + 1, dummyPs)));
    6.69 +        val cert = cterm_of thy;
    6.70 +        val insts' = (map cert induct_Ps) ~~ (map cert insts);
    6.71 +        val induct' = refl RS ((List.nth
    6.72 +          (split_conj_thm (cterm_instantiate insts' induct), i)) RSN (2, rev_mp))
    6.73 +
    6.74 +      in
    6.75 +        SkipProof.prove_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t)
    6.76 +          (fn {prems, ...} => EVERY
    6.77 +            [rtac induct' 1,
    6.78 +             REPEAT (rtac TrueI 1),
    6.79 +             REPEAT ((rtac impI 1) THEN (eresolve_tac prems 1)),
    6.80 +             REPEAT (rtac TrueI 1)])
    6.81 +      end;
    6.82 +
    6.83 +    val casedist_thms = map prove_casedist_thm ((0 upto (length newTs - 1)) ~~
    6.84 +      (DatatypeProp.make_casedists descr sorts) ~~ newTs)
    6.85 +  in
    6.86 +    thy
    6.87 +    |> store_thms_atts "exhaust" new_type_names (map single case_names_exhausts) casedist_thms
    6.88 +  end;
    6.89 +
    6.90 +
    6.91 +(*************************** primrec combinators ******************************)
    6.92 +
    6.93 +fun prove_primrec_thms (config : config) new_type_names descr sorts
    6.94 +    (dt_info : info Symtab.table) constr_inject dist_rewrites dist_ss induct thy =
    6.95 +  let
    6.96 +    val _ = message config "Constructing primrec combinators ...";
    6.97 +
    6.98 +    val big_name = space_implode "_" new_type_names;
    6.99 +    val thy0 = add_path (#flat_names config) big_name thy;
   6.100 +
   6.101 +    val descr' = List.concat descr;
   6.102 +    val recTs = get_rec_types descr' sorts;
   6.103 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
   6.104 +    val newTs = Library.take (length (hd descr), recTs);
   6.105 +
   6.106 +    val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
   6.107 +
   6.108 +    val big_rec_name' = big_name ^ "_rec_set";
   6.109 +    val rec_set_names' =
   6.110 +      if length descr' = 1 then [big_rec_name'] else
   6.111 +        map ((curry (op ^) (big_rec_name' ^ "_")) o string_of_int)
   6.112 +          (1 upto (length descr'));
   6.113 +    val rec_set_names = map (Sign.full_bname thy0) rec_set_names';
   6.114 +
   6.115 +    val (rec_result_Ts, reccomb_fn_Ts) = DatatypeProp.make_primrec_Ts descr sorts used;
   6.116 +
   6.117 +    val rec_set_Ts = map (fn (T1, T2) =>
   6.118 +      reccomb_fn_Ts @ [T1, T2] ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
   6.119 +
   6.120 +    val rec_fns = map (uncurry (mk_Free "f"))
   6.121 +      (reccomb_fn_Ts ~~ (1 upto (length reccomb_fn_Ts)));
   6.122 +    val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
   6.123 +      (rec_set_names' ~~ rec_set_Ts);
   6.124 +    val rec_sets = map (fn c => list_comb (Const c, rec_fns))
   6.125 +      (rec_set_names ~~ rec_set_Ts);
   6.126 +
   6.127 +    (* introduction rules for graph of primrec function *)
   6.128 +
   6.129 +    fun make_rec_intr T rec_set ((rec_intr_ts, l), (cname, cargs)) =
   6.130 +      let
   6.131 +        fun mk_prem ((dt, U), (j, k, prems, t1s, t2s)) =
   6.132 +          let val free1 = mk_Free "x" U j
   6.133 +          in (case (strip_dtyp dt, strip_type U) of
   6.134 +             ((_, DtRec m), (Us, _)) =>
   6.135 +               let
   6.136 +                 val free2 = mk_Free "y" (Us ---> List.nth (rec_result_Ts, m)) k;
   6.137 +                 val i = length Us
   6.138 +               in (j + 1, k + 1, HOLogic.mk_Trueprop (HOLogic.list_all
   6.139 +                     (map (pair "x") Us, List.nth (rec_sets', m) $
   6.140 +                       app_bnds free1 i $ app_bnds free2 i)) :: prems,
   6.141 +                   free1::t1s, free2::t2s)
   6.142 +               end
   6.143 +           | _ => (j + 1, k, prems, free1::t1s, t2s))
   6.144 +          end;
   6.145 +
   6.146 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
   6.147 +        val (_, _, prems, t1s, t2s) = List.foldr mk_prem (1, 1, [], [], []) (cargs ~~ Ts)
   6.148 +
   6.149 +      in (rec_intr_ts @ [Logic.list_implies (prems, HOLogic.mk_Trueprop
   6.150 +        (rec_set $ list_comb (Const (cname, Ts ---> T), t1s) $
   6.151 +          list_comb (List.nth (rec_fns, l), t1s @ t2s)))], l + 1)
   6.152 +      end;
   6.153 +
   6.154 +    val (rec_intr_ts, _) = Library.foldl (fn (x, ((d, T), set_name)) =>
   6.155 +      Library.foldl (make_rec_intr T set_name) (x, #3 (snd d)))
   6.156 +        (([], 0), descr' ~~ recTs ~~ rec_sets');
   6.157 +
   6.158 +    val ({intrs = rec_intrs, elims = rec_elims, ...}, thy1) =
   6.159 +        Inductive.add_inductive_global (serial_string ())
   6.160 +          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
   6.161 +            alt_name = Binding.name big_rec_name', coind = false, no_elim = false, no_ind = true,
   6.162 +            skip_mono = true, fork_mono = false}
   6.163 +          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
   6.164 +          (map dest_Free rec_fns)
   6.165 +          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) [] thy0;
   6.166 +
   6.167 +    (* prove uniqueness and termination of primrec combinators *)
   6.168 +
   6.169 +    val _ = message config "Proving termination and uniqueness of primrec functions ...";
   6.170 +
   6.171 +    fun mk_unique_tac ((tac, intrs), ((((i, (tname, _, constrs)), elim), T), T')) =
   6.172 +      let
   6.173 +        val distinct_tac =
   6.174 +          (if i < length newTs then
   6.175 +             full_simp_tac (HOL_ss addsimps (List.nth (dist_rewrites, i))) 1
   6.176 +           else full_simp_tac dist_ss 1);
   6.177 +
   6.178 +        val inject = map (fn r => r RS iffD1)
   6.179 +          (if i < length newTs then List.nth (constr_inject, i)
   6.180 +            else #inject (the (Symtab.lookup dt_info tname)));
   6.181 +
   6.182 +        fun mk_unique_constr_tac n ((tac, intr::intrs, j), (cname, cargs)) =
   6.183 +          let
   6.184 +            val k = length (List.filter is_rec_type cargs)
   6.185 +
   6.186 +          in (EVERY [DETERM tac,
   6.187 +                REPEAT (etac ex1E 1), rtac ex1I 1,
   6.188 +                DEPTH_SOLVE_1 (ares_tac [intr] 1),
   6.189 +                REPEAT_DETERM_N k (etac thin_rl 1 THEN rotate_tac 1 1),
   6.190 +                etac elim 1,
   6.191 +                REPEAT_DETERM_N j distinct_tac,
   6.192 +                TRY (dresolve_tac inject 1),
   6.193 +                REPEAT (etac conjE 1), hyp_subst_tac 1,
   6.194 +                REPEAT (EVERY [etac allE 1, dtac mp 1, atac 1]),
   6.195 +                TRY (hyp_subst_tac 1),
   6.196 +                rtac refl 1,
   6.197 +                REPEAT_DETERM_N (n - j - 1) distinct_tac],
   6.198 +              intrs, j + 1)
   6.199 +          end;
   6.200 +
   6.201 +        val (tac', intrs', _) = Library.foldl (mk_unique_constr_tac (length constrs))
   6.202 +          ((tac, intrs, 0), constrs);
   6.203 +
   6.204 +      in (tac', intrs') end;
   6.205 +
   6.206 +    val rec_unique_thms =
   6.207 +      let
   6.208 +        val rec_unique_ts = map (fn (((set_t, T1), T2), i) =>
   6.209 +          Const ("Ex1", (T2 --> HOLogic.boolT) --> HOLogic.boolT) $
   6.210 +            absfree ("y", T2, set_t $ mk_Free "x" T1 i $ Free ("y", T2)))
   6.211 +              (rec_sets ~~ recTs ~~ rec_result_Ts ~~ (1 upto length recTs));
   6.212 +        val cert = cterm_of thy1
   6.213 +        val insts = map (fn ((i, T), t) => absfree ("x" ^ (string_of_int i), T, t))
   6.214 +          ((1 upto length recTs) ~~ recTs ~~ rec_unique_ts);
   6.215 +        val induct' = cterm_instantiate ((map cert induct_Ps) ~~
   6.216 +          (map cert insts)) induct;
   6.217 +        val (tac, _) = Library.foldl mk_unique_tac
   6.218 +          (((rtac induct' THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1
   6.219 +              THEN rewrite_goals_tac [mk_meta_eq choice_eq], rec_intrs),
   6.220 +            descr' ~~ rec_elims ~~ recTs ~~ rec_result_Ts);
   6.221 +
   6.222 +      in split_conj_thm (SkipProof.prove_global thy1 [] []
   6.223 +        (HOLogic.mk_Trueprop (mk_conj rec_unique_ts)) (K tac))
   6.224 +      end;
   6.225 +
   6.226 +    val rec_total_thms = map (fn r => r RS theI') rec_unique_thms;
   6.227 +
   6.228 +    (* define primrec combinators *)
   6.229 +
   6.230 +    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
   6.231 +    val reccomb_names = map (Sign.full_bname thy1)
   6.232 +      (if length descr' = 1 then [big_reccomb_name] else
   6.233 +        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
   6.234 +          (1 upto (length descr'))));
   6.235 +    val reccombs = map (fn ((name, T), T') => list_comb
   6.236 +      (Const (name, reccomb_fn_Ts @ [T] ---> T'), rec_fns))
   6.237 +        (reccomb_names ~~ recTs ~~ rec_result_Ts);
   6.238 +
   6.239 +    val (reccomb_defs, thy2) =
   6.240 +      thy1
   6.241 +      |> Sign.add_consts_i (map (fn ((name, T), T') =>
   6.242 +          (Binding.name (Long_Name.base_name name), reccomb_fn_Ts @ [T] ---> T', NoSyn))
   6.243 +          (reccomb_names ~~ recTs ~~ rec_result_Ts))
   6.244 +      |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
   6.245 +          (Binding.name (Long_Name.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
   6.246 +           Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
   6.247 +             set $ Free ("x", T) $ Free ("y", T'))))))
   6.248 +               (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts))
   6.249 +      ||> parent_path (#flat_names config) 
   6.250 +      ||> Theory.checkpoint;
   6.251 +
   6.252 +
   6.253 +    (* prove characteristic equations for primrec combinators *)
   6.254 +
   6.255 +    val _ = message config "Proving characteristic theorems for primrec combinators ..."
   6.256 +
   6.257 +    val rec_thms = map (fn t => SkipProof.prove_global thy2 [] [] t
   6.258 +      (fn _ => EVERY
   6.259 +        [rewrite_goals_tac reccomb_defs,
   6.260 +         rtac the1_equality 1,
   6.261 +         resolve_tac rec_unique_thms 1,
   6.262 +         resolve_tac rec_intrs 1,
   6.263 +         REPEAT (rtac allI 1 ORELSE resolve_tac rec_total_thms 1)]))
   6.264 +           (DatatypeProp.make_primrecs new_type_names descr sorts thy2)
   6.265 +
   6.266 +  in
   6.267 +    thy2
   6.268 +    |> Sign.add_path (space_implode "_" new_type_names)
   6.269 +    |> PureThy.add_thmss [((Binding.name "recs", rec_thms),
   6.270 +         [Nitpick_Const_Simp_Thms.add])]
   6.271 +    ||> Sign.parent_path
   6.272 +    ||> Theory.checkpoint
   6.273 +    |-> (fn thms => pair (reccomb_names, Library.flat thms))
   6.274 +  end;
   6.275 +
   6.276 +
   6.277 +(***************************** case combinators *******************************)
   6.278 +
   6.279 +fun prove_case_thms (config : config) new_type_names descr sorts reccomb_names primrec_thms thy =
   6.280 +  let
   6.281 +    val _ = message config "Proving characteristic theorems for case combinators ...";
   6.282 +
   6.283 +    val thy1 = add_path (#flat_names config) (space_implode "_" new_type_names) thy;
   6.284 +
   6.285 +    val descr' = List.concat descr;
   6.286 +    val recTs = get_rec_types descr' sorts;
   6.287 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
   6.288 +    val newTs = Library.take (length (hd descr), recTs);
   6.289 +    val T' = TFree (Name.variant used "'t", HOLogic.typeS);
   6.290 +
   6.291 +    fun mk_dummyT dt = binder_types (typ_of_dtyp descr' sorts dt) ---> T';
   6.292 +
   6.293 +    val case_dummy_fns = map (fn (_, (_, _, constrs)) => map (fn (_, cargs) =>
   6.294 +      let
   6.295 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
   6.296 +        val Ts' = map mk_dummyT (List.filter is_rec_type cargs)
   6.297 +      in Const (@{const_name undefined}, Ts @ Ts' ---> T')
   6.298 +      end) constrs) descr';
   6.299 +
   6.300 +    val case_names = map (fn s => Sign.full_bname thy1 (s ^ "_case")) new_type_names;
   6.301 +
   6.302 +    (* define case combinators via primrec combinators *)
   6.303 +
   6.304 +    val (case_defs, thy2) = Library.foldl (fn ((defs, thy),
   6.305 +      ((((i, (_, _, constrs)), T), name), recname)) =>
   6.306 +        let
   6.307 +          val (fns1, fns2) = ListPair.unzip (map (fn ((_, cargs), j) =>
   6.308 +            let
   6.309 +              val Ts = map (typ_of_dtyp descr' sorts) cargs;
   6.310 +              val Ts' = Ts @ map mk_dummyT (List.filter is_rec_type cargs);
   6.311 +              val frees' = map (uncurry (mk_Free "x")) (Ts' ~~ (1 upto length Ts'));
   6.312 +              val frees = Library.take (length cargs, frees');
   6.313 +              val free = mk_Free "f" (Ts ---> T') j
   6.314 +            in
   6.315 +             (free, list_abs_free (map dest_Free frees',
   6.316 +               list_comb (free, frees)))
   6.317 +            end) (constrs ~~ (1 upto length constrs)));
   6.318 +
   6.319 +          val caseT = (map (snd o dest_Free) fns1) @ [T] ---> T';
   6.320 +          val fns = (List.concat (Library.take (i, case_dummy_fns))) @
   6.321 +            fns2 @ (List.concat (Library.drop (i + 1, case_dummy_fns)));
   6.322 +          val reccomb = Const (recname, (map fastype_of fns) @ [T] ---> T');
   6.323 +          val decl = ((Binding.name (Long_Name.base_name name), caseT), NoSyn);
   6.324 +          val def = (Binding.name (Long_Name.base_name name ^ "_def"),
   6.325 +            Logic.mk_equals (list_comb (Const (name, caseT), fns1),
   6.326 +              list_comb (reccomb, (List.concat (Library.take (i, case_dummy_fns))) @
   6.327 +                fns2 @ (List.concat (Library.drop (i + 1, case_dummy_fns))) )));
   6.328 +          val ([def_thm], thy') =
   6.329 +            thy
   6.330 +            |> Sign.declare_const [] decl |> snd
   6.331 +            |> (PureThy.add_defs false o map Thm.no_attributes) [def];
   6.332 +
   6.333 +        in (defs @ [def_thm], thy')
   6.334 +        end) (([], thy1), (hd descr) ~~ newTs ~~ case_names ~~
   6.335 +          (Library.take (length newTs, reccomb_names)))
   6.336 +      ||> Theory.checkpoint;
   6.337 +
   6.338 +    val case_thms = map (map (fn t => SkipProof.prove_global thy2 [] [] t
   6.339 +      (fn _ => EVERY [rewrite_goals_tac (case_defs @ map mk_meta_eq primrec_thms), rtac refl 1])))
   6.340 +          (DatatypeProp.make_cases new_type_names descr sorts thy2)
   6.341 +  in
   6.342 +    thy2
   6.343 +    |> Context.the_theory o fold (fold Nitpick_Const_Simp_Thms.add_thm) case_thms
   6.344 +       o Context.Theory
   6.345 +    |> parent_path (#flat_names config)
   6.346 +    |> store_thmss "cases" new_type_names case_thms
   6.347 +    |-> (fn thmss => pair (thmss, case_names))
   6.348 +  end;
   6.349 +
   6.350 +
   6.351 +(******************************* case splitting *******************************)
   6.352 +
   6.353 +fun prove_split_thms (config : config) new_type_names descr sorts constr_inject dist_rewrites
   6.354 +    casedist_thms case_thms thy =
   6.355 +  let
   6.356 +    val _ = message config "Proving equations for case splitting ...";
   6.357 +
   6.358 +    val descr' = flat descr;
   6.359 +    val recTs = get_rec_types descr' sorts;
   6.360 +    val newTs = Library.take (length (hd descr), recTs);
   6.361 +
   6.362 +    fun prove_split_thms ((((((t1, t2), inject), dist_rewrites'),
   6.363 +        exhaustion), case_thms'), T) =
   6.364 +      let
   6.365 +        val cert = cterm_of thy;
   6.366 +        val _ $ (_ $ lhs $ _) = hd (Logic.strip_assums_hyp (hd (prems_of exhaustion)));
   6.367 +        val exhaustion' = cterm_instantiate
   6.368 +          [(cert lhs, cert (Free ("x", T)))] exhaustion;
   6.369 +        val tacf = K (EVERY [rtac exhaustion' 1, ALLGOALS (asm_simp_tac
   6.370 +          (HOL_ss addsimps (dist_rewrites' @ inject @ case_thms')))])
   6.371 +      in
   6.372 +        (SkipProof.prove_global thy [] [] t1 tacf,
   6.373 +         SkipProof.prove_global thy [] [] t2 tacf)
   6.374 +      end;
   6.375 +
   6.376 +    val split_thm_pairs = map prove_split_thms
   6.377 +      ((DatatypeProp.make_splits new_type_names descr sorts thy) ~~ constr_inject ~~
   6.378 +        dist_rewrites ~~ casedist_thms ~~ case_thms ~~ newTs);
   6.379 +
   6.380 +    val (split_thms, split_asm_thms) = ListPair.unzip split_thm_pairs
   6.381 +
   6.382 +  in
   6.383 +    thy
   6.384 +    |> store_thms "split" new_type_names split_thms
   6.385 +    ||>> store_thms "split_asm" new_type_names split_asm_thms
   6.386 +    |-> (fn (thms1, thms2) => pair (thms1 ~~ thms2))
   6.387 +  end;
   6.388 +
   6.389 +fun prove_weak_case_congs new_type_names descr sorts thy =
   6.390 +  let
   6.391 +    fun prove_weak_case_cong t =
   6.392 +       SkipProof.prove_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t)
   6.393 +         (fn {prems, ...} => EVERY [rtac ((hd prems) RS arg_cong) 1])
   6.394 +
   6.395 +    val weak_case_congs = map prove_weak_case_cong (DatatypeProp.make_weak_case_congs
   6.396 +      new_type_names descr sorts thy)
   6.397 +
   6.398 +  in thy |> store_thms "weak_case_cong" new_type_names weak_case_congs end;
   6.399 +
   6.400 +(************************* additional theorems for TFL ************************)
   6.401 +
   6.402 +fun prove_nchotomys (config : config) new_type_names descr sorts casedist_thms thy =
   6.403 +  let
   6.404 +    val _ = message config "Proving additional theorems for TFL ...";
   6.405 +
   6.406 +    fun prove_nchotomy (t, exhaustion) =
   6.407 +      let
   6.408 +        (* For goal i, select the correct disjunct to attack, then prove it *)
   6.409 +        fun tac i 0 = EVERY [TRY (rtac disjI1 i),
   6.410 +              hyp_subst_tac i, REPEAT (rtac exI i), rtac refl i]
   6.411 +          | tac i n = rtac disjI2 i THEN tac i (n - 1)
   6.412 +      in 
   6.413 +        SkipProof.prove_global thy [] [] t (fn _ =>
   6.414 +          EVERY [rtac allI 1,
   6.415 +           exh_tac (K exhaustion) 1,
   6.416 +           ALLGOALS (fn i => tac i (i-1))])
   6.417 +      end;
   6.418 +
   6.419 +    val nchotomys =
   6.420 +      map prove_nchotomy (DatatypeProp.make_nchotomys descr sorts ~~ casedist_thms)
   6.421 +
   6.422 +  in thy |> store_thms "nchotomy" new_type_names nchotomys end;
   6.423 +
   6.424 +fun prove_case_congs new_type_names descr sorts nchotomys case_thms thy =
   6.425 +  let
   6.426 +    fun prove_case_cong ((t, nchotomy), case_rewrites) =
   6.427 +      let
   6.428 +        val (Const ("==>", _) $ tm $ _) = t;
   6.429 +        val (Const ("Trueprop", _) $ (Const ("op =", _) $ _ $ Ma)) = tm;
   6.430 +        val cert = cterm_of thy;
   6.431 +        val nchotomy' = nchotomy RS spec;
   6.432 +        val [v] = Term.add_vars (concl_of nchotomy') [];
   6.433 +        val nchotomy'' = cterm_instantiate [(cert (Var v), cert Ma)] nchotomy'
   6.434 +      in
   6.435 +        SkipProof.prove_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t)
   6.436 +          (fn {prems, ...} => 
   6.437 +            let val simplify = asm_simp_tac (HOL_ss addsimps (prems @ case_rewrites))
   6.438 +            in EVERY [simp_tac (HOL_ss addsimps [hd prems]) 1,
   6.439 +                cut_facts_tac [nchotomy''] 1,
   6.440 +                REPEAT (etac disjE 1 THEN REPEAT (etac exE 1) THEN simplify 1),
   6.441 +                REPEAT (etac exE 1) THEN simplify 1 (* Get last disjunct *)]
   6.442 +            end)
   6.443 +      end;
   6.444 +
   6.445 +    val case_congs = map prove_case_cong (DatatypeProp.make_case_congs
   6.446 +      new_type_names descr sorts thy ~~ nchotomys ~~ case_thms)
   6.447 +
   6.448 +  in thy |> store_thms "case_cong" new_type_names case_congs end;
   6.449 +
   6.450 +end;
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/Datatype/datatype_aux.ML	Tue Jun 23 12:09:30 2009 +0200
     7.3 @@ -0,0 +1,381 @@
     7.4 +(*  Title:      HOL/Tools/datatype_aux.ML
     7.5 +    Author:     Stefan Berghofer, TU Muenchen
     7.6 +
     7.7 +Auxiliary functions for defining datatypes.
     7.8 +*)
     7.9 +
    7.10 +signature DATATYPE_COMMON =
    7.11 +sig
    7.12 +  type config
    7.13 +  val default_config : config
    7.14 +  datatype dtyp =
    7.15 +      DtTFree of string
    7.16 +    | DtType of string * (dtyp list)
    7.17 +    | DtRec of int;
    7.18 +  type descr
    7.19 +  type info
    7.20 +end
    7.21 +
    7.22 +signature DATATYPE_AUX =
    7.23 +sig
    7.24 +  include DATATYPE_COMMON
    7.25 +
    7.26 +  val message : config -> string -> unit
    7.27 +  
    7.28 +  val add_path : bool -> string -> theory -> theory
    7.29 +  val parent_path : bool -> theory -> theory
    7.30 +
    7.31 +  val store_thmss_atts : string -> string list -> attribute list list -> thm list list
    7.32 +    -> theory -> thm list list * theory
    7.33 +  val store_thmss : string -> string list -> thm list list -> theory -> thm list list * theory
    7.34 +  val store_thms_atts : string -> string list -> attribute list list -> thm list
    7.35 +    -> theory -> thm list * theory
    7.36 +  val store_thms : string -> string list -> thm list -> theory -> thm list * theory
    7.37 +
    7.38 +  val split_conj_thm : thm -> thm list
    7.39 +  val mk_conj : term list -> term
    7.40 +  val mk_disj : term list -> term
    7.41 +
    7.42 +  val app_bnds : term -> int -> term
    7.43 +
    7.44 +  val cong_tac : int -> tactic
    7.45 +  val indtac : thm -> string list -> int -> tactic
    7.46 +  val exh_tac : (string -> thm) -> int -> tactic
    7.47 +
    7.48 +  datatype simproc_dist = FewConstrs of thm list
    7.49 +                        | ManyConstrs of thm * simpset;
    7.50 +
    7.51 +
    7.52 +  exception Datatype
    7.53 +  exception Datatype_Empty of string
    7.54 +  val name_of_typ : typ -> string
    7.55 +  val dtyp_of_typ : (string * string list) list -> typ -> dtyp
    7.56 +  val mk_Free : string -> typ -> int -> term
    7.57 +  val is_rec_type : dtyp -> bool
    7.58 +  val typ_of_dtyp : descr -> (string * sort) list -> dtyp -> typ
    7.59 +  val dest_DtTFree : dtyp -> string
    7.60 +  val dest_DtRec : dtyp -> int
    7.61 +  val strip_dtyp : dtyp -> dtyp list * dtyp
    7.62 +  val body_index : dtyp -> int
    7.63 +  val mk_fun_dtyp : dtyp list -> dtyp -> dtyp
    7.64 +  val get_nonrec_types : descr -> (string * sort) list -> typ list
    7.65 +  val get_branching_types : descr -> (string * sort) list -> typ list
    7.66 +  val get_arities : descr -> int list
    7.67 +  val get_rec_types : descr -> (string * sort) list -> typ list
    7.68 +  val interpret_construction : descr -> (string * sort) list
    7.69 +    -> { atyp: typ -> 'a, dtyp: typ list -> int * bool -> string * typ list -> 'a }
    7.70 +    -> ((string * Term.typ list) * (string * 'a list) list) list
    7.71 +  val check_nonempty : descr list -> unit
    7.72 +  val unfold_datatypes : 
    7.73 +    theory -> descr -> (string * sort) list -> info Symtab.table ->
    7.74 +      descr -> int -> descr list * int
    7.75 +end;
    7.76 +
    7.77 +structure DatatypeAux : DATATYPE_AUX =
    7.78 +struct
    7.79 +
    7.80 +(* datatype option flags *)
    7.81 +
    7.82 +type config = { strict: bool, flat_names: bool, quiet: bool };
    7.83 +val default_config : config =
    7.84 +  { strict = true, flat_names = false, quiet = false };
    7.85 +fun message ({ quiet, ...} : config) s =
    7.86 +  if quiet then () else writeln s;
    7.87 +
    7.88 +fun add_path flat_names s = if flat_names then I else Sign.add_path s;
    7.89 +fun parent_path flat_names = if flat_names then I else Sign.parent_path;
    7.90 +
    7.91 +
    7.92 +(* store theorems in theory *)
    7.93 +
    7.94 +fun store_thmss_atts label tnames attss thmss =
    7.95 +  fold_map (fn ((tname, atts), thms) =>
    7.96 +    Sign.add_path tname
    7.97 +    #> PureThy.add_thmss [((Binding.name label, thms), atts)]
    7.98 +    #-> (fn thm::_ => Sign.parent_path #> pair thm)) (tnames ~~ attss ~~ thmss)
    7.99 +  ##> Theory.checkpoint;
   7.100 +
   7.101 +fun store_thmss label tnames = store_thmss_atts label tnames (replicate (length tnames) []);
   7.102 +
   7.103 +fun store_thms_atts label tnames attss thmss =
   7.104 +  fold_map (fn ((tname, atts), thms) =>
   7.105 +    Sign.add_path tname
   7.106 +    #> PureThy.add_thms [((Binding.name label, thms), atts)]
   7.107 +    #-> (fn thm::_ => Sign.parent_path #> pair thm)) (tnames ~~ attss ~~ thmss)
   7.108 +  ##> Theory.checkpoint;
   7.109 +
   7.110 +fun store_thms label tnames = store_thms_atts label tnames (replicate (length tnames) []);
   7.111 +
   7.112 +
   7.113 +(* split theorem thm_1 & ... & thm_n into n theorems *)
   7.114 +
   7.115 +fun split_conj_thm th =
   7.116 +  ((th RS conjunct1)::(split_conj_thm (th RS conjunct2))) handle THM _ => [th];
   7.117 +
   7.118 +val mk_conj = foldr1 (HOLogic.mk_binop "op &");
   7.119 +val mk_disj = foldr1 (HOLogic.mk_binop "op |");
   7.120 +
   7.121 +fun app_bnds t i = list_comb (t, map Bound (i - 1 downto 0));
   7.122 +
   7.123 +
   7.124 +fun cong_tac i st = (case Logic.strip_assums_concl
   7.125 +  (List.nth (prems_of st, i - 1)) of
   7.126 +    _ $ (_ $ (f $ x) $ (g $ y)) =>
   7.127 +      let
   7.128 +        val cong' = Thm.lift_rule (Thm.cprem_of st i) cong;
   7.129 +        val _ $ (_ $ (f' $ x') $ (g' $ y')) =
   7.130 +          Logic.strip_assums_concl (prop_of cong');
   7.131 +        val insts = map (pairself (cterm_of (Thm.theory_of_thm st)) o
   7.132 +          apsnd (curry list_abs (Logic.strip_params (concl_of cong'))) o
   7.133 +            apfst head_of) [(f', f), (g', g), (x', x), (y', y)]
   7.134 +      in compose_tac (false, cterm_instantiate insts cong', 2) i st
   7.135 +        handle THM _ => no_tac st
   7.136 +      end
   7.137 +  | _ => no_tac st);
   7.138 +
   7.139 +(* instantiate induction rule *)
   7.140 +
   7.141 +fun indtac indrule indnames i st =
   7.142 +  let
   7.143 +    val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule));
   7.144 +    val ts' = HOLogic.dest_conj (HOLogic.dest_Trueprop
   7.145 +      (Logic.strip_imp_concl (List.nth (prems_of st, i - 1))));
   7.146 +    val getP = if can HOLogic.dest_imp (hd ts) then
   7.147 +      (apfst SOME) o HOLogic.dest_imp else pair NONE;
   7.148 +    val flt = if null indnames then I else
   7.149 +      filter (fn Free (s, _) => s mem indnames | _ => false);
   7.150 +    fun abstr (t1, t2) = (case t1 of
   7.151 +        NONE => (case flt (OldTerm.term_frees t2) of
   7.152 +            [Free (s, T)] => SOME (absfree (s, T, t2))
   7.153 +          | _ => NONE)
   7.154 +      | SOME (_ $ t') => SOME (Abs ("x", fastype_of t', abstract_over (t', t2))))
   7.155 +    val cert = cterm_of (Thm.theory_of_thm st);
   7.156 +    val insts = List.mapPartial (fn (t, u) => case abstr (getP u) of
   7.157 +        NONE => NONE
   7.158 +      | SOME u' => SOME (t |> getP |> snd |> head_of |> cert, cert u')) (ts ~~ ts');
   7.159 +    val indrule' = cterm_instantiate insts indrule
   7.160 +  in
   7.161 +    rtac indrule' i st
   7.162 +  end;
   7.163 +
   7.164 +(* perform exhaustive case analysis on last parameter of subgoal i *)
   7.165 +
   7.166 +fun exh_tac exh_thm_of i state =
   7.167 +  let
   7.168 +    val thy = Thm.theory_of_thm state;
   7.169 +    val prem = nth (prems_of state) (i - 1);
   7.170 +    val params = Logic.strip_params prem;
   7.171 +    val (_, Type (tname, _)) = hd (rev params);
   7.172 +    val exhaustion = Thm.lift_rule (Thm.cprem_of state i) (exh_thm_of tname);
   7.173 +    val prem' = hd (prems_of exhaustion);
   7.174 +    val _ $ (_ $ lhs $ _) = hd (rev (Logic.strip_assums_hyp prem'));
   7.175 +    val exhaustion' = cterm_instantiate [(cterm_of thy (head_of lhs),
   7.176 +      cterm_of thy (List.foldr (fn ((_, T), t) => Abs ("z", T, t))
   7.177 +        (Bound 0) params))] exhaustion
   7.178 +  in compose_tac (false, exhaustion', nprems_of exhaustion) i state
   7.179 +  end;
   7.180 +
   7.181 +(* handling of distinctness theorems *)
   7.182 +
   7.183 +datatype simproc_dist = FewConstrs of thm list
   7.184 +                      | ManyConstrs of thm * simpset;
   7.185 +
   7.186 +(********************** Internal description of datatypes *********************)
   7.187 +
   7.188 +datatype dtyp =
   7.189 +    DtTFree of string
   7.190 +  | DtType of string * (dtyp list)
   7.191 +  | DtRec of int;
   7.192 +
   7.193 +(* information about datatypes *)
   7.194 +
   7.195 +(* index, datatype name, type arguments, constructor name, types of constructor's arguments *)
   7.196 +type descr = (int * (string * dtyp list * (string * dtyp list) list)) list;
   7.197 +
   7.198 +type info =
   7.199 +  {index : int,
   7.200 +   alt_names : string list option,
   7.201 +   descr : descr,
   7.202 +   sorts : (string * sort) list,
   7.203 +   rec_names : string list,
   7.204 +   rec_rewrites : thm list,
   7.205 +   case_name : string,
   7.206 +   case_rewrites : thm list,
   7.207 +   induction : thm,
   7.208 +   exhaustion : thm,
   7.209 +   distinct : simproc_dist,
   7.210 +   inject : thm list,
   7.211 +   nchotomy : thm,
   7.212 +   case_cong : thm,
   7.213 +   weak_case_cong : thm};
   7.214 +
   7.215 +fun mk_Free s T i = Free (s ^ (string_of_int i), T);
   7.216 +
   7.217 +fun subst_DtTFree _ substs (T as (DtTFree name)) =
   7.218 +      AList.lookup (op =) substs name |> the_default T
   7.219 +  | subst_DtTFree i substs (DtType (name, ts)) =
   7.220 +      DtType (name, map (subst_DtTFree i substs) ts)
   7.221 +  | subst_DtTFree i _ (DtRec j) = DtRec (i + j);
   7.222 +
   7.223 +exception Datatype;
   7.224 +exception Datatype_Empty of string;
   7.225 +
   7.226 +fun dest_DtTFree (DtTFree a) = a
   7.227 +  | dest_DtTFree _ = raise Datatype;
   7.228 +
   7.229 +fun dest_DtRec (DtRec i) = i
   7.230 +  | dest_DtRec _ = raise Datatype;
   7.231 +
   7.232 +fun is_rec_type (DtType (_, dts)) = exists is_rec_type dts
   7.233 +  | is_rec_type (DtRec _) = true
   7.234 +  | is_rec_type _ = false;
   7.235 +
   7.236 +fun strip_dtyp (DtType ("fun", [T, U])) = apfst (cons T) (strip_dtyp U)
   7.237 +  | strip_dtyp T = ([], T);
   7.238 +
   7.239 +val body_index = dest_DtRec o snd o strip_dtyp;
   7.240 +
   7.241 +fun mk_fun_dtyp [] U = U
   7.242 +  | mk_fun_dtyp (T :: Ts) U = DtType ("fun", [T, mk_fun_dtyp Ts U]);
   7.243 +
   7.244 +fun name_of_typ (Type (s, Ts)) =
   7.245 +      let val s' = Long_Name.base_name s
   7.246 +      in space_implode "_" (List.filter (not o equal "") (map name_of_typ Ts) @
   7.247 +        [if Syntax.is_identifier s' then s' else "x"])
   7.248 +      end
   7.249 +  | name_of_typ _ = "";
   7.250 +
   7.251 +fun dtyp_of_typ _ (TFree (n, _)) = DtTFree n
   7.252 +  | dtyp_of_typ _ (TVar _) = error "Illegal schematic type variable(s)"
   7.253 +  | dtyp_of_typ new_dts (Type (tname, Ts)) =
   7.254 +      (case AList.lookup (op =) new_dts tname of
   7.255 +         NONE => DtType (tname, map (dtyp_of_typ new_dts) Ts)
   7.256 +       | SOME vs => if map (try (fst o dest_TFree)) Ts = map SOME vs then
   7.257 +             DtRec (find_index (curry op = tname o fst) new_dts)
   7.258 +           else error ("Illegal occurrence of recursive type " ^ tname));
   7.259 +
   7.260 +fun typ_of_dtyp descr sorts (DtTFree a) = TFree (a, (the o AList.lookup (op =) sorts) a)
   7.261 +  | typ_of_dtyp descr sorts (DtRec i) =
   7.262 +      let val (s, ds, _) = (the o AList.lookup (op =) descr) i
   7.263 +      in Type (s, map (typ_of_dtyp descr sorts) ds) end
   7.264 +  | typ_of_dtyp descr sorts (DtType (s, ds)) =
   7.265 +      Type (s, map (typ_of_dtyp descr sorts) ds);
   7.266 +
   7.267 +(* find all non-recursive types in datatype description *)
   7.268 +
   7.269 +fun get_nonrec_types descr sorts =
   7.270 +  map (typ_of_dtyp descr sorts) (Library.foldl (fn (Ts, (_, (_, _, constrs))) =>
   7.271 +    Library.foldl (fn (Ts', (_, cargs)) =>
   7.272 +      filter_out is_rec_type cargs union Ts') (Ts, constrs)) ([], descr));
   7.273 +
   7.274 +(* get all recursive types in datatype description *)
   7.275 +
   7.276 +fun get_rec_types descr sorts = map (fn (_ , (s, ds, _)) =>
   7.277 +  Type (s, map (typ_of_dtyp descr sorts) ds)) descr;
   7.278 +
   7.279 +(* get all branching types *)
   7.280 +
   7.281 +fun get_branching_types descr sorts =
   7.282 +  map (typ_of_dtyp descr sorts) (fold (fn (_, (_, _, constrs)) =>
   7.283 +    fold (fn (_, cargs) => fold (strip_dtyp #> fst #> fold (insert op =)) cargs)
   7.284 +      constrs) descr []);
   7.285 +
   7.286 +fun get_arities descr = fold (fn (_, (_, _, constrs)) =>
   7.287 +  fold (fn (_, cargs) => fold (insert op =) (map (length o fst o strip_dtyp)
   7.288 +    (List.filter is_rec_type cargs))) constrs) descr [];
   7.289 +
   7.290 +(* interpret construction of datatype *)
   7.291 +
   7.292 +fun interpret_construction descr vs { atyp, dtyp } =
   7.293 +  let
   7.294 +    val typ_of_dtyp = typ_of_dtyp descr vs;
   7.295 +    fun interpT dT = case strip_dtyp dT
   7.296 +     of (dTs, DtRec l) =>
   7.297 +          let
   7.298 +            val (tyco, dTs', _) = (the o AList.lookup (op =) descr) l;
   7.299 +            val Ts = map typ_of_dtyp dTs;
   7.300 +            val Ts' = map typ_of_dtyp dTs';
   7.301 +            val is_proper = forall (can dest_TFree) Ts';
   7.302 +          in dtyp Ts (l, is_proper) (tyco, Ts') end
   7.303 +      | _ => atyp (typ_of_dtyp dT);
   7.304 +    fun interpC (c, dTs) = (c, map interpT dTs);
   7.305 +    fun interpD (_, (tyco, dTs, cs)) = ((tyco, map typ_of_dtyp dTs), map interpC cs);
   7.306 +  in map interpD descr end;
   7.307 +
   7.308 +(* nonemptiness check for datatypes *)
   7.309 +
   7.310 +fun check_nonempty descr =
   7.311 +  let
   7.312 +    val descr' = List.concat descr;
   7.313 +    fun is_nonempty_dt is i =
   7.314 +      let
   7.315 +        val (_, _, constrs) = (the o AList.lookup (op =) descr') i;
   7.316 +        fun arg_nonempty (_, DtRec i) = if i mem is then false
   7.317 +              else is_nonempty_dt (i::is) i
   7.318 +          | arg_nonempty _ = true;
   7.319 +      in exists ((forall (arg_nonempty o strip_dtyp)) o snd) constrs
   7.320 +      end
   7.321 +  in assert_all (fn (i, _) => is_nonempty_dt [i] i) (hd descr)
   7.322 +    (fn (_, (s, _, _)) => raise Datatype_Empty s)
   7.323 +  end;
   7.324 +
   7.325 +(* unfold a list of mutually recursive datatype specifications *)
   7.326 +(* all types of the form DtType (dt_name, [..., DtRec _, ...]) *)
   7.327 +(* need to be unfolded                                         *)
   7.328 +
   7.329 +fun unfold_datatypes sign orig_descr sorts (dt_info : info Symtab.table) descr i =
   7.330 +  let
   7.331 +    fun typ_error T msg = error ("Non-admissible type expression\n" ^
   7.332 +      Syntax.string_of_typ_global sign (typ_of_dtyp (orig_descr @ descr) sorts T) ^ "\n" ^ msg);
   7.333 +
   7.334 +    fun get_dt_descr T i tname dts =
   7.335 +      (case Symtab.lookup dt_info tname of
   7.336 +         NONE => typ_error T (tname ^ " is not a datatype - can't use it in\
   7.337 +           \ nested recursion")
   7.338 +       | (SOME {index, descr, ...}) =>
   7.339 +           let val (_, vars, _) = (the o AList.lookup (op =) descr) index;
   7.340 +               val subst = ((map dest_DtTFree vars) ~~ dts) handle Library.UnequalLengths =>
   7.341 +                 typ_error T ("Type constructor " ^ tname ^ " used with wrong\
   7.342 +                  \ number of arguments")
   7.343 +           in (i + index, map (fn (j, (tn, args, cs)) => (i + j,
   7.344 +             (tn, map (subst_DtTFree i subst) args,
   7.345 +              map (apsnd (map (subst_DtTFree i subst))) cs))) descr)
   7.346 +           end);
   7.347 +
   7.348 +    (* unfold a single constructor argument *)
   7.349 +
   7.350 +    fun unfold_arg ((i, Ts, descrs), T) =
   7.351 +      if is_rec_type T then
   7.352 +        let val (Us, U) = strip_dtyp T
   7.353 +        in if exists is_rec_type Us then
   7.354 +            typ_error T "Non-strictly positive recursive occurrence of type"
   7.355 +          else (case U of
   7.356 +              DtType (tname, dts) =>  
   7.357 +                let
   7.358 +                  val (index, descr) = get_dt_descr T i tname dts;
   7.359 +                  val (descr', i') = unfold_datatypes sign orig_descr sorts
   7.360 +                    dt_info descr (i + length descr)
   7.361 +                in (i', Ts @ [mk_fun_dtyp Us (DtRec index)], descrs @ descr') end
   7.362 +            | _ => (i, Ts @ [T], descrs))
   7.363 +        end
   7.364 +      else (i, Ts @ [T], descrs);
   7.365 +
   7.366 +    (* unfold a constructor *)
   7.367 +
   7.368 +    fun unfold_constr ((i, constrs, descrs), (cname, cargs)) =
   7.369 +      let val (i', cargs', descrs') = Library.foldl unfold_arg ((i, [], descrs), cargs)
   7.370 +      in (i', constrs @ [(cname, cargs')], descrs') end;
   7.371 +
   7.372 +    (* unfold a single datatype *)
   7.373 +
   7.374 +    fun unfold_datatype ((i, dtypes, descrs), (j, (tname, tvars, constrs))) =
   7.375 +      let val (i', constrs', descrs') =
   7.376 +        Library.foldl unfold_constr ((i, [], descrs), constrs)
   7.377 +      in (i', dtypes @ [(j, (tname, tvars, constrs'))], descrs')
   7.378 +      end;
   7.379 +
   7.380 +    val (i', descr', descrs) = Library.foldl unfold_datatype ((i, [],[]), descr);
   7.381 +
   7.382 +  in (descr' :: descrs, i') end;
   7.383 +
   7.384 +end;
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/Datatype/datatype_case.ML	Tue Jun 23 12:09:30 2009 +0200
     8.3 @@ -0,0 +1,469 @@
     8.4 +(*  Title:      HOL/Tools/datatype_case.ML
     8.5 +    Author:     Konrad Slind, Cambridge University Computer Laboratory
     8.6 +    Author:     Stefan Berghofer, TU Muenchen
     8.7 +
     8.8 +Nested case expressions on datatypes.
     8.9 +*)
    8.10 +
    8.11 +signature DATATYPE_CASE =
    8.12 +sig
    8.13 +  val make_case: (string -> DatatypeAux.info option) ->
    8.14 +    Proof.context -> bool -> string list -> term -> (term * term) list ->
    8.15 +    term * (term * (int * bool)) list
    8.16 +  val dest_case: (string -> DatatypeAux.info option) -> bool ->
    8.17 +    string list -> term -> (term * (term * term) list) option
    8.18 +  val strip_case: (string -> DatatypeAux.info option) -> bool ->
    8.19 +    term -> (term * (term * term) list) option
    8.20 +  val case_tr: bool -> (theory -> string -> DatatypeAux.info option)
    8.21 +    -> Proof.context -> term list -> term
    8.22 +  val case_tr': (theory -> string -> DatatypeAux.info option) ->
    8.23 +    string -> Proof.context -> term list -> term
    8.24 +end;
    8.25 +
    8.26 +structure DatatypeCase : DATATYPE_CASE =
    8.27 +struct
    8.28 +
    8.29 +exception CASE_ERROR of string * int;
    8.30 +
    8.31 +fun match_type thy pat ob = Sign.typ_match thy (pat, ob) Vartab.empty;
    8.32 +
    8.33 +(*---------------------------------------------------------------------------
    8.34 + * Get information about datatypes
    8.35 + *---------------------------------------------------------------------------*)
    8.36 +
    8.37 +fun ty_info (tab : string -> DatatypeAux.info option) s =
    8.38 +  case tab s of
    8.39 +    SOME {descr, case_name, index, sorts, ...} =>
    8.40 +      let
    8.41 +        val (_, (tname, dts, constrs)) = nth descr index;
    8.42 +        val mk_ty = DatatypeAux.typ_of_dtyp descr sorts;
    8.43 +        val T = Type (tname, map mk_ty dts)
    8.44 +      in
    8.45 +        SOME {case_name = case_name,
    8.46 +          constructors = map (fn (cname, dts') =>
    8.47 +            Const (cname, Logic.varifyT (map mk_ty dts' ---> T))) constrs}
    8.48 +      end
    8.49 +  | NONE => NONE;
    8.50 +
    8.51 +
    8.52 +(*---------------------------------------------------------------------------
    8.53 + * Each pattern carries with it a tag (i,b) where
    8.54 + * i is the clause it came from and
    8.55 + * b=true indicates that clause was given by the user
    8.56 + * (or is an instantiation of a user supplied pattern)
    8.57 + * b=false --> i = ~1
    8.58 + *---------------------------------------------------------------------------*)
    8.59 +
    8.60 +fun pattern_subst theta (tm, x) = (subst_free theta tm, x);
    8.61 +
    8.62 +fun row_of_pat x = fst (snd x);
    8.63 +
    8.64 +fun add_row_used ((prfx, pats), (tm, tag)) =
    8.65 +  fold Term.add_free_names (tm :: pats @ prfx);
    8.66 +
    8.67 +(* try to preserve names given by user *)
    8.68 +fun default_names names ts =
    8.69 +  map (fn ("", Free (name', _)) => name' | (name, _) => name) (names ~~ ts);
    8.70 +
    8.71 +fun strip_constraints (Const ("_constrain", _) $ t $ tT) =
    8.72 +      strip_constraints t ||> cons tT
    8.73 +  | strip_constraints t = (t, []);
    8.74 +
    8.75 +fun mk_fun_constrain tT t = Syntax.const "_constrain" $ t $
    8.76 +  (Syntax.free "fun" $ tT $ Syntax.free "dummy");
    8.77 +
    8.78 +
    8.79 +(*---------------------------------------------------------------------------
    8.80 + * Produce an instance of a constructor, plus genvars for its arguments.
    8.81 + *---------------------------------------------------------------------------*)
    8.82 +fun fresh_constr ty_match ty_inst colty used c =
    8.83 +  let
    8.84 +    val (_, Ty) = dest_Const c
    8.85 +    val Ts = binder_types Ty;
    8.86 +    val names = Name.variant_list used
    8.87 +      (DatatypeProp.make_tnames (map Logic.unvarifyT Ts));
    8.88 +    val ty = body_type Ty;
    8.89 +    val ty_theta = ty_match ty colty handle Type.TYPE_MATCH =>
    8.90 +      raise CASE_ERROR ("type mismatch", ~1)
    8.91 +    val c' = ty_inst ty_theta c
    8.92 +    val gvars = map (ty_inst ty_theta o Free) (names ~~ Ts)
    8.93 +  in (c', gvars)
    8.94 +  end;
    8.95 +
    8.96 +
    8.97 +(*---------------------------------------------------------------------------
    8.98 + * Goes through a list of rows and picks out the ones beginning with a
    8.99 + * pattern with constructor = name.
   8.100 + *---------------------------------------------------------------------------*)
   8.101 +fun mk_group (name, T) rows =
   8.102 +  let val k = length (binder_types T)
   8.103 +  in fold (fn (row as ((prfx, p :: rst), rhs as (_, (i, _)))) =>
   8.104 +    fn ((in_group, not_in_group), (names, cnstrts)) => (case strip_comb p of
   8.105 +        (Const (name', _), args) =>
   8.106 +          if name = name' then
   8.107 +            if length args = k then
   8.108 +              let val (args', cnstrts') = split_list (map strip_constraints args)
   8.109 +              in
   8.110 +                ((((prfx, args' @ rst), rhs) :: in_group, not_in_group),
   8.111 +                 (default_names names args', map2 append cnstrts cnstrts'))
   8.112 +              end
   8.113 +            else raise CASE_ERROR
   8.114 +              ("Wrong number of arguments for constructor " ^ name, i)
   8.115 +          else ((in_group, row :: not_in_group), (names, cnstrts))
   8.116 +      | _ => raise CASE_ERROR ("Not a constructor pattern", i)))
   8.117 +    rows (([], []), (replicate k "", replicate k [])) |>> pairself rev
   8.118 +  end;
   8.119 +
   8.120 +(*---------------------------------------------------------------------------
   8.121 + * Partition the rows. Not efficient: we should use hashing.
   8.122 + *---------------------------------------------------------------------------*)
   8.123 +fun partition _ _ _ _ _ _ _ [] = raise CASE_ERROR ("partition: no rows", ~1)
   8.124 +  | partition ty_match ty_inst type_of used constructors colty res_ty
   8.125 +        (rows as (((prfx, _ :: rstp), _) :: _)) =
   8.126 +      let
   8.127 +        fun part {constrs = [], rows = [], A} = rev A
   8.128 +          | part {constrs = [], rows = (_, (_, (i, _))) :: _, A} =
   8.129 +              raise CASE_ERROR ("Not a constructor pattern", i)
   8.130 +          | part {constrs = c :: crst, rows, A} =
   8.131 +              let
   8.132 +                val ((in_group, not_in_group), (names, cnstrts)) =
   8.133 +                  mk_group (dest_Const c) rows;
   8.134 +                val used' = fold add_row_used in_group used;
   8.135 +                val (c', gvars) = fresh_constr ty_match ty_inst colty used' c;
   8.136 +                val in_group' =
   8.137 +                  if null in_group  (* Constructor not given *)
   8.138 +                  then
   8.139 +                    let
   8.140 +                      val Ts = map type_of rstp;
   8.141 +                      val xs = Name.variant_list
   8.142 +                        (fold Term.add_free_names gvars used')
   8.143 +                        (replicate (length rstp) "x")
   8.144 +                    in
   8.145 +                      [((prfx, gvars @ map Free (xs ~~ Ts)),
   8.146 +                        (Const ("HOL.undefined", res_ty), (~1, false)))]
   8.147 +                    end
   8.148 +                  else in_group
   8.149 +              in
   8.150 +                part{constrs = crst,
   8.151 +                  rows = not_in_group,
   8.152 +                  A = {constructor = c',
   8.153 +                    new_formals = gvars,
   8.154 +                    names = names,
   8.155 +                    constraints = cnstrts,
   8.156 +                    group = in_group'} :: A}
   8.157 +              end
   8.158 +      in part {constrs = constructors, rows = rows, A = []}
   8.159 +      end;
   8.160 +
   8.161 +(*---------------------------------------------------------------------------
   8.162 + * Misc. routines used in mk_case
   8.163 + *---------------------------------------------------------------------------*)
   8.164 +
   8.165 +fun mk_pat ((c, c'), l) =
   8.166 +  let
   8.167 +    val L = length (binder_types (fastype_of c))
   8.168 +    fun build (prfx, tag, plist) =
   8.169 +      let val (args, plist') = chop L plist
   8.170 +      in (prfx, tag, list_comb (c', args) :: plist') end
   8.171 +  in map build l end;
   8.172 +
   8.173 +fun v_to_prfx (prfx, v::pats) = (v::prfx,pats)
   8.174 +  | v_to_prfx _ = raise CASE_ERROR ("mk_case: v_to_prfx", ~1);
   8.175 +
   8.176 +fun v_to_pats (v::prfx,tag, pats) = (prfx, tag, v::pats)
   8.177 +  | v_to_pats _ = raise CASE_ERROR ("mk_case: v_to_pats", ~1);
   8.178 +
   8.179 +
   8.180 +(*----------------------------------------------------------------------------
   8.181 + * Translation of pattern terms into nested case expressions.
   8.182 + *
   8.183 + * This performs the translation and also builds the full set of patterns.
   8.184 + * Thus it supports the construction of induction theorems even when an
   8.185 + * incomplete set of patterns is given.
   8.186 + *---------------------------------------------------------------------------*)
   8.187 +
   8.188 +fun mk_case tab ctxt ty_match ty_inst type_of used range_ty =
   8.189 +  let
   8.190 +    val name = Name.variant used "a";
   8.191 +    fun expand constructors used ty ((_, []), _) =
   8.192 +          raise CASE_ERROR ("mk_case: expand_var_row", ~1)
   8.193 +      | expand constructors used ty (row as ((prfx, p :: rst), rhs)) =
   8.194 +          if is_Free p then
   8.195 +            let
   8.196 +              val used' = add_row_used row used;
   8.197 +              fun expnd c =
   8.198 +                let val capp =
   8.199 +                  list_comb (fresh_constr ty_match ty_inst ty used' c)
   8.200 +                in ((prfx, capp :: rst), pattern_subst [(p, capp)] rhs)
   8.201 +                end
   8.202 +            in map expnd constructors end
   8.203 +          else [row]
   8.204 +    fun mk {rows = [], ...} = raise CASE_ERROR ("no rows", ~1)
   8.205 +      | mk {path = [], rows = ((prfx, []), (tm, tag)) :: _} =  (* Done *)
   8.206 +          ([(prfx, tag, [])], tm)
   8.207 +      | mk {path, rows as ((row as ((_, [Free _]), _)) :: _ :: _)} =
   8.208 +          mk {path = path, rows = [row]}
   8.209 +      | mk {path = u :: rstp, rows as ((_, _ :: _), _) :: _} =
   8.210 +          let val col0 = map (fn ((_, p :: _), (_, (i, _))) => (p, i)) rows
   8.211 +          in case Option.map (apfst head_of)
   8.212 +            (find_first (not o is_Free o fst) col0) of
   8.213 +              NONE =>
   8.214 +                let
   8.215 +                  val rows' = map (fn ((v, _), row) => row ||>
   8.216 +                    pattern_subst [(v, u)] |>> v_to_prfx) (col0 ~~ rows);
   8.217 +                  val (pref_patl, tm) = mk {path = rstp, rows = rows'}
   8.218 +                in (map v_to_pats pref_patl, tm) end
   8.219 +            | SOME (Const (cname, cT), i) => (case ty_info tab cname of
   8.220 +                NONE => raise CASE_ERROR ("Not a datatype constructor: " ^ cname, i)
   8.221 +              | SOME {case_name, constructors} =>
   8.222 +                let
   8.223 +                  val pty = body_type cT;
   8.224 +                  val used' = fold Term.add_free_names rstp used;
   8.225 +                  val nrows = maps (expand constructors used' pty) rows;
   8.226 +                  val subproblems = partition ty_match ty_inst type_of used'
   8.227 +                    constructors pty range_ty nrows;
   8.228 +                  val new_formals = map #new_formals subproblems
   8.229 +                  val constructors' = map #constructor subproblems
   8.230 +                  val news = map (fn {new_formals, group, ...} =>
   8.231 +                    {path = new_formals @ rstp, rows = group}) subproblems;
   8.232 +                  val (pat_rect, dtrees) = split_list (map mk news);
   8.233 +                  val case_functions = map2
   8.234 +                    (fn {new_formals, names, constraints, ...} =>
   8.235 +                       fold_rev (fn ((x as Free (_, T), s), cnstrts) => fn t =>
   8.236 +                         Abs (if s = "" then name else s, T,
   8.237 +                           abstract_over (x, t)) |>
   8.238 +                         fold mk_fun_constrain cnstrts)
   8.239 +                           (new_formals ~~ names ~~ constraints))
   8.240 +                    subproblems dtrees;
   8.241 +                  val types = map type_of (case_functions @ [u]);
   8.242 +                  val case_const = Const (case_name, types ---> range_ty)
   8.243 +                  val tree = list_comb (case_const, case_functions @ [u])
   8.244 +                  val pat_rect1 = flat (map mk_pat
   8.245 +                    (constructors ~~ constructors' ~~ pat_rect))
   8.246 +                in (pat_rect1, tree)
   8.247 +                end)
   8.248 +            | SOME (t, i) => raise CASE_ERROR ("Not a datatype constructor: " ^
   8.249 +                Syntax.string_of_term ctxt t, i)
   8.250 +          end
   8.251 +      | mk _ = raise CASE_ERROR ("Malformed row matrix", ~1)
   8.252 +  in mk
   8.253 +  end;
   8.254 +
   8.255 +fun case_error s = error ("Error in case expression:\n" ^ s);
   8.256 +
   8.257 +(* Repeated variable occurrences in a pattern are not allowed. *)
   8.258 +fun no_repeat_vars ctxt pat = fold_aterms
   8.259 +  (fn x as Free (s, _) => (fn xs =>
   8.260 +        if member op aconv xs x then
   8.261 +          case_error (quote s ^ " occurs repeatedly in the pattern " ^
   8.262 +            quote (Syntax.string_of_term ctxt pat))
   8.263 +        else x :: xs)
   8.264 +    | _ => I) pat [];
   8.265 +
   8.266 +fun gen_make_case ty_match ty_inst type_of tab ctxt err used x clauses =
   8.267 +  let
   8.268 +    fun string_of_clause (pat, rhs) = Syntax.string_of_term ctxt
   8.269 +      (Syntax.const "_case1" $ pat $ rhs);
   8.270 +    val _ = map (no_repeat_vars ctxt o fst) clauses;
   8.271 +    val rows = map_index (fn (i, (pat, rhs)) =>
   8.272 +      (([], [pat]), (rhs, (i, true)))) clauses;
   8.273 +    val rangeT = (case distinct op = (map (type_of o snd) clauses) of
   8.274 +        [] => case_error "no clauses given"
   8.275 +      | [T] => T
   8.276 +      | _ => case_error "all cases must have the same result type");
   8.277 +    val used' = fold add_row_used rows used;
   8.278 +    val (patts, case_tm) = mk_case tab ctxt ty_match ty_inst type_of
   8.279 +        used' rangeT {path = [x], rows = rows}
   8.280 +      handle CASE_ERROR (msg, i) => case_error (msg ^
   8.281 +        (if i < 0 then ""
   8.282 +         else "\nIn clause\n" ^ string_of_clause (nth clauses i)));
   8.283 +    val patts1 = map
   8.284 +      (fn (_, tag, [pat]) => (pat, tag)
   8.285 +        | _ => case_error "error in pattern-match translation") patts;
   8.286 +    val patts2 = Library.sort (Library.int_ord o Library.pairself row_of_pat) patts1
   8.287 +    val finals = map row_of_pat patts2
   8.288 +    val originals = map (row_of_pat o #2) rows
   8.289 +    val _ = case originals \\ finals of
   8.290 +        [] => ()
   8.291 +      | is => (if err then case_error else warning)
   8.292 +          ("The following clauses are redundant (covered by preceding clauses):\n" ^
   8.293 +           cat_lines (map (string_of_clause o nth clauses) is));
   8.294 +  in
   8.295 +    (case_tm, patts2)
   8.296 +  end;
   8.297 +
   8.298 +fun make_case tab ctxt = gen_make_case
   8.299 +  (match_type (ProofContext.theory_of ctxt)) Envir.subst_TVars fastype_of tab ctxt;
   8.300 +val make_case_untyped = gen_make_case (K (K Vartab.empty))
   8.301 +  (K (Term.map_types (K dummyT))) (K dummyT);
   8.302 +
   8.303 +
   8.304 +(* parse translation *)
   8.305 +
   8.306 +fun case_tr err tab_of ctxt [t, u] =
   8.307 +    let
   8.308 +      val thy = ProofContext.theory_of ctxt;
   8.309 +      (* replace occurrences of dummy_pattern by distinct variables *)
   8.310 +      (* internalize constant names                                 *)
   8.311 +      fun prep_pat ((c as Const ("_constrain", _)) $ t $ tT) used =
   8.312 +            let val (t', used') = prep_pat t used
   8.313 +            in (c $ t' $ tT, used') end
   8.314 +        | prep_pat (Const ("dummy_pattern", T)) used =
   8.315 +            let val x = Name.variant used "x"
   8.316 +            in (Free (x, T), x :: used) end
   8.317 +        | prep_pat (Const (s, T)) used =
   8.318 +            (case try (unprefix Syntax.constN) s of
   8.319 +               SOME c => (Const (c, T), used)
   8.320 +             | NONE => (Const (Sign.intern_const thy s, T), used))
   8.321 +        | prep_pat (v as Free (s, T)) used =
   8.322 +            let val s' = Sign.intern_const thy s
   8.323 +            in
   8.324 +              if Sign.declared_const thy s' then
   8.325 +                (Const (s', T), used)
   8.326 +              else (v, used)
   8.327 +            end
   8.328 +        | prep_pat (t $ u) used =
   8.329 +            let
   8.330 +              val (t', used') = prep_pat t used;
   8.331 +              val (u', used'') = prep_pat u used'
   8.332 +            in
   8.333 +              (t' $ u', used'')
   8.334 +            end
   8.335 +        | prep_pat t used = case_error ("Bad pattern: " ^ Syntax.string_of_term ctxt t);
   8.336 +      fun dest_case1 (t as Const ("_case1", _) $ l $ r) =
   8.337 +            let val (l', cnstrts) = strip_constraints l
   8.338 +            in ((fst (prep_pat l' (Term.add_free_names t [])), r), cnstrts)
   8.339 +            end
   8.340 +        | dest_case1 t = case_error "dest_case1";
   8.341 +      fun dest_case2 (Const ("_case2", _) $ t $ u) = t :: dest_case2 u
   8.342 +        | dest_case2 t = [t];
   8.343 +      val (cases, cnstrts) = split_list (map dest_case1 (dest_case2 u));
   8.344 +      val (case_tm, _) = make_case_untyped (tab_of thy) ctxt err []
   8.345 +        (fold (fn tT => fn t => Syntax.const "_constrain" $ t $ tT)
   8.346 +           (flat cnstrts) t) cases;
   8.347 +    in case_tm end
   8.348 +  | case_tr _ _ _ ts = case_error "case_tr";
   8.349 +
   8.350 +
   8.351 +(*---------------------------------------------------------------------------
   8.352 + * Pretty printing of nested case expressions
   8.353 + *---------------------------------------------------------------------------*)
   8.354 +
   8.355 +(* destruct one level of pattern matching *)
   8.356 +
   8.357 +fun gen_dest_case name_of type_of tab d used t =
   8.358 +  case apfst name_of (strip_comb t) of
   8.359 +    (SOME cname, ts as _ :: _) =>
   8.360 +      let
   8.361 +        val (fs, x) = split_last ts;
   8.362 +        fun strip_abs i t =
   8.363 +          let
   8.364 +            val zs = strip_abs_vars t;
   8.365 +            val _ = if length zs < i then raise CASE_ERROR ("", 0) else ();
   8.366 +            val (xs, ys) = chop i zs;
   8.367 +            val u = list_abs (ys, strip_abs_body t);
   8.368 +            val xs' = map Free (Name.variant_list (OldTerm.add_term_names (u, used))
   8.369 +              (map fst xs) ~~ map snd xs)
   8.370 +          in (xs', subst_bounds (rev xs', u)) end;
   8.371 +        fun is_dependent i t =
   8.372 +          let val k = length (strip_abs_vars t) - i
   8.373 +          in k < 0 orelse exists (fn j => j >= k)
   8.374 +            (loose_bnos (strip_abs_body t))
   8.375 +          end;
   8.376 +        fun count_cases (_, _, true) = I
   8.377 +          | count_cases (c, (_, body), false) =
   8.378 +              AList.map_default op aconv (body, []) (cons c);
   8.379 +        val is_undefined = name_of #> equal (SOME "HOL.undefined");
   8.380 +        fun mk_case (c, (xs, body), _) = (list_comb (c, xs), body)
   8.381 +      in case ty_info tab cname of
   8.382 +          SOME {constructors, case_name} =>
   8.383 +            if length fs = length constructors then
   8.384 +              let
   8.385 +                val cases = map (fn (Const (s, U), t) =>
   8.386 +                  let
   8.387 +                    val k = length (binder_types U);
   8.388 +                    val p as (xs, _) = strip_abs k t
   8.389 +                  in
   8.390 +                    (Const (s, map type_of xs ---> type_of x),
   8.391 +                     p, is_dependent k t)
   8.392 +                  end) (constructors ~~ fs);
   8.393 +                val cases' = sort (int_ord o swap o pairself (length o snd))
   8.394 +                  (fold_rev count_cases cases []);
   8.395 +                val R = type_of t;
   8.396 +                val dummy = if d then Const ("dummy_pattern", R)
   8.397 +                  else Free (Name.variant used "x", R)
   8.398 +              in
   8.399 +                SOME (x, map mk_case (case find_first (is_undefined o fst) cases' of
   8.400 +                  SOME (_, cs) =>
   8.401 +                  if length cs = length constructors then [hd cases]
   8.402 +                  else filter_out (fn (_, (_, body), _) => is_undefined body) cases
   8.403 +                | NONE => case cases' of
   8.404 +                  [] => cases
   8.405 +                | (default, cs) :: _ =>
   8.406 +                  if length cs = 1 then cases
   8.407 +                  else if length cs = length constructors then
   8.408 +                    [hd cases, (dummy, ([], default), false)]
   8.409 +                  else
   8.410 +                    filter_out (fn (c, _, _) => member op aconv cs c) cases @
   8.411 +                    [(dummy, ([], default), false)]))
   8.412 +              end handle CASE_ERROR _ => NONE
   8.413 +            else NONE
   8.414 +        | _ => NONE
   8.415 +      end
   8.416 +  | _ => NONE;
   8.417 +
   8.418 +val dest_case = gen_dest_case (try (dest_Const #> fst)) fastype_of;
   8.419 +val dest_case' = gen_dest_case
   8.420 +  (try (dest_Const #> fst #> unprefix Syntax.constN)) (K dummyT);
   8.421 +
   8.422 +
   8.423 +(* destruct nested patterns *)
   8.424 +
   8.425 +fun strip_case'' dest (pat, rhs) =
   8.426 +  case dest (Term.add_free_names pat []) rhs of
   8.427 +    SOME (exp as Free _, clauses) =>
   8.428 +      if member op aconv (OldTerm.term_frees pat) exp andalso
   8.429 +        not (exists (fn (_, rhs') =>
   8.430 +          member op aconv (OldTerm.term_frees rhs') exp) clauses)
   8.431 +      then
   8.432 +        maps (strip_case'' dest) (map (fn (pat', rhs') =>
   8.433 +          (subst_free [(exp, pat')] pat, rhs')) clauses)
   8.434 +      else [(pat, rhs)]
   8.435 +  | _ => [(pat, rhs)];
   8.436 +
   8.437 +fun gen_strip_case dest t = case dest [] t of
   8.438 +    SOME (x, clauses) =>
   8.439 +      SOME (x, maps (strip_case'' dest) clauses)
   8.440 +  | NONE => NONE;
   8.441 +
   8.442 +val strip_case = gen_strip_case oo dest_case;
   8.443 +val strip_case' = gen_strip_case oo dest_case';
   8.444 +
   8.445 +
   8.446 +(* print translation *)
   8.447 +
   8.448 +fun case_tr' tab_of cname ctxt ts =
   8.449 +  let
   8.450 +    val thy = ProofContext.theory_of ctxt;
   8.451 +    val consts = ProofContext.consts_of ctxt;
   8.452 +    fun mk_clause (pat, rhs) =
   8.453 +      let val xs = Term.add_frees pat []
   8.454 +      in
   8.455 +        Syntax.const "_case1" $
   8.456 +          map_aterms
   8.457 +            (fn Free p => Syntax.mark_boundT p
   8.458 +              | Const (s, _) => Const (Consts.extern_early consts s, dummyT)
   8.459 +              | t => t) pat $
   8.460 +          map_aterms
   8.461 +            (fn x as Free (s, T) =>
   8.462 +                  if member (op =) xs (s, T) then Syntax.mark_bound s else x
   8.463 +              | t => t) rhs
   8.464 +      end
   8.465 +  in case strip_case' (tab_of thy) true (list_comb (Syntax.const cname, ts)) of
   8.466 +      SOME (x, clauses) => Syntax.const "_case_syntax" $ x $
   8.467 +        foldr1 (fn (t, u) => Syntax.const "_case2" $ t $ u)
   8.468 +          (map mk_clause clauses)
   8.469 +    | NONE => raise Match
   8.470 +  end;
   8.471 +
   8.472 +end;
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Tools/Datatype/datatype_codegen.ML	Tue Jun 23 12:09:30 2009 +0200
     9.3 @@ -0,0 +1,455 @@
     9.4 +(*  Title:      HOL/Tools/datatype_codegen.ML
     9.5 +    Author:     Stefan Berghofer and Florian Haftmann, TU Muenchen
     9.6 +
     9.7 +Code generator facilities for inductive datatypes.
     9.8 +*)
     9.9 +
    9.10 +signature DATATYPE_CODEGEN =
    9.11 +sig
    9.12 +  val find_shortest_path: Datatype.descr -> int -> (string * int) option
    9.13 +  val mk_eq_eqns: theory -> string -> (thm * bool) list
    9.14 +  val mk_case_cert: theory -> string -> thm
    9.15 +  val setup: theory -> theory
    9.16 +end;
    9.17 +
    9.18 +structure DatatypeCodegen : DATATYPE_CODEGEN =
    9.19 +struct
    9.20 +
    9.21 +(** find shortest path to constructor with no recursive arguments **)
    9.22 +
    9.23 +fun find_nonempty (descr: Datatype.descr) is i =
    9.24 +  let
    9.25 +    val (_, _, constrs) = the (AList.lookup (op =) descr i);
    9.26 +    fun arg_nonempty (_, DatatypeAux.DtRec i) = if member (op =) is i
    9.27 +          then NONE
    9.28 +          else Option.map (curry op + 1 o snd) (find_nonempty descr (i::is) i)
    9.29 +      | arg_nonempty _ = SOME 0;
    9.30 +    fun max xs = Library.foldl
    9.31 +      (fn (NONE, _) => NONE
    9.32 +        | (SOME i, SOME j) => SOME (Int.max (i, j))
    9.33 +        | (_, NONE) => NONE) (SOME 0, xs);
    9.34 +    val xs = sort (int_ord o pairself snd)
    9.35 +      (map_filter (fn (s, dts) => Option.map (pair s)
    9.36 +        (max (map (arg_nonempty o DatatypeAux.strip_dtyp) dts))) constrs)
    9.37 +  in case xs of [] => NONE | x :: _ => SOME x end;
    9.38 +
    9.39 +fun find_shortest_path descr i = find_nonempty descr [i] i;
    9.40 +
    9.41 +
    9.42 +(** SML code generator **)
    9.43 +
    9.44 +open Codegen;
    9.45 +
    9.46 +(* datatype definition *)
    9.47 +
    9.48 +fun add_dt_defs thy defs dep module (descr: Datatype.descr) sorts gr =
    9.49 +  let
    9.50 +    val descr' = List.filter (can (map DatatypeAux.dest_DtTFree o #2 o snd)) descr;
    9.51 +    val rtnames = map (#1 o snd) (List.filter (fn (_, (_, _, cs)) =>
    9.52 +      exists (exists DatatypeAux.is_rec_type o snd) cs) descr');
    9.53 +
    9.54 +    val (_, (tname, _, _)) :: _ = descr';
    9.55 +    val node_id = tname ^ " (type)";
    9.56 +    val module' = if_library (thyname_of_type thy tname) module;
    9.57 +
    9.58 +    fun mk_dtdef prfx [] gr = ([], gr)
    9.59 +      | mk_dtdef prfx ((_, (tname, dts, cs))::xs) gr =
    9.60 +          let
    9.61 +            val tvs = map DatatypeAux.dest_DtTFree dts;
    9.62 +            val cs' = map (apsnd (map (DatatypeAux.typ_of_dtyp descr sorts))) cs;
    9.63 +            val ((_, type_id), gr') = mk_type_id module' tname gr;
    9.64 +            val (ps, gr'') = gr' |>
    9.65 +              fold_map (fn (cname, cargs) =>
    9.66 +                fold_map (invoke_tycodegen thy defs node_id module' false)
    9.67 +                  cargs ##>>
    9.68 +                mk_const_id module' cname) cs';
    9.69 +            val (rest, gr''') = mk_dtdef "and " xs gr''
    9.70 +          in
    9.71 +            (Pretty.block (str prfx ::
    9.72 +               (if null tvs then [] else
    9.73 +                  [mk_tuple (map str tvs), str " "]) @
    9.74 +               [str (type_id ^ " ="), Pretty.brk 1] @
    9.75 +               List.concat (separate [Pretty.brk 1, str "| "]
    9.76 +                 (map (fn (ps', (_, cname)) => [Pretty.block
    9.77 +                   (str cname ::
    9.78 +                    (if null ps' then [] else
    9.79 +                     List.concat ([str " of", Pretty.brk 1] ::
    9.80 +                       separate [str " *", Pretty.brk 1]
    9.81 +                         (map single ps'))))]) ps))) :: rest, gr''')
    9.82 +          end;
    9.83 +
    9.84 +    fun mk_constr_term cname Ts T ps =
    9.85 +      List.concat (separate [str " $", Pretty.brk 1]
    9.86 +        ([str ("Const (\"" ^ cname ^ "\","), Pretty.brk 1,
    9.87 +          mk_type false (Ts ---> T), str ")"] :: ps));
    9.88 +
    9.89 +    fun mk_term_of_def gr prfx [] = []
    9.90 +      | mk_term_of_def gr prfx ((_, (tname, dts, cs)) :: xs) =
    9.91 +          let
    9.92 +            val cs' = map (apsnd (map (DatatypeAux.typ_of_dtyp descr sorts))) cs;
    9.93 +            val dts' = map (DatatypeAux.typ_of_dtyp descr sorts) dts;
    9.94 +            val T = Type (tname, dts');
    9.95 +            val rest = mk_term_of_def gr "and " xs;
    9.96 +            val (eqs, _) = fold_map (fn (cname, Ts) => fn prfx =>
    9.97 +              let val args = map (fn i =>
    9.98 +                str ("x" ^ string_of_int i)) (1 upto length Ts)
    9.99 +              in (Pretty.blk (4,
   9.100 +                [str prfx, mk_term_of gr module' false T, Pretty.brk 1,
   9.101 +                 if null Ts then str (snd (get_const_id gr cname))
   9.102 +                 else parens (Pretty.block
   9.103 +                   [str (snd (get_const_id gr cname)),
   9.104 +                    Pretty.brk 1, mk_tuple args]),
   9.105 +                 str " =", Pretty.brk 1] @
   9.106 +                 mk_constr_term cname Ts T
   9.107 +                   (map2 (fn x => fn U => [Pretty.block [mk_term_of gr module' false U,
   9.108 +                      Pretty.brk 1, x]]) args Ts)), "  | ")
   9.109 +              end) cs' prfx
   9.110 +          in eqs @ rest end;
   9.111 +
   9.112 +    fun mk_gen_of_def gr prfx [] = []
   9.113 +      | mk_gen_of_def gr prfx ((i, (tname, dts, cs)) :: xs) =
   9.114 +          let
   9.115 +            val tvs = map DatatypeAux.dest_DtTFree dts;
   9.116 +            val Us = map (DatatypeAux.typ_of_dtyp descr sorts) dts;
   9.117 +            val T = Type (tname, Us);
   9.118 +            val (cs1, cs2) =
   9.119 +              List.partition (exists DatatypeAux.is_rec_type o snd) cs;
   9.120 +            val SOME (cname, _) = find_shortest_path descr i;
   9.121 +
   9.122 +            fun mk_delay p = Pretty.block
   9.123 +              [str "fn () =>", Pretty.brk 1, p];
   9.124 +
   9.125 +            fun mk_force p = Pretty.block [p, Pretty.brk 1, str "()"];
   9.126 +
   9.127 +            fun mk_constr s b (cname, dts) =
   9.128 +              let
   9.129 +                val gs = map (fn dt => mk_app false (mk_gen gr module' false rtnames s
   9.130 +                    (DatatypeAux.typ_of_dtyp descr sorts dt))
   9.131 +                  [str (if b andalso DatatypeAux.is_rec_type dt then "0"
   9.132 +                     else "j")]) dts;
   9.133 +                val Ts = map (DatatypeAux.typ_of_dtyp descr sorts) dts;
   9.134 +                val xs = map str
   9.135 +                  (DatatypeProp.indexify_names (replicate (length dts) "x"));
   9.136 +                val ts = map str
   9.137 +                  (DatatypeProp.indexify_names (replicate (length dts) "t"));
   9.138 +                val (_, id) = get_const_id gr cname
   9.139 +              in
   9.140 +                mk_let
   9.141 +                  (map2 (fn p => fn q => mk_tuple [p, q]) xs ts ~~ gs)
   9.142 +                  (mk_tuple
   9.143 +                    [case xs of
   9.144 +                       _ :: _ :: _ => Pretty.block
   9.145 +                         [str id, Pretty.brk 1, mk_tuple xs]
   9.146 +                     | _ => mk_app false (str id) xs,
   9.147 +                     mk_delay (Pretty.block (mk_constr_term cname Ts T
   9.148 +                       (map (single o mk_force) ts)))])
   9.149 +              end;
   9.150 +
   9.151 +            fun mk_choice [c] = mk_constr "(i-1)" false c
   9.152 +              | mk_choice cs = Pretty.block [str "one_of",
   9.153 +                  Pretty.brk 1, Pretty.blk (1, str "[" ::
   9.154 +                  List.concat (separate [str ",", Pretty.fbrk]
   9.155 +                    (map (single o mk_delay o mk_constr "(i-1)" false) cs)) @
   9.156 +                  [str "]"]), Pretty.brk 1, str "()"];
   9.157 +
   9.158 +            val gs = maps (fn s =>
   9.159 +              let val s' = strip_tname s
   9.160 +              in [str (s' ^ "G"), str (s' ^ "T")] end) tvs;
   9.161 +            val gen_name = "gen_" ^ snd (get_type_id gr tname)
   9.162 +
   9.163 +          in
   9.164 +            Pretty.blk (4, separate (Pretty.brk 1) 
   9.165 +                (str (prfx ^ gen_name ^
   9.166 +                   (if null cs1 then "" else "'")) :: gs @
   9.167 +                 (if null cs1 then [] else [str "i"]) @
   9.168 +                 [str "j"]) @
   9.169 +              [str " =", Pretty.brk 1] @
   9.170 +              (if not (null cs1) andalso not (null cs2)
   9.171 +               then [str "frequency", Pretty.brk 1,
   9.172 +                 Pretty.blk (1, [str "[",
   9.173 +                   mk_tuple [str "i", mk_delay (mk_choice cs1)],
   9.174 +                   str ",", Pretty.fbrk,
   9.175 +                   mk_tuple [str "1", mk_delay (mk_choice cs2)],
   9.176 +                   str "]"]), Pretty.brk 1, str "()"]
   9.177 +               else if null cs2 then
   9.178 +                 [Pretty.block [str "(case", Pretty.brk 1,
   9.179 +                   str "i", Pretty.brk 1, str "of",
   9.180 +                   Pretty.brk 1, str "0 =>", Pretty.brk 1,
   9.181 +                   mk_constr "0" true (cname, valOf (AList.lookup (op =) cs cname)),
   9.182 +                   Pretty.brk 1, str "| _ =>", Pretty.brk 1,
   9.183 +                   mk_choice cs1, str ")"]]
   9.184 +               else [mk_choice cs2])) ::
   9.185 +            (if null cs1 then []
   9.186 +             else [Pretty.blk (4, separate (Pretty.brk 1) 
   9.187 +                 (str ("and " ^ gen_name) :: gs @ [str "i"]) @
   9.188 +               [str " =", Pretty.brk 1] @
   9.189 +               separate (Pretty.brk 1) (str (gen_name ^ "'") :: gs @
   9.190 +                 [str "i", str "i"]))]) @
   9.191 +            mk_gen_of_def gr "and " xs
   9.192 +          end
   9.193 +
   9.194 +  in
   9.195 +    (module', (add_edge_acyclic (node_id, dep) gr
   9.196 +        handle Graph.CYCLES _ => gr) handle Graph.UNDEF _ =>
   9.197 +         let
   9.198 +           val gr1 = add_edge (node_id, dep)
   9.199 +             (new_node (node_id, (NONE, "", "")) gr);
   9.200 +           val (dtdef, gr2) = mk_dtdef "datatype " descr' gr1 ;
   9.201 +         in
   9.202 +           map_node node_id (K (NONE, module',
   9.203 +             string_of (Pretty.blk (0, separate Pretty.fbrk dtdef @
   9.204 +               [str ";"])) ^ "\n\n" ^
   9.205 +             (if "term_of" mem !mode then
   9.206 +                string_of (Pretty.blk (0, separate Pretty.fbrk
   9.207 +                  (mk_term_of_def gr2 "fun " descr') @ [str ";"])) ^ "\n\n"
   9.208 +              else "") ^
   9.209 +             (if "test" mem !mode then
   9.210 +                string_of (Pretty.blk (0, separate Pretty.fbrk
   9.211 +                  (mk_gen_of_def gr2 "fun " descr') @ [str ";"])) ^ "\n\n"
   9.212 +              else ""))) gr2
   9.213 +         end)
   9.214 +  end;
   9.215 +
   9.216 +
   9.217 +(* case expressions *)
   9.218 +
   9.219 +fun pretty_case thy defs dep module brack constrs (c as Const (_, T)) ts gr =
   9.220 +  let val i = length constrs
   9.221 +  in if length ts <= i then
   9.222 +       invoke_codegen thy defs dep module brack (eta_expand c ts (i+1)) gr
   9.223 +    else
   9.224 +      let
   9.225 +        val ts1 = Library.take (i, ts);
   9.226 +        val t :: ts2 = Library.drop (i, ts);
   9.227 +        val names = List.foldr OldTerm.add_term_names
   9.228 +          (map (fst o fst o dest_Var) (List.foldr OldTerm.add_term_vars [] ts1)) ts1;
   9.229 +        val (Ts, dT) = split_last (Library.take (i+1, fst (strip_type T)));
   9.230 +
   9.231 +        fun pcase [] [] [] gr = ([], gr)
   9.232 +          | pcase ((cname, cargs)::cs) (t::ts) (U::Us) gr =
   9.233 +              let
   9.234 +                val j = length cargs;
   9.235 +                val xs = Name.variant_list names (replicate j "x");
   9.236 +                val Us' = Library.take (j, fst (strip_type U));
   9.237 +                val frees = map Free (xs ~~ Us');
   9.238 +                val (cp, gr0) = invoke_codegen thy defs dep module false
   9.239 +                  (list_comb (Const (cname, Us' ---> dT), frees)) gr;
   9.240 +                val t' = Envir.beta_norm (list_comb (t, frees));
   9.241 +                val (p, gr1) = invoke_codegen thy defs dep module false t' gr0;
   9.242 +                val (ps, gr2) = pcase cs ts Us gr1;
   9.243 +              in
   9.244 +                ([Pretty.block [cp, str " =>", Pretty.brk 1, p]] :: ps, gr2)
   9.245 +              end;
   9.246 +
   9.247 +        val (ps1, gr1) = pcase constrs ts1 Ts gr ;
   9.248 +        val ps = List.concat (separate [Pretty.brk 1, str "| "] ps1);
   9.249 +        val (p, gr2) = invoke_codegen thy defs dep module false t gr1;
   9.250 +        val (ps2, gr3) = fold_map (invoke_codegen thy defs dep module true) ts2 gr2;
   9.251 +      in ((if not (null ts2) andalso brack then parens else I)
   9.252 +        (Pretty.block (separate (Pretty.brk 1)
   9.253 +          (Pretty.block ([str "(case ", p, str " of",
   9.254 +             Pretty.brk 1] @ ps @ [str ")"]) :: ps2))), gr3)
   9.255 +      end
   9.256 +  end;
   9.257 +
   9.258 +
   9.259 +(* constructors *)
   9.260 +
   9.261 +fun pretty_constr thy defs dep module brack args (c as Const (s, T)) ts gr =
   9.262 +  let val i = length args
   9.263 +  in if i > 1 andalso length ts < i then
   9.264 +      invoke_codegen thy defs dep module brack (eta_expand c ts i) gr
   9.265 +     else
   9.266 +       let
   9.267 +         val id = mk_qual_id module (get_const_id gr s);
   9.268 +         val (ps, gr') = fold_map
   9.269 +           (invoke_codegen thy defs dep module (i = 1)) ts gr;
   9.270 +       in (case args of
   9.271 +          _ :: _ :: _ => (if brack then parens else I)
   9.272 +            (Pretty.block [str id, Pretty.brk 1, mk_tuple ps])
   9.273 +        | _ => (mk_app brack (str id) ps), gr')
   9.274 +       end
   9.275 +  end;
   9.276 +
   9.277 +
   9.278 +(* code generators for terms and types *)
   9.279 +
   9.280 +fun datatype_codegen thy defs dep module brack t gr = (case strip_comb t of
   9.281 +   (c as Const (s, T), ts) =>
   9.282 +     (case Datatype.datatype_of_case thy s of
   9.283 +        SOME {index, descr, ...} =>
   9.284 +          if is_some (get_assoc_code thy (s, T)) then NONE else
   9.285 +          SOME (pretty_case thy defs dep module brack
   9.286 +            (#3 (the (AList.lookup op = descr index))) c ts gr )
   9.287 +      | NONE => case (Datatype.datatype_of_constr thy s, strip_type T) of
   9.288 +        (SOME {index, descr, ...}, (_, U as Type (tyname, _))) =>
   9.289 +          if is_some (get_assoc_code thy (s, T)) then NONE else
   9.290 +          let
   9.291 +            val SOME (tyname', _, constrs) = AList.lookup op = descr index;
   9.292 +            val SOME args = AList.lookup op = constrs s
   9.293 +          in
   9.294 +            if tyname <> tyname' then NONE
   9.295 +            else SOME (pretty_constr thy defs
   9.296 +              dep module brack args c ts (snd (invoke_tycodegen thy defs dep module false U gr)))
   9.297 +          end
   9.298 +      | _ => NONE)
   9.299 + | _ => NONE);
   9.300 +
   9.301 +fun datatype_tycodegen thy defs dep module brack (Type (s, Ts)) gr =
   9.302 +      (case Datatype.get_datatype thy s of
   9.303 +         NONE => NONE
   9.304 +       | SOME {descr, sorts, ...} =>
   9.305 +           if is_some (get_assoc_type thy s) then NONE else
   9.306 +           let
   9.307 +             val (ps, gr') = fold_map
   9.308 +               (invoke_tycodegen thy defs dep module false) Ts gr;
   9.309 +             val (module', gr'') = add_dt_defs thy defs dep module descr sorts gr' ;
   9.310 +             val (tyid, gr''') = mk_type_id module' s gr''
   9.311 +           in SOME (Pretty.block ((if null Ts then [] else
   9.312 +               [mk_tuple ps, str " "]) @
   9.313 +               [str (mk_qual_id module tyid)]), gr''')
   9.314 +           end)
   9.315 +  | datatype_tycodegen _ _ _ _ _ _ _ = NONE;
   9.316 +
   9.317 +
   9.318 +(** generic code generator **)
   9.319 +
   9.320 +(* liberal addition of code data for datatypes *)
   9.321 +
   9.322 +fun mk_constr_consts thy vs dtco cos =
   9.323 +  let
   9.324 +    val cs = map (fn (c, tys) => (c, tys ---> Type (dtco, map TFree vs))) cos;
   9.325 +    val cs' = map (fn c_ty as (_, ty) => (AxClass.unoverload_const thy c_ty, ty)) cs;
   9.326 +  in if is_some (try (Code.constrset_of_consts thy) cs')
   9.327 +    then SOME cs
   9.328 +    else NONE
   9.329 +  end;
   9.330 +
   9.331 +
   9.332 +(* case certificates *)
   9.333 +
   9.334 +fun mk_case_cert thy tyco =
   9.335 +  let
   9.336 +    val raw_thms =
   9.337 +      (#case_rewrites o Datatype.the_datatype thy) tyco;
   9.338 +    val thms as hd_thm :: _ = raw_thms
   9.339 +      |> Conjunction.intr_balanced
   9.340 +      |> Thm.unvarify
   9.341 +      |> Conjunction.elim_balanced (length raw_thms)
   9.342 +      |> map Simpdata.mk_meta_eq
   9.343 +      |> map Drule.zero_var_indexes
   9.344 +    val params = fold_aterms (fn (Free (v, _)) => insert (op =) v
   9.345 +      | _ => I) (Thm.prop_of hd_thm) [];
   9.346 +    val rhs = hd_thm
   9.347 +      |> Thm.prop_of
   9.348 +      |> Logic.dest_equals
   9.349 +      |> fst
   9.350 +      |> Term.strip_comb
   9.351 +      |> apsnd (fst o split_last)
   9.352 +      |> list_comb;
   9.353 +    val lhs = Free (Name.variant params "case", Term.fastype_of rhs);
   9.354 +    val asm = (Thm.cterm_of thy o Logic.mk_equals) (lhs, rhs);
   9.355 +  in
   9.356 +    thms
   9.357 +    |> Conjunction.intr_balanced
   9.358 +    |> MetaSimplifier.rewrite_rule [(Thm.symmetric o Thm.assume) asm]
   9.359 +    |> Thm.implies_intr asm
   9.360 +    |> Thm.generalize ([], params) 0
   9.361 +    |> AxClass.unoverload thy
   9.362 +    |> Thm.varifyT
   9.363 +  end;
   9.364 +
   9.365 +
   9.366 +(* equality *)
   9.367 +
   9.368 +fun mk_eq_eqns thy dtco =
   9.369 +  let
   9.370 +    val (vs, cos) = Datatype.the_datatype_spec thy dtco;
   9.371 +    val { descr, index, inject = inject_thms, ... } = Datatype.the_datatype thy dtco;
   9.372 +    val ty = Type (dtco, map TFree vs);
   9.373 +    fun mk_eq (t1, t2) = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
   9.374 +      $ t1 $ t2;
   9.375 +    fun true_eq t12 = HOLogic.mk_eq (mk_eq t12, HOLogic.true_const);
   9.376 +    fun false_eq t12 = HOLogic.mk_eq (mk_eq t12, HOLogic.false_const);
   9.377 +    val triv_injects = map_filter
   9.378 +     (fn (c, []) => SOME (HOLogic.mk_Trueprop (true_eq (Const (c, ty), Const (c, ty))))
   9.379 +       | _ => NONE) cos;
   9.380 +    fun prep_inject (trueprop $ (equiv $ (_ $ t1 $ t2) $ rhs)) =
   9.381 +      trueprop $ (equiv $ mk_eq (t1, t2) $ rhs);
   9.382 +    val injects = map prep_inject (nth (DatatypeProp.make_injs [descr] vs) index);
   9.383 +    fun prep_distinct (trueprop $ (not $ (_ $ t1 $ t2))) =
   9.384 +      [trueprop $ false_eq (t1, t2), trueprop $ false_eq (t2, t1)];
   9.385 +    val distincts = maps prep_distinct (snd (nth (DatatypeProp.make_distincts [descr] vs) index));
   9.386 +    val refl = HOLogic.mk_Trueprop (true_eq (Free ("x", ty), Free ("x", ty)));
   9.387 +    val simpset = Simplifier.context (ProofContext.init thy) (HOL_basic_ss
   9.388 +      addsimps (map Simpdata.mk_eq (@{thm eq} :: @{thm eq_True} :: inject_thms))
   9.389 +      addsimprocs [Datatype.distinct_simproc]);
   9.390 +    fun prove prop = SkipProof.prove_global thy [] [] prop (K (ALLGOALS (simp_tac simpset)))
   9.391 +      |> Simpdata.mk_eq;
   9.392 +  in map (rpair true o prove) (triv_injects @ injects @ distincts) @ [(prove refl, false)] end;
   9.393 +
   9.394 +fun add_equality vs dtcos thy =
   9.395 +  let
   9.396 +    fun add_def dtco lthy =
   9.397 +      let
   9.398 +        val ty = Type (dtco, map TFree vs);
   9.399 +        fun mk_side const_name = Const (const_name, ty --> ty --> HOLogic.boolT)
   9.400 +          $ Free ("x", ty) $ Free ("y", ty);
   9.401 +        val def = HOLogic.mk_Trueprop (HOLogic.mk_eq
   9.402 +          (mk_side @{const_name eq_class.eq}, mk_side @{const_name "op ="}));
   9.403 +        val def' = Syntax.check_term lthy def;
   9.404 +        val ((_, (_, thm)), lthy') = Specification.definition
   9.405 +          (NONE, (Attrib.empty_binding, def')) lthy;
   9.406 +        val ctxt_thy = ProofContext.init (ProofContext.theory_of lthy);
   9.407 +        val thm' = singleton (ProofContext.export lthy' ctxt_thy) thm;
   9.408 +      in (thm', lthy') end;
   9.409 +    fun tac thms = Class.intro_classes_tac []
   9.410 +      THEN ALLGOALS (ProofContext.fact_tac thms);
   9.411 +    fun add_eq_thms dtco thy =
   9.412 +      let
   9.413 +        val const = AxClass.param_of_inst thy (@{const_name eq_class.eq}, dtco);
   9.414 +        val thy_ref = Theory.check_thy thy;
   9.415 +        fun mk_thms () = rev ((mk_eq_eqns (Theory.deref thy_ref) dtco));
   9.416 +      in
   9.417 +        Code.add_eqnl (const, Lazy.lazy mk_thms) thy
   9.418 +      end;
   9.419 +  in
   9.420 +    thy
   9.421 +    |> TheoryTarget.instantiation (dtcos, vs, [HOLogic.class_eq])
   9.422 +    |> fold_map add_def dtcos
   9.423 +    |-> (fn def_thms => Class.prove_instantiation_exit_result (map o Morphism.thm)
   9.424 +         (fn _ => fn def_thms => tac def_thms) def_thms)
   9.425 +    |-> (fn def_thms => fold Code.del_eqn def_thms)
   9.426 +    |> fold add_eq_thms dtcos
   9.427 +  end;
   9.428 +
   9.429 +
   9.430 +(* register a datatype etc. *)
   9.431 +
   9.432 +fun add_all_code config dtcos thy =
   9.433 +  let
   9.434 +    val (vs :: _, coss) = (split_list o map (Datatype.the_datatype_spec thy)) dtcos;
   9.435 +    val any_css = map2 (mk_constr_consts thy vs) dtcos coss;
   9.436 +    val css = if exists is_none any_css then []
   9.437 +      else map_filter I any_css;
   9.438 +    val case_rewrites = maps (#case_rewrites o Datatype.the_datatype thy) dtcos;
   9.439 +    val certs = map (mk_case_cert thy) dtcos;
   9.440 +  in
   9.441 +    if null css then thy
   9.442 +    else thy
   9.443 +      |> tap (fn _ => DatatypeAux.message config "Registering datatype for code generator ...")
   9.444 +      |> fold Code.add_datatype css
   9.445 +      |> fold_rev Code.add_default_eqn case_rewrites
   9.446 +      |> fold Code.add_case certs
   9.447 +      |> add_equality vs dtcos
   9.448 +   end;
   9.449 +
   9.450 +
   9.451 +(** theory setup **)
   9.452 +
   9.453 +val setup = 
   9.454 +  add_codegen "datatype" datatype_codegen
   9.455 +  #> add_tycodegen "datatype" datatype_tycodegen
   9.456 +  #> Datatype.interpretation add_all_code
   9.457 +
   9.458 +end;
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/Datatype/datatype_prop.ML	Tue Jun 23 12:09:30 2009 +0200
    10.3 @@ -0,0 +1,435 @@
    10.4 +(*  Title:      HOL/Tools/datatype_prop.ML
    10.5 +    Author:     Stefan Berghofer, TU Muenchen
    10.6 +
    10.7 +Characteristic properties of datatypes.
    10.8 +*)
    10.9 +
   10.10 +signature DATATYPE_PROP =
   10.11 +sig
   10.12 +  val indexify_names: string list -> string list
   10.13 +  val make_tnames: typ list -> string list
   10.14 +  val make_injs : DatatypeAux.descr list -> (string * sort) list -> term list list
   10.15 +  val make_distincts : DatatypeAux.descr list ->
   10.16 +    (string * sort) list -> (int * term list) list (*no symmetric inequalities*)
   10.17 +  val make_ind : DatatypeAux.descr list -> (string * sort) list -> term
   10.18 +  val make_casedists : DatatypeAux.descr list -> (string * sort) list -> term list
   10.19 +  val make_primrec_Ts : DatatypeAux.descr list -> (string * sort) list ->
   10.20 +    string list -> typ list * typ list
   10.21 +  val make_primrecs : string list -> DatatypeAux.descr list ->
   10.22 +    (string * sort) list -> theory -> term list
   10.23 +  val make_cases : string list -> DatatypeAux.descr list ->
   10.24 +    (string * sort) list -> theory -> term list list
   10.25 +  val make_splits : string list -> DatatypeAux.descr list ->
   10.26 +    (string * sort) list -> theory -> (term * term) list
   10.27 +  val make_weak_case_congs : string list -> DatatypeAux.descr list ->
   10.28 +    (string * sort) list -> theory -> term list
   10.29 +  val make_case_congs : string list -> DatatypeAux.descr list ->
   10.30 +    (string * sort) list -> theory -> term list
   10.31 +  val make_nchotomys : DatatypeAux.descr list ->
   10.32 +    (string * sort) list -> term list
   10.33 +end;
   10.34 +
   10.35 +structure DatatypeProp : DATATYPE_PROP =
   10.36 +struct
   10.37 +
   10.38 +open DatatypeAux;
   10.39 +
   10.40 +fun indexify_names names =
   10.41 +  let
   10.42 +    fun index (x :: xs) tab =
   10.43 +      (case AList.lookup (op =) tab x of
   10.44 +        NONE => if member (op =) xs x then (x ^ "1") :: index xs ((x, 2) :: tab) else x :: index xs tab
   10.45 +      | SOME i => (x ^ string_of_int i) :: index xs ((x, i + 1) :: tab))
   10.46 +    | index [] _ = [];
   10.47 +  in index names [] end;
   10.48 +
   10.49 +fun make_tnames Ts =
   10.50 +  let
   10.51 +    fun type_name (TFree (name, _)) = implode (tl (explode name))
   10.52 +      | type_name (Type (name, _)) = 
   10.53 +          let val name' = Long_Name.base_name name
   10.54 +          in if Syntax.is_identifier name' then name' else "x" end;
   10.55 +  in indexify_names (map type_name Ts) end;
   10.56 +
   10.57 +
   10.58 +(************************* injectivity of constructors ************************)
   10.59 +
   10.60 +fun make_injs descr sorts =
   10.61 +  let
   10.62 +    val descr' = flat descr;
   10.63 +    fun make_inj T (cname, cargs) =
   10.64 +      if null cargs then I else
   10.65 +        let
   10.66 +          val Ts = map (typ_of_dtyp descr' sorts) cargs;
   10.67 +          val constr_t = Const (cname, Ts ---> T);
   10.68 +          val tnames = make_tnames Ts;
   10.69 +          val frees = map Free (tnames ~~ Ts);
   10.70 +          val frees' = map Free ((map ((op ^) o (rpair "'")) tnames) ~~ Ts);
   10.71 +        in cons (HOLogic.mk_Trueprop (HOLogic.mk_eq
   10.72 +          (HOLogic.mk_eq (list_comb (constr_t, frees), list_comb (constr_t, frees')),
   10.73 +           foldr1 (HOLogic.mk_binop "op &")
   10.74 +             (map HOLogic.mk_eq (frees ~~ frees')))))
   10.75 +        end;
   10.76 +  in
   10.77 +    map2 (fn d => fn T => fold_rev (make_inj T) (#3 (snd d)) [])
   10.78 +      (hd descr) (Library.take (length (hd descr), get_rec_types descr' sorts))
   10.79 +  end;
   10.80 +
   10.81 +
   10.82 +(************************* distinctness of constructors ***********************)
   10.83 +
   10.84 +fun make_distincts descr sorts =
   10.85 +  let
   10.86 +    val descr' = flat descr;
   10.87 +    val recTs = get_rec_types descr' sorts;
   10.88 +    val newTs = Library.take (length (hd descr), recTs);
   10.89 +
   10.90 +    fun prep_constr (cname, cargs) = (cname, map (typ_of_dtyp descr' sorts) cargs);
   10.91 +
   10.92 +    fun make_distincts' _ [] = []
   10.93 +      | make_distincts' T ((cname, cargs)::constrs) =
   10.94 +          let
   10.95 +            val frees = map Free ((make_tnames cargs) ~~ cargs);
   10.96 +            val t = list_comb (Const (cname, cargs ---> T), frees);
   10.97 +
   10.98 +            fun make_distincts'' (cname', cargs') =
   10.99 +              let
  10.100 +                val frees' = map Free ((map ((op ^) o (rpair "'"))
  10.101 +                  (make_tnames cargs')) ~~ cargs');
  10.102 +                val t' = list_comb (Const (cname', cargs' ---> T), frees')
  10.103 +              in
  10.104 +                HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.mk_eq (t, t'))
  10.105 +              end
  10.106 +
  10.107 +          in map make_distincts'' constrs @ make_distincts' T constrs end;
  10.108 +
  10.109 +  in
  10.110 +    map2 (fn ((_, (_, _, constrs))) => fn T =>
  10.111 +      (length constrs, make_distincts' T (map prep_constr constrs))) (hd descr) newTs
  10.112 +  end;
  10.113 +
  10.114 +
  10.115 +(********************************* induction **********************************)
  10.116 +
  10.117 +fun make_ind descr sorts =
  10.118 +  let
  10.119 +    val descr' = List.concat descr;
  10.120 +    val recTs = get_rec_types descr' sorts;
  10.121 +    val pnames = if length descr' = 1 then ["P"]
  10.122 +      else map (fn i => "P" ^ string_of_int i) (1 upto length descr');
  10.123 +
  10.124 +    fun make_pred i T =
  10.125 +      let val T' = T --> HOLogic.boolT
  10.126 +      in Free (List.nth (pnames, i), T') end;
  10.127 +
  10.128 +    fun make_ind_prem k T (cname, cargs) =
  10.129 +      let
  10.130 +        fun mk_prem ((dt, s), T) =
  10.131 +          let val (Us, U) = strip_type T
  10.132 +          in list_all (map (pair "x") Us, HOLogic.mk_Trueprop
  10.133 +            (make_pred (body_index dt) U $ app_bnds (Free (s, T)) (length Us)))
  10.134 +          end;
  10.135 +
  10.136 +        val recs = List.filter is_rec_type cargs;
  10.137 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.138 +        val recTs' = map (typ_of_dtyp descr' sorts) recs;
  10.139 +        val tnames = Name.variant_list pnames (make_tnames Ts);
  10.140 +        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
  10.141 +        val frees = tnames ~~ Ts;
  10.142 +        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
  10.143 +
  10.144 +      in list_all_free (frees, Logic.list_implies (prems,
  10.145 +        HOLogic.mk_Trueprop (make_pred k T $ 
  10.146 +          list_comb (Const (cname, Ts ---> T), map Free frees))))
  10.147 +      end;
  10.148 +
  10.149 +    val prems = List.concat (map (fn ((i, (_, _, constrs)), T) =>
  10.150 +      map (make_ind_prem i T) constrs) (descr' ~~ recTs));
  10.151 +    val tnames = make_tnames recTs;
  10.152 +    val concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
  10.153 +      (map (fn (((i, _), T), tname) => make_pred i T $ Free (tname, T))
  10.154 +        (descr' ~~ recTs ~~ tnames)))
  10.155 +
  10.156 +  in Logic.list_implies (prems, concl) end;
  10.157 +
  10.158 +(******************************* case distinction *****************************)
  10.159 +
  10.160 +fun make_casedists descr sorts =
  10.161 +  let
  10.162 +    val descr' = List.concat descr;
  10.163 +
  10.164 +    fun make_casedist_prem T (cname, cargs) =
  10.165 +      let
  10.166 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.167 +        val frees = Name.variant_list ["P", "y"] (make_tnames Ts) ~~ Ts;
  10.168 +        val free_ts = map Free frees
  10.169 +      in list_all_free (frees, Logic.mk_implies (HOLogic.mk_Trueprop
  10.170 +        (HOLogic.mk_eq (Free ("y", T), list_comb (Const (cname, Ts ---> T), free_ts))),
  10.171 +          HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))))
  10.172 +      end;
  10.173 +
  10.174 +    fun make_casedist ((_, (_, _, constrs)), T) =
  10.175 +      let val prems = map (make_casedist_prem T) constrs
  10.176 +      in Logic.list_implies (prems, HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT)))
  10.177 +      end
  10.178 +
  10.179 +  in map make_casedist
  10.180 +    ((hd descr) ~~ Library.take (length (hd descr), get_rec_types descr' sorts))
  10.181 +  end;
  10.182 +
  10.183 +(*************** characteristic equations for primrec combinator **************)
  10.184 +
  10.185 +fun make_primrec_Ts descr sorts used =
  10.186 +  let
  10.187 +    val descr' = List.concat descr;
  10.188 +
  10.189 +    val rec_result_Ts = map TFree (Name.variant_list used (replicate (length descr') "'t") ~~
  10.190 +      replicate (length descr') HOLogic.typeS);
  10.191 +
  10.192 +    val reccomb_fn_Ts = List.concat (map (fn (i, (_, _, constrs)) =>
  10.193 +      map (fn (_, cargs) =>
  10.194 +        let
  10.195 +          val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.196 +          val recs = List.filter (is_rec_type o fst) (cargs ~~ Ts);
  10.197 +
  10.198 +          fun mk_argT (dt, T) =
  10.199 +            binder_types T ---> List.nth (rec_result_Ts, body_index dt);
  10.200 +
  10.201 +          val argTs = Ts @ map mk_argT recs
  10.202 +        in argTs ---> List.nth (rec_result_Ts, i)
  10.203 +        end) constrs) descr');
  10.204 +
  10.205 +  in (rec_result_Ts, reccomb_fn_Ts) end;
  10.206 +
  10.207 +fun make_primrecs new_type_names descr sorts thy =
  10.208 +  let
  10.209 +    val descr' = List.concat descr;
  10.210 +    val recTs = get_rec_types descr' sorts;
  10.211 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
  10.212 +
  10.213 +    val (rec_result_Ts, reccomb_fn_Ts) = make_primrec_Ts descr sorts used;
  10.214 +
  10.215 +    val rec_fns = map (uncurry (mk_Free "f"))
  10.216 +      (reccomb_fn_Ts ~~ (1 upto (length reccomb_fn_Ts)));
  10.217 +
  10.218 +    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
  10.219 +    val reccomb_names = map (Sign.intern_const thy)
  10.220 +      (if length descr' = 1 then [big_reccomb_name] else
  10.221 +        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
  10.222 +          (1 upto (length descr'))));
  10.223 +    val reccombs = map (fn ((name, T), T') => list_comb
  10.224 +      (Const (name, reccomb_fn_Ts @ [T] ---> T'), rec_fns))
  10.225 +        (reccomb_names ~~ recTs ~~ rec_result_Ts);
  10.226 +
  10.227 +    fun make_primrec T comb_t ((ts, f::fs), (cname, cargs)) =
  10.228 +      let
  10.229 +        val recs = List.filter is_rec_type cargs;
  10.230 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.231 +        val recTs' = map (typ_of_dtyp descr' sorts) recs;
  10.232 +        val tnames = make_tnames Ts;
  10.233 +        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
  10.234 +        val frees = map Free (tnames ~~ Ts);
  10.235 +        val frees' = map Free (rec_tnames ~~ recTs');
  10.236 +
  10.237 +        fun mk_reccomb ((dt, T), t) =
  10.238 +          let val (Us, U) = strip_type T
  10.239 +          in list_abs (map (pair "x") Us,
  10.240 +            List.nth (reccombs, body_index dt) $ app_bnds t (length Us))
  10.241 +          end;
  10.242 +
  10.243 +        val reccombs' = map mk_reccomb (recs ~~ recTs' ~~ frees')
  10.244 +
  10.245 +      in (ts @ [HOLogic.mk_Trueprop (HOLogic.mk_eq
  10.246 +        (comb_t $ list_comb (Const (cname, Ts ---> T), frees),
  10.247 +         list_comb (f, frees @ reccombs')))], fs)
  10.248 +      end
  10.249 +
  10.250 +  in fst (Library.foldl (fn (x, ((dt, T), comb_t)) =>
  10.251 +    Library.foldl (make_primrec T comb_t) (x, #3 (snd dt)))
  10.252 +      (([], rec_fns), descr' ~~ recTs ~~ reccombs))
  10.253 +  end;
  10.254 +
  10.255 +(****************** make terms of form  t_case f1 ... fn  *********************)
  10.256 +
  10.257 +fun make_case_combs new_type_names descr sorts thy fname =
  10.258 +  let
  10.259 +    val descr' = List.concat descr;
  10.260 +    val recTs = get_rec_types descr' sorts;
  10.261 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
  10.262 +    val newTs = Library.take (length (hd descr), recTs);
  10.263 +    val T' = TFree (Name.variant used "'t", HOLogic.typeS);
  10.264 +
  10.265 +    val case_fn_Ts = map (fn (i, (_, _, constrs)) =>
  10.266 +      map (fn (_, cargs) =>
  10.267 +        let val Ts = map (typ_of_dtyp descr' sorts) cargs
  10.268 +        in Ts ---> T' end) constrs) (hd descr);
  10.269 +
  10.270 +    val case_names = map (fn s =>
  10.271 +      Sign.intern_const thy (s ^ "_case")) new_type_names
  10.272 +  in
  10.273 +    map (fn ((name, Ts), T) => list_comb
  10.274 +      (Const (name, Ts @ [T] ---> T'),
  10.275 +        map (uncurry (mk_Free fname)) (Ts ~~ (1 upto length Ts))))
  10.276 +          (case_names ~~ case_fn_Ts ~~ newTs)
  10.277 +  end;
  10.278 +
  10.279 +(**************** characteristic equations for case combinator ****************)
  10.280 +
  10.281 +fun make_cases new_type_names descr sorts thy =
  10.282 +  let
  10.283 +    val descr' = List.concat descr;
  10.284 +    val recTs = get_rec_types descr' sorts;
  10.285 +    val newTs = Library.take (length (hd descr), recTs);
  10.286 +
  10.287 +    fun make_case T comb_t ((cname, cargs), f) =
  10.288 +      let
  10.289 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.290 +        val frees = map Free ((make_tnames Ts) ~~ Ts)
  10.291 +      in HOLogic.mk_Trueprop (HOLogic.mk_eq
  10.292 +        (comb_t $ list_comb (Const (cname, Ts ---> T), frees),
  10.293 +         list_comb (f, frees)))
  10.294 +      end
  10.295 +
  10.296 +  in map (fn (((_, (_, _, constrs)), T), comb_t) =>
  10.297 +    map (make_case T comb_t) (constrs ~~ (snd (strip_comb comb_t))))
  10.298 +      ((hd descr) ~~ newTs ~~ (make_case_combs new_type_names descr sorts thy "f"))
  10.299 +  end;
  10.300 +
  10.301 +
  10.302 +(*************************** the "split" - equations **************************)
  10.303 +
  10.304 +fun make_splits new_type_names descr sorts thy =
  10.305 +  let
  10.306 +    val descr' = List.concat descr;
  10.307 +    val recTs = get_rec_types descr' sorts;
  10.308 +    val used' = List.foldr OldTerm.add_typ_tfree_names [] recTs;
  10.309 +    val newTs = Library.take (length (hd descr), recTs);
  10.310 +    val T' = TFree (Name.variant used' "'t", HOLogic.typeS);
  10.311 +    val P = Free ("P", T' --> HOLogic.boolT);
  10.312 +
  10.313 +    fun make_split (((_, (_, _, constrs)), T), comb_t) =
  10.314 +      let
  10.315 +        val (_, fs) = strip_comb comb_t;
  10.316 +        val used = ["P", "x"] @ (map (fst o dest_Free) fs);
  10.317 +
  10.318 +        fun process_constr (((cname, cargs), f), (t1s, t2s)) =
  10.319 +          let
  10.320 +            val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.321 +            val frees = map Free (Name.variant_list used (make_tnames Ts) ~~ Ts);
  10.322 +            val eqn = HOLogic.mk_eq (Free ("x", T),
  10.323 +              list_comb (Const (cname, Ts ---> T), frees));
  10.324 +            val P' = P $ list_comb (f, frees)
  10.325 +          in ((List.foldr (fn (Free (s, T), t) => HOLogic.mk_all (s, T, t))
  10.326 +                (HOLogic.imp $ eqn $ P') frees)::t1s,
  10.327 +              (List.foldr (fn (Free (s, T), t) => HOLogic.mk_exists (s, T, t))
  10.328 +                (HOLogic.conj $ eqn $ (HOLogic.Not $ P')) frees)::t2s)
  10.329 +          end;
  10.330 +
  10.331 +        val (t1s, t2s) = List.foldr process_constr ([], []) (constrs ~~ fs);
  10.332 +        val lhs = P $ (comb_t $ Free ("x", T))
  10.333 +      in
  10.334 +        (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, mk_conj t1s)),
  10.335 +         HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, HOLogic.Not $ mk_disj t2s)))
  10.336 +      end
  10.337 +
  10.338 +  in map make_split ((hd descr) ~~ newTs ~~
  10.339 +    (make_case_combs new_type_names descr sorts thy "f"))
  10.340 +  end;
  10.341 +
  10.342 +(************************* additional rules for TFL ***************************)
  10.343 +
  10.344 +fun make_weak_case_congs new_type_names descr sorts thy =
  10.345 +  let
  10.346 +    val case_combs = make_case_combs new_type_names descr sorts thy "f";
  10.347 +
  10.348 +    fun mk_case_cong comb =
  10.349 +      let 
  10.350 +        val Type ("fun", [T, _]) = fastype_of comb;
  10.351 +        val M = Free ("M", T);
  10.352 +        val M' = Free ("M'", T);
  10.353 +      in
  10.354 +        Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_eq (M, M')),
  10.355 +          HOLogic.mk_Trueprop (HOLogic.mk_eq (comb $ M, comb $ M')))
  10.356 +      end
  10.357 +  in
  10.358 +    map mk_case_cong case_combs
  10.359 +  end;
  10.360 + 
  10.361 +
  10.362 +(*---------------------------------------------------------------------------
  10.363 + * Structure of case congruence theorem looks like this:
  10.364 + *
  10.365 + *    (M = M') 
  10.366 + *    ==> (!!x1,...,xk. (M' = C1 x1..xk) ==> (f1 x1..xk = g1 x1..xk)) 
  10.367 + *    ==> ... 
  10.368 + *    ==> (!!x1,...,xj. (M' = Cn x1..xj) ==> (fn x1..xj = gn x1..xj)) 
  10.369 + *    ==>
  10.370 + *      (ty_case f1..fn M = ty_case g1..gn M')
  10.371 + *---------------------------------------------------------------------------*)
  10.372 +
  10.373 +fun make_case_congs new_type_names descr sorts thy =
  10.374 +  let
  10.375 +    val case_combs = make_case_combs new_type_names descr sorts thy "f";
  10.376 +    val case_combs' = make_case_combs new_type_names descr sorts thy "g";
  10.377 +
  10.378 +    fun mk_case_cong ((comb, comb'), (_, (_, _, constrs))) =
  10.379 +      let
  10.380 +        val Type ("fun", [T, _]) = fastype_of comb;
  10.381 +        val (_, fs) = strip_comb comb;
  10.382 +        val (_, gs) = strip_comb comb';
  10.383 +        val used = ["M", "M'"] @ map (fst o dest_Free) (fs @ gs);
  10.384 +        val M = Free ("M", T);
  10.385 +        val M' = Free ("M'", T);
  10.386 +
  10.387 +        fun mk_clause ((f, g), (cname, _)) =
  10.388 +          let
  10.389 +            val (Ts, _) = strip_type (fastype_of f);
  10.390 +            val tnames = Name.variant_list used (make_tnames Ts);
  10.391 +            val frees = map Free (tnames ~~ Ts)
  10.392 +          in
  10.393 +            list_all_free (tnames ~~ Ts, Logic.mk_implies
  10.394 +              (HOLogic.mk_Trueprop
  10.395 +                (HOLogic.mk_eq (M', list_comb (Const (cname, Ts ---> T), frees))),
  10.396 +               HOLogic.mk_Trueprop
  10.397 +                (HOLogic.mk_eq (list_comb (f, frees), list_comb (g, frees)))))
  10.398 +          end
  10.399 +
  10.400 +      in
  10.401 +        Logic.list_implies (HOLogic.mk_Trueprop (HOLogic.mk_eq (M, M')) ::
  10.402 +          map mk_clause (fs ~~ gs ~~ constrs),
  10.403 +            HOLogic.mk_Trueprop (HOLogic.mk_eq (comb $ M, comb' $ M')))
  10.404 +      end
  10.405 +
  10.406 +  in
  10.407 +    map mk_case_cong (case_combs ~~ case_combs' ~~ hd descr)
  10.408 +  end;
  10.409 +
  10.410 +(*---------------------------------------------------------------------------
  10.411 + * Structure of exhaustion theorem looks like this:
  10.412 + *
  10.413 + *    !v. (? y1..yi. v = C1 y1..yi) | ... | (? y1..yj. v = Cn y1..yj)
  10.414 + *---------------------------------------------------------------------------*)
  10.415 +
  10.416 +fun make_nchotomys descr sorts =
  10.417 +  let
  10.418 +    val descr' = List.concat descr;
  10.419 +    val recTs = get_rec_types descr' sorts;
  10.420 +    val newTs = Library.take (length (hd descr), recTs);
  10.421 +
  10.422 +    fun mk_eqn T (cname, cargs) =
  10.423 +      let
  10.424 +        val Ts = map (typ_of_dtyp descr' sorts) cargs;
  10.425 +        val tnames = Name.variant_list ["v"] (make_tnames Ts);
  10.426 +        val frees = tnames ~~ Ts
  10.427 +      in
  10.428 +        List.foldr (fn ((s, T'), t) => HOLogic.mk_exists (s, T', t))
  10.429 +          (HOLogic.mk_eq (Free ("v", T),
  10.430 +            list_comb (Const (cname, Ts ---> T), map Free frees))) frees
  10.431 +      end
  10.432 +
  10.433 +  in map (fn ((_, (_, _, constrs)), T) =>
  10.434 +    HOLogic.mk_Trueprop (HOLogic.mk_all ("v", T, mk_disj (map (mk_eqn T) constrs))))
  10.435 +      (hd descr ~~ newTs)
  10.436 +  end;
  10.437 +
  10.438 +end;
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Tools/Datatype/datatype_realizer.ML	Tue Jun 23 12:09:30 2009 +0200
    11.3 @@ -0,0 +1,230 @@
    11.4 +(*  Title:      HOL/Tools/datatype_realizer.ML
    11.5 +    Author:     Stefan Berghofer, TU Muenchen
    11.6 +
    11.7 +Porgram extraction from proofs involving datatypes:
    11.8 +Realizers for induction and case analysis
    11.9 +*)
   11.10 +
   11.11 +signature DATATYPE_REALIZER =
   11.12 +sig
   11.13 +  val add_dt_realizers: Datatype.config -> string list -> theory -> theory
   11.14 +  val setup: theory -> theory
   11.15 +end;
   11.16 +
   11.17 +structure DatatypeRealizer : DATATYPE_REALIZER =
   11.18 +struct
   11.19 +
   11.20 +open DatatypeAux;
   11.21 +
   11.22 +fun subsets i j = if i <= j then
   11.23 +       let val is = subsets (i+1) j
   11.24 +       in map (fn ks => i::ks) is @ is end
   11.25 +     else [[]];
   11.26 +
   11.27 +fun forall_intr_prf (t, prf) =
   11.28 +  let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   11.29 +  in Abst (a, SOME T, Proofterm.prf_abstract_over t prf) end;
   11.30 +
   11.31 +fun prf_of thm =
   11.32 +  Reconstruct.reconstruct_proof (Thm.theory_of_thm thm) (Thm.prop_of thm) (Thm.proof_of thm);
   11.33 +
   11.34 +fun prf_subst_vars inst =
   11.35 +  Proofterm.map_proof_terms (subst_vars ([], inst)) I;
   11.36 +
   11.37 +fun is_unit t = snd (strip_type (fastype_of t)) = HOLogic.unitT;
   11.38 +
   11.39 +fun tname_of (Type (s, _)) = s
   11.40 +  | tname_of _ = "";
   11.41 +
   11.42 +fun mk_realizes T = Const ("realizes", T --> HOLogic.boolT --> HOLogic.boolT);
   11.43 +
   11.44 +fun make_ind sorts ({descr, rec_names, rec_rewrites, induction, ...} : info) is thy =
   11.45 +  let
   11.46 +    val recTs = get_rec_types descr sorts;
   11.47 +    val pnames = if length descr = 1 then ["P"]
   11.48 +      else map (fn i => "P" ^ string_of_int i) (1 upto length descr);
   11.49 +
   11.50 +    val rec_result_Ts = map (fn ((i, _), P) =>
   11.51 +      if i mem is then TFree ("'" ^ P, HOLogic.typeS) else HOLogic.unitT)
   11.52 +        (descr ~~ pnames);
   11.53 +
   11.54 +    fun make_pred i T U r x =
   11.55 +      if i mem is then
   11.56 +        Free (List.nth (pnames, i), T --> U --> HOLogic.boolT) $ r $ x
   11.57 +      else Free (List.nth (pnames, i), U --> HOLogic.boolT) $ x;
   11.58 +
   11.59 +    fun mk_all i s T t =
   11.60 +      if i mem is then list_all_free ([(s, T)], t) else t;
   11.61 +
   11.62 +    val (prems, rec_fns) = split_list (flat (fst (fold_map
   11.63 +      (fn ((i, (_, _, constrs)), T) => fold_map (fn (cname, cargs) => fn j =>
   11.64 +        let
   11.65 +          val Ts = map (typ_of_dtyp descr sorts) cargs;
   11.66 +          val tnames = Name.variant_list pnames (DatatypeProp.make_tnames Ts);
   11.67 +          val recs = filter (is_rec_type o fst o fst) (cargs ~~ tnames ~~ Ts);
   11.68 +          val frees = tnames ~~ Ts;
   11.69 +
   11.70 +          fun mk_prems vs [] = 
   11.71 +                let
   11.72 +                  val rT = nth (rec_result_Ts) i;
   11.73 +                  val vs' = filter_out is_unit vs;
   11.74 +                  val f = mk_Free "f" (map fastype_of vs' ---> rT) j;
   11.75 +                  val f' = Envir.eta_contract (list_abs_free
   11.76 +                    (map dest_Free vs, if i mem is then list_comb (f, vs')
   11.77 +                      else HOLogic.unit));
   11.78 +                in (HOLogic.mk_Trueprop (make_pred i rT T (list_comb (f, vs'))
   11.79 +                  (list_comb (Const (cname, Ts ---> T), map Free frees))), f')
   11.80 +                end
   11.81 +            | mk_prems vs (((dt, s), T) :: ds) = 
   11.82 +                let
   11.83 +                  val k = body_index dt;
   11.84 +                  val (Us, U) = strip_type T;
   11.85 +                  val i = length Us;
   11.86 +                  val rT = nth (rec_result_Ts) k;
   11.87 +                  val r = Free ("r" ^ s, Us ---> rT);
   11.88 +                  val (p, f) = mk_prems (vs @ [r]) ds
   11.89 +                in (mk_all k ("r" ^ s) (Us ---> rT) (Logic.mk_implies
   11.90 +                  (list_all (map (pair "x") Us, HOLogic.mk_Trueprop
   11.91 +                    (make_pred k rT U (app_bnds r i)
   11.92 +                      (app_bnds (Free (s, T)) i))), p)), f)
   11.93 +                end
   11.94 +
   11.95 +        in (apfst (curry list_all_free frees) (mk_prems (map Free frees) recs), j + 1) end)
   11.96 +          constrs) (descr ~~ recTs) 1)));
   11.97 + 
   11.98 +    fun mk_proj j [] t = t
   11.99 +      | mk_proj j (i :: is) t = if null is then t else
  11.100 +          if (j: int) = i then HOLogic.mk_fst t
  11.101 +          else mk_proj j is (HOLogic.mk_snd t);
  11.102 +
  11.103 +    val tnames = DatatypeProp.make_tnames recTs;
  11.104 +    val fTs = map fastype_of rec_fns;
  11.105 +    val ps = map (fn ((((i, _), T), U), s) => Abs ("x", T, make_pred i U T
  11.106 +      (list_comb (Const (s, fTs ---> T --> U), rec_fns) $ Bound 0) (Bound 0)))
  11.107 +        (descr ~~ recTs ~~ rec_result_Ts ~~ rec_names);
  11.108 +    val r = if null is then Extraction.nullt else
  11.109 +      foldr1 HOLogic.mk_prod (List.mapPartial (fn (((((i, _), T), U), s), tname) =>
  11.110 +        if i mem is then SOME
  11.111 +          (list_comb (Const (s, fTs ---> T --> U), rec_fns) $ Free (tname, T))
  11.112 +        else NONE) (descr ~~ recTs ~~ rec_result_Ts ~~ rec_names ~~ tnames));
  11.113 +    val concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
  11.114 +      (map (fn ((((i, _), T), U), tname) =>
  11.115 +        make_pred i U T (mk_proj i is r) (Free (tname, T)))
  11.116 +          (descr ~~ recTs ~~ rec_result_Ts ~~ tnames)));
  11.117 +    val cert = cterm_of thy;
  11.118 +    val inst = map (pairself cert) (map head_of (HOLogic.dest_conj
  11.119 +      (HOLogic.dest_Trueprop (concl_of induction))) ~~ ps);
  11.120 +
  11.121 +    val thm = OldGoals.simple_prove_goal_cterm (cert (Logic.list_implies (prems, concl)))
  11.122 +      (fn prems =>
  11.123 +         [rewrite_goals_tac (map mk_meta_eq [fst_conv, snd_conv]),
  11.124 +          rtac (cterm_instantiate inst induction) 1,
  11.125 +          ALLGOALS ObjectLogic.atomize_prems_tac,
  11.126 +          rewrite_goals_tac (@{thm o_def} :: map mk_meta_eq rec_rewrites),
  11.127 +          REPEAT ((resolve_tac prems THEN_ALL_NEW (fn i =>
  11.128 +            REPEAT (etac allE i) THEN atac i)) 1)]);
  11.129 +
  11.130 +    val ind_name = Thm.get_name induction;
  11.131 +    val vs = map (fn i => List.nth (pnames, i)) is;
  11.132 +    val (thm', thy') = thy
  11.133 +      |> Sign.root_path
  11.134 +      |> PureThy.store_thm
  11.135 +        (Binding.qualified_name (space_implode "_" (ind_name :: vs @ ["correctness"])), thm)
  11.136 +      ||> Sign.restore_naming thy;
  11.137 +
  11.138 +    val ivs = rev (Term.add_vars (Logic.varify (DatatypeProp.make_ind [descr] sorts)) []);
  11.139 +    val rvs = rev (Thm.fold_terms Term.add_vars thm' []);
  11.140 +    val ivs1 = map Var (filter_out (fn (_, T) =>
  11.141 +      tname_of (body_type T) mem ["set", "bool"]) ivs);
  11.142 +    val ivs2 = map (fn (ixn, _) => Var (ixn, valOf (AList.lookup (op =) rvs ixn))) ivs;
  11.143 +
  11.144 +    val prf = List.foldr forall_intr_prf
  11.145 +     (List.foldr (fn ((f, p), prf) =>
  11.146 +        (case head_of (strip_abs_body f) of
  11.147 +           Free (s, T) =>
  11.148 +             let val T' = Logic.varifyT T
  11.149 +             in Abst (s, SOME T', Proofterm.prf_abstract_over
  11.150 +               (Var ((s, 0), T')) (AbsP ("H", SOME p, prf)))
  11.151 +             end
  11.152 +         | _ => AbsP ("H", SOME p, prf)))
  11.153 +           (Proofterm.proof_combP
  11.154 +             (prf_of thm', map PBound (length prems - 1 downto 0))) (rec_fns ~~ prems_of thm)) ivs2;
  11.155 +
  11.156 +    val r' = if null is then r else Logic.varify (List.foldr (uncurry lambda)
  11.157 +      r (map Logic.unvarify ivs1 @ filter_out is_unit
  11.158 +          (map (head_of o strip_abs_body) rec_fns)));
  11.159 +
  11.160 +  in Extraction.add_realizers_i [(ind_name, (vs, r', prf))] thy' end;
  11.161 +
  11.162 +
  11.163 +fun make_casedists sorts ({index, descr, case_name, case_rewrites, exhaustion, ...} : info) thy =
  11.164 +  let
  11.165 +    val cert = cterm_of thy;
  11.166 +    val rT = TFree ("'P", HOLogic.typeS);
  11.167 +    val rT' = TVar (("'P", 0), HOLogic.typeS);
  11.168 +
  11.169 +    fun make_casedist_prem T (cname, cargs) =
  11.170 +      let
  11.171 +        val Ts = map (typ_of_dtyp descr sorts) cargs;
  11.172 +        val frees = Name.variant_list ["P", "y"] (DatatypeProp.make_tnames Ts) ~~ Ts;
  11.173 +        val free_ts = map Free frees;
  11.174 +        val r = Free ("r" ^ Long_Name.base_name cname, Ts ---> rT)
  11.175 +      in (r, list_all_free (frees, Logic.mk_implies (HOLogic.mk_Trueprop
  11.176 +        (HOLogic.mk_eq (Free ("y", T), list_comb (Const (cname, Ts ---> T), free_ts))),
  11.177 +          HOLogic.mk_Trueprop (Free ("P", rT --> HOLogic.boolT) $
  11.178 +            list_comb (r, free_ts)))))
  11.179 +      end;
  11.180 +
  11.181 +    val SOME (_, _, constrs) = AList.lookup (op =) descr index;
  11.182 +    val T = List.nth (get_rec_types descr sorts, index);
  11.183 +    val (rs, prems) = split_list (map (make_casedist_prem T) constrs);
  11.184 +    val r = Const (case_name, map fastype_of rs ---> T --> rT);
  11.185 +
  11.186 +    val y = Var (("y", 0), Logic.legacy_varifyT T);
  11.187 +    val y' = Free ("y", T);
  11.188 +
  11.189 +    val thm = OldGoals.prove_goalw_cterm [] (cert (Logic.list_implies (prems,
  11.190 +      HOLogic.mk_Trueprop (Free ("P", rT --> HOLogic.boolT) $
  11.191 +        list_comb (r, rs @ [y'])))))
  11.192 +      (fn prems =>
  11.193 +         [rtac (cterm_instantiate [(cert y, cert y')] exhaustion) 1,
  11.194 +          ALLGOALS (EVERY'
  11.195 +            [asm_simp_tac (HOL_basic_ss addsimps case_rewrites),
  11.196 +             resolve_tac prems, asm_simp_tac HOL_basic_ss])]);
  11.197 +
  11.198 +    val exh_name = Thm.get_name exhaustion;
  11.199 +    val (thm', thy') = thy
  11.200 +      |> Sign.root_path
  11.201 +      |> PureThy.store_thm (Binding.qualified_name (exh_name ^ "_P_correctness"), thm)
  11.202 +      ||> Sign.restore_naming thy;
  11.203 +
  11.204 +    val P = Var (("P", 0), rT' --> HOLogic.boolT);
  11.205 +    val prf = forall_intr_prf (y, forall_intr_prf (P,
  11.206 +      List.foldr (fn ((p, r), prf) =>
  11.207 +        forall_intr_prf (Logic.legacy_varify r, AbsP ("H", SOME (Logic.varify p),
  11.208 +          prf))) (Proofterm.proof_combP (prf_of thm',
  11.209 +            map PBound (length prems - 1 downto 0))) (prems ~~ rs)));
  11.210 +    val r' = Logic.legacy_varify (Abs ("y", Logic.legacy_varifyT T,
  11.211 +      list_abs (map dest_Free rs, list_comb (r,
  11.212 +        map Bound ((length rs - 1 downto 0) @ [length rs])))));
  11.213 +
  11.214 +  in Extraction.add_realizers_i
  11.215 +    [(exh_name, (["P"], r', prf)),
  11.216 +     (exh_name, ([], Extraction.nullt, prf_of exhaustion))] thy'
  11.217 +  end;
  11.218 +
  11.219 +fun add_dt_realizers config names thy =
  11.220 +  if ! Proofterm.proofs < 2 then thy
  11.221 +  else let
  11.222 +    val _ = message config "Adding realizers for induction and case analysis ..."
  11.223 +    val infos = map (Datatype.the_datatype thy) names;
  11.224 +    val info :: _ = infos;
  11.225 +  in
  11.226 +    thy
  11.227 +    |> fold_rev (make_ind (#sorts info) info) (subsets 0 (length (#descr info) - 1))
  11.228 +    |> fold_rev (make_casedists (#sorts info)) infos
  11.229 +  end;
  11.230 +
  11.231 +val setup = Datatype.interpretation add_dt_realizers;
  11.232 +
  11.233 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/Datatype/datatype_rep_proofs.ML	Tue Jun 23 12:09:30 2009 +0200
    12.3 @@ -0,0 +1,643 @@
    12.4 +(*  Title:      HOL/Tools/datatype_rep_proofs.ML
    12.5 +    Author:     Stefan Berghofer, TU Muenchen
    12.6 +
    12.7 +Definitional introduction of datatypes
    12.8 +Proof of characteristic theorems:
    12.9 +
   12.10 + - injectivity of constructors
   12.11 + - distinctness of constructors
   12.12 + - induction theorem
   12.13 +*)
   12.14 +
   12.15 +signature DATATYPE_REP_PROOFS =
   12.16 +sig
   12.17 +  include DATATYPE_COMMON
   12.18 +  val distinctness_limit : int Config.T
   12.19 +  val distinctness_limit_setup : theory -> theory
   12.20 +  val representation_proofs : config -> info Symtab.table ->
   12.21 +    string list -> descr list -> (string * sort) list ->
   12.22 +      (binding * mixfix) list -> (binding * mixfix) list list -> attribute
   12.23 +        -> theory -> (thm list list * thm list list * thm list list *
   12.24 +          DatatypeAux.simproc_dist list * thm) * theory
   12.25 +end;
   12.26 +
   12.27 +structure DatatypeRepProofs : DATATYPE_REP_PROOFS =
   12.28 +struct
   12.29 +
   12.30 +open DatatypeAux;
   12.31 +
   12.32 +(*the kind of distinctiveness axioms depends on number of constructors*)
   12.33 +val (distinctness_limit, distinctness_limit_setup) =
   12.34 +  Attrib.config_int "datatype_distinctness_limit" 7;
   12.35 +
   12.36 +val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
   12.37 +
   12.38 +val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
   12.39 +
   12.40 +
   12.41 +(** theory context references **)
   12.42 +
   12.43 +val f_myinv_f = thm "f_myinv_f";
   12.44 +val myinv_f_f = thm "myinv_f_f";
   12.45 +
   12.46 +
   12.47 +fun exh_thm_of (dt_info : info Symtab.table) tname =
   12.48 +  #exhaustion (the (Symtab.lookup dt_info tname));
   12.49 +
   12.50 +(******************************************************************************)
   12.51 +
   12.52 +fun representation_proofs (config : config) (dt_info : info Symtab.table)
   12.53 +      new_type_names descr sorts types_syntax constr_syntax case_names_induct thy =
   12.54 +  let
   12.55 +    val Datatype_thy = ThyInfo.the_theory "Datatype" thy;
   12.56 +    val node_name = "Datatype.node";
   12.57 +    val In0_name = "Datatype.In0";
   12.58 +    val In1_name = "Datatype.In1";
   12.59 +    val Scons_name = "Datatype.Scons";
   12.60 +    val Leaf_name = "Datatype.Leaf";
   12.61 +    val Numb_name = "Datatype.Numb";
   12.62 +    val Lim_name = "Datatype.Lim";
   12.63 +    val Suml_name = "Datatype.Suml";
   12.64 +    val Sumr_name = "Datatype.Sumr";
   12.65 +
   12.66 +    val [In0_inject, In1_inject, Scons_inject, Leaf_inject,
   12.67 +         In0_eq, In1_eq, In0_not_In1, In1_not_In0,
   12.68 +         Lim_inject, Suml_inject, Sumr_inject] = map (PureThy.get_thm Datatype_thy)
   12.69 +          ["In0_inject", "In1_inject", "Scons_inject", "Leaf_inject",
   12.70 +           "In0_eq", "In1_eq", "In0_not_In1", "In1_not_In0",
   12.71 +           "Lim_inject", "Suml_inject", "Sumr_inject"];
   12.72 +
   12.73 +    val descr' = flat descr;
   12.74 +
   12.75 +    val big_name = space_implode "_" new_type_names;
   12.76 +    val thy1 = add_path (#flat_names config) big_name thy;
   12.77 +    val big_rec_name = big_name ^ "_rep_set";
   12.78 +    val rep_set_names' =
   12.79 +      (if length descr' = 1 then [big_rec_name] else
   12.80 +        (map ((curry (op ^) (big_rec_name ^ "_")) o string_of_int)
   12.81 +          (1 upto (length descr'))));
   12.82 +    val rep_set_names = map (Sign.full_bname thy1) rep_set_names';
   12.83 +
   12.84 +    val tyvars = map (fn (_, (_, Ts, _)) => map dest_DtTFree Ts) (hd descr);
   12.85 +    val leafTs' = get_nonrec_types descr' sorts;
   12.86 +    val branchTs = get_branching_types descr' sorts;
   12.87 +    val branchT = if null branchTs then HOLogic.unitT
   12.88 +      else BalancedTree.make (fn (T, U) => Type ("+", [T, U])) branchTs;
   12.89 +    val arities = get_arities descr' \ 0;
   12.90 +    val unneeded_vars = hd tyvars \\ List.foldr OldTerm.add_typ_tfree_names [] (leafTs' @ branchTs);
   12.91 +    val leafTs = leafTs' @ (map (fn n => TFree (n, (the o AList.lookup (op =) sorts) n)) unneeded_vars);
   12.92 +    val recTs = get_rec_types descr' sorts;
   12.93 +    val newTs = Library.take (length (hd descr), recTs);
   12.94 +    val oldTs = Library.drop (length (hd descr), recTs);
   12.95 +    val sumT = if null leafTs then HOLogic.unitT
   12.96 +      else BalancedTree.make (fn (T, U) => Type ("+", [T, U])) leafTs;
   12.97 +    val Univ_elT = HOLogic.mk_setT (Type (node_name, [sumT, branchT]));
   12.98 +    val UnivT = HOLogic.mk_setT Univ_elT;
   12.99 +    val UnivT' = Univ_elT --> HOLogic.boolT;
  12.100 +    val Collect = Const ("Collect", UnivT' --> UnivT);
  12.101 +
  12.102 +    val In0 = Const (In0_name, Univ_elT --> Univ_elT);
  12.103 +    val In1 = Const (In1_name, Univ_elT --> Univ_elT);
  12.104 +    val Leaf = Const (Leaf_name, sumT --> Univ_elT);
  12.105 +    val Lim = Const (Lim_name, (branchT --> Univ_elT) --> Univ_elT);
  12.106 +
  12.107 +    (* make injections needed for embedding types in leaves *)
  12.108 +
  12.109 +    fun mk_inj T' x =
  12.110 +      let
  12.111 +        fun mk_inj' T n i =
  12.112 +          if n = 1 then x else
  12.113 +          let val n2 = n div 2;
  12.114 +              val Type (_, [T1, T2]) = T
  12.115 +          in
  12.116 +            if i <= n2 then
  12.117 +              Const ("Sum_Type.Inl", T1 --> T) $ (mk_inj' T1 n2 i)
  12.118 +            else
  12.119 +              Const ("Sum_Type.Inr", T2 --> T) $ (mk_inj' T2 (n - n2) (i - n2))
  12.120 +          end
  12.121 +      in mk_inj' sumT (length leafTs) (1 + find_index_eq T' leafTs)
  12.122 +      end;
  12.123 +
  12.124 +    (* make injections for constructors *)
  12.125 +
  12.126 +    fun mk_univ_inj ts = BalancedTree.access
  12.127 +      {left = fn t => In0 $ t,
  12.128 +        right = fn t => In1 $ t,
  12.129 +        init =
  12.130 +          if ts = [] then Const (@{const_name undefined}, Univ_elT)
  12.131 +          else foldr1 (HOLogic.mk_binop Scons_name) ts};
  12.132 +
  12.133 +    (* function spaces *)
  12.134 +
  12.135 +    fun mk_fun_inj T' x =
  12.136 +      let
  12.137 +        fun mk_inj T n i =
  12.138 +          if n = 1 then x else
  12.139 +          let
  12.140 +            val n2 = n div 2;
  12.141 +            val Type (_, [T1, T2]) = T;
  12.142 +            fun mkT U = (U --> Univ_elT) --> T --> Univ_elT
  12.143 +          in
  12.144 +            if i <= n2 then Const (Suml_name, mkT T1) $ mk_inj T1 n2 i
  12.145 +            else Const (Sumr_name, mkT T2) $ mk_inj T2 (n - n2) (i - n2)
  12.146 +          end
  12.147 +      in mk_inj branchT (length branchTs) (1 + find_index_eq T' branchTs)
  12.148 +      end;
  12.149 +
  12.150 +    val mk_lim = List.foldr (fn (T, t) => Lim $ mk_fun_inj T (Abs ("x", T, t)));
  12.151 +
  12.152 +    (************** generate introduction rules for representing set **********)
  12.153 +
  12.154 +    val _ = message config "Constructing representing sets ...";
  12.155 +
  12.156 +    (* make introduction rule for a single constructor *)
  12.157 +
  12.158 +    fun make_intr s n (i, (_, cargs)) =
  12.159 +      let
  12.160 +        fun mk_prem (dt, (j, prems, ts)) = (case strip_dtyp dt of
  12.161 +            (dts, DtRec k) =>
  12.162 +              let
  12.163 +                val Ts = map (typ_of_dtyp descr' sorts) dts;
  12.164 +                val free_t =
  12.165 +                  app_bnds (mk_Free "x" (Ts ---> Univ_elT) j) (length Ts)
  12.166 +              in (j + 1, list_all (map (pair "x") Ts,
  12.167 +                  HOLogic.mk_Trueprop
  12.168 +                    (Free (List.nth (rep_set_names', k), UnivT') $ free_t)) :: prems,
  12.169 +                mk_lim free_t Ts :: ts)
  12.170 +              end
  12.171 +          | _ =>
  12.172 +              let val T = typ_of_dtyp descr' sorts dt
  12.173 +              in (j + 1, prems, (Leaf $ mk_inj T (mk_Free "x" T j))::ts)
  12.174 +              end);
  12.175 +
  12.176 +        val (_, prems, ts) = List.foldr mk_prem (1, [], []) cargs;
  12.177 +        val concl = HOLogic.mk_Trueprop
  12.178 +          (Free (s, UnivT') $ mk_univ_inj ts n i)
  12.179 +      in Logic.list_implies (prems, concl)
  12.180 +      end;
  12.181 +
  12.182 +    val intr_ts = maps (fn ((_, (_, _, constrs)), rep_set_name) =>
  12.183 +      map (make_intr rep_set_name (length constrs))
  12.184 +        ((1 upto (length constrs)) ~~ constrs)) (descr' ~~ rep_set_names');
  12.185 +
  12.186 +    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
  12.187 +        Inductive.add_inductive_global (serial_string ())
  12.188 +          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
  12.189 +           alt_name = Binding.name big_rec_name, coind = false, no_elim = true, no_ind = false,
  12.190 +           skip_mono = true, fork_mono = false}
  12.191 +          (map (fn s => ((Binding.name s, UnivT'), NoSyn)) rep_set_names') []
  12.192 +          (map (fn x => (Attrib.empty_binding, x)) intr_ts) [] thy1;
  12.193 +
  12.194 +    (********************************* typedef ********************************)
  12.195 +
  12.196 +    val (typedefs, thy3) = thy2 |>
  12.197 +      parent_path (#flat_names config) |>
  12.198 +      fold_map (fn ((((name, mx), tvs), c), name') =>
  12.199 +          Typedef.add_typedef false (SOME (Binding.name name')) (name, tvs, mx)
  12.200 +            (Collect $ Const (c, UnivT')) NONE
  12.201 +            (rtac exI 1 THEN rtac CollectI 1 THEN
  12.202 +              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  12.203 +              (resolve_tac rep_intrs 1)))
  12.204 +                (types_syntax ~~ tyvars ~~
  12.205 +                  (Library.take (length newTs, rep_set_names)) ~~ new_type_names) ||>
  12.206 +      add_path (#flat_names config) big_name;
  12.207 +
  12.208 +    (*********************** definition of constructors ***********************)
  12.209 +
  12.210 +    val big_rep_name = (space_implode "_" new_type_names) ^ "_Rep_";
  12.211 +    val rep_names = map (curry op ^ "Rep_") new_type_names;
  12.212 +    val rep_names' = map (fn i => big_rep_name ^ (string_of_int i))
  12.213 +      (1 upto (length (flat (tl descr))));
  12.214 +    val all_rep_names = map (Sign.intern_const thy3) rep_names @
  12.215 +      map (Sign.full_bname thy3) rep_names';
  12.216 +
  12.217 +    (* isomorphism declarations *)
  12.218 +
  12.219 +    val iso_decls = map (fn (T, s) => (Binding.name s, T --> Univ_elT, NoSyn))
  12.220 +      (oldTs ~~ rep_names');
  12.221 +
  12.222 +    (* constructor definitions *)
  12.223 +
  12.224 +    fun make_constr_def tname T n ((thy, defs, eqns, i), ((cname, cargs), (cname', mx))) =
  12.225 +      let
  12.226 +        fun constr_arg (dt, (j, l_args, r_args)) =
  12.227 +          let val T = typ_of_dtyp descr' sorts dt;
  12.228 +              val free_t = mk_Free "x" T j
  12.229 +          in (case (strip_dtyp dt, strip_type T) of
  12.230 +              ((_, DtRec m), (Us, U)) => (j + 1, free_t :: l_args, mk_lim
  12.231 +                (Const (List.nth (all_rep_names, m), U --> Univ_elT) $
  12.232 +                   app_bnds free_t (length Us)) Us :: r_args)
  12.233 +            | _ => (j + 1, free_t::l_args, (Leaf $ mk_inj T free_t)::r_args))
  12.234 +          end;
  12.235 +
  12.236 +        val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) cargs;
  12.237 +        val constrT = (map (typ_of_dtyp descr' sorts) cargs) ---> T;
  12.238 +        val abs_name = Sign.intern_const thy ("Abs_" ^ tname);
  12.239 +        val rep_name = Sign.intern_const thy ("Rep_" ^ tname);
  12.240 +        val lhs = list_comb (Const (cname, constrT), l_args);
  12.241 +        val rhs = mk_univ_inj r_args n i;
  12.242 +        val def = Logic.mk_equals (lhs, Const (abs_name, Univ_elT --> T) $ rhs);
  12.243 +        val def_name = Long_Name.base_name cname ^ "_def";
  12.244 +        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  12.245 +          (Const (rep_name, T --> Univ_elT) $ lhs, rhs));
  12.246 +        val ([def_thm], thy') =
  12.247 +          thy
  12.248 +          |> Sign.add_consts_i [(cname', constrT, mx)]
  12.249 +          |> (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)];
  12.250 +
  12.251 +      in (thy', defs @ [def_thm], eqns @ [eqn], i + 1) end;
  12.252 +
  12.253 +    (* constructor definitions for datatype *)
  12.254 +
  12.255 +    fun dt_constr_defs ((thy, defs, eqns, rep_congs, dist_lemmas),
  12.256 +        ((((_, (_, _, constrs)), tname), T), constr_syntax)) =
  12.257 +      let
  12.258 +        val _ $ (_ $ (cong_f $ _) $ _) = concl_of arg_cong;
  12.259 +        val rep_const = cterm_of thy
  12.260 +          (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> Univ_elT));
  12.261 +        val cong' = standard (cterm_instantiate [(cterm_of thy cong_f, rep_const)] arg_cong);
  12.262 +        val dist = standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
  12.263 +        val (thy', defs', eqns', _) = Library.foldl ((make_constr_def tname T) (length constrs))
  12.264 +          ((add_path (#flat_names config) tname thy, defs, [], 1), constrs ~~ constr_syntax)
  12.265 +      in
  12.266 +        (parent_path (#flat_names config) thy', defs', eqns @ [eqns'],
  12.267 +          rep_congs @ [cong'], dist_lemmas @ [dist])
  12.268 +      end;
  12.269 +
  12.270 +    val (thy4, constr_defs, constr_rep_eqns, rep_congs, dist_lemmas) = Library.foldl dt_constr_defs
  12.271 +      ((thy3 |> Sign.add_consts_i iso_decls |> parent_path (#flat_names config), [], [], [], []),
  12.272 +        hd descr ~~ new_type_names ~~ newTs ~~ constr_syntax);
  12.273 +
  12.274 +    (*********** isomorphisms for new types (introduced by typedef) ***********)
  12.275 +
  12.276 +    val _ = message config "Proving isomorphism properties ...";
  12.277 +
  12.278 +    val newT_iso_axms = map (fn (_, td) =>
  12.279 +      (collect_simp (#Abs_inverse td), #Rep_inverse td,
  12.280 +       collect_simp (#Rep td))) typedefs;
  12.281 +
  12.282 +    val newT_iso_inj_thms = map (fn (_, td) =>
  12.283 +      (collect_simp (#Abs_inject td) RS iffD1, #Rep_inject td RS iffD1)) typedefs;
  12.284 +
  12.285 +    (********* isomorphisms between existing types and "unfolded" types *******)
  12.286 +
  12.287 +    (*---------------------------------------------------------------------*)
  12.288 +    (* isomorphisms are defined using primrec-combinators:                 *)
  12.289 +    (* generate appropriate functions for instantiating primrec-combinator *)
  12.290 +    (*                                                                     *)
  12.291 +    (*   e.g.  dt_Rep_i = list_rec ... (%h t y. In1 (Scons (Leaf h) y))    *)
  12.292 +    (*                                                                     *)
  12.293 +    (* also generate characteristic equations for isomorphisms             *)
  12.294 +    (*                                                                     *)
  12.295 +    (*   e.g.  dt_Rep_i (cons h t) = In1 (Scons (dt_Rep_j h) (dt_Rep_i t)) *)
  12.296 +    (*---------------------------------------------------------------------*)
  12.297 +
  12.298 +    fun make_iso_def k ks n ((fs, eqns, i), (cname, cargs)) =
  12.299 +      let
  12.300 +        val argTs = map (typ_of_dtyp descr' sorts) cargs;
  12.301 +        val T = List.nth (recTs, k);
  12.302 +        val rep_name = List.nth (all_rep_names, k);
  12.303 +        val rep_const = Const (rep_name, T --> Univ_elT);
  12.304 +        val constr = Const (cname, argTs ---> T);
  12.305 +
  12.306 +        fun process_arg ks' ((i2, i2', ts, Ts), dt) =
  12.307 +          let
  12.308 +            val T' = typ_of_dtyp descr' sorts dt;
  12.309 +            val (Us, U) = strip_type T'
  12.310 +          in (case strip_dtyp dt of
  12.311 +              (_, DtRec j) => if j mem ks' then
  12.312 +                  (i2 + 1, i2' + 1, ts @ [mk_lim (app_bnds
  12.313 +                     (mk_Free "y" (Us ---> Univ_elT) i2') (length Us)) Us],
  12.314 +                   Ts @ [Us ---> Univ_elT])
  12.315 +                else
  12.316 +                  (i2 + 1, i2', ts @ [mk_lim
  12.317 +                     (Const (List.nth (all_rep_names, j), U --> Univ_elT) $
  12.318 +                        app_bnds (mk_Free "x" T' i2) (length Us)) Us], Ts)
  12.319 +            | _ => (i2 + 1, i2', ts @ [Leaf $ mk_inj T' (mk_Free "x" T' i2)], Ts))
  12.320 +          end;
  12.321 +
  12.322 +        val (i2, i2', ts, Ts) = Library.foldl (process_arg ks) ((1, 1, [], []), cargs);
  12.323 +        val xs = map (uncurry (mk_Free "x")) (argTs ~~ (1 upto (i2 - 1)));
  12.324 +        val ys = map (uncurry (mk_Free "y")) (Ts ~~ (1 upto (i2' - 1)));
  12.325 +        val f = list_abs_free (map dest_Free (xs @ ys), mk_univ_inj ts n i);
  12.326 +
  12.327 +        val (_, _, ts', _) = Library.foldl (process_arg []) ((1, 1, [], []), cargs);
  12.328 +        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  12.329 +          (rep_const $ list_comb (constr, xs), mk_univ_inj ts' n i))
  12.330 +
  12.331 +      in (fs @ [f], eqns @ [eqn], i + 1) end;
  12.332 +
  12.333 +    (* define isomorphisms for all mutually recursive datatypes in list ds *)
  12.334 +
  12.335 +    fun make_iso_defs (ds, (thy, char_thms)) =
  12.336 +      let
  12.337 +        val ks = map fst ds;
  12.338 +        val (_, (tname, _, _)) = hd ds;
  12.339 +        val {rec_rewrites, rec_names, ...} = the (Symtab.lookup dt_info tname);
  12.340 +
  12.341 +        fun process_dt ((fs, eqns, isos), (k, (tname, _, constrs))) =
  12.342 +          let
  12.343 +            val (fs', eqns', _) = Library.foldl (make_iso_def k ks (length constrs))
  12.344 +              ((fs, eqns, 1), constrs);
  12.345 +            val iso = (List.nth (recTs, k), List.nth (all_rep_names, k))
  12.346 +          in (fs', eqns', isos @ [iso]) end;
  12.347 +        
  12.348 +        val (fs, eqns, isos) = Library.foldl process_dt (([], [], []), ds);
  12.349 +        val fTs = map fastype_of fs;
  12.350 +        val defs = map (fn (rec_name, (T, iso_name)) => (Binding.name (Long_Name.base_name iso_name ^ "_def"),
  12.351 +          Logic.mk_equals (Const (iso_name, T --> Univ_elT),
  12.352 +            list_comb (Const (rec_name, fTs @ [T] ---> Univ_elT), fs)))) (rec_names ~~ isos);
  12.353 +        val (def_thms, thy') =
  12.354 +          apsnd Theory.checkpoint ((PureThy.add_defs false o map Thm.no_attributes) defs thy);
  12.355 +
  12.356 +        (* prove characteristic equations *)
  12.357 +
  12.358 +        val rewrites = def_thms @ (map mk_meta_eq rec_rewrites);
  12.359 +        val char_thms' = map (fn eqn => SkipProof.prove_global thy' [] [] eqn
  12.360 +          (fn _ => EVERY [rewrite_goals_tac rewrites, rtac refl 1])) eqns;
  12.361 +
  12.362 +      in (thy', char_thms' @ char_thms) end;
  12.363 +
  12.364 +    val (thy5, iso_char_thms) = apfst Theory.checkpoint (List.foldr make_iso_defs
  12.365 +      (add_path (#flat_names config) big_name thy4, []) (tl descr));
  12.366 +
  12.367 +    (* prove isomorphism properties *)
  12.368 +
  12.369 +    fun mk_funs_inv thy thm =
  12.370 +      let
  12.371 +        val prop = Thm.prop_of thm;
  12.372 +        val _ $ (_ $ ((S as Const (_, Type (_, [U, _]))) $ _ )) $
  12.373 +          (_ $ (_ $ (r $ (a $ _)) $ _)) = Type.freeze prop;
  12.374 +        val used = OldTerm.add_term_tfree_names (a, []);
  12.375 +
  12.376 +        fun mk_thm i =
  12.377 +          let
  12.378 +            val Ts = map (TFree o rpair HOLogic.typeS)
  12.379 +              (Name.variant_list used (replicate i "'t"));
  12.380 +            val f = Free ("f", Ts ---> U)
  12.381 +          in SkipProof.prove_global thy [] [] (Logic.mk_implies
  12.382 +            (HOLogic.mk_Trueprop (HOLogic.list_all
  12.383 +               (map (pair "x") Ts, S $ app_bnds f i)),
  12.384 +             HOLogic.mk_Trueprop (HOLogic.mk_eq (list_abs (map (pair "x") Ts,
  12.385 +               r $ (a $ app_bnds f i)), f))))
  12.386 +            (fn _ => EVERY [REPEAT_DETERM_N i (rtac ext 1),
  12.387 +               REPEAT (etac allE 1), rtac thm 1, atac 1])
  12.388 +          end
  12.389 +      in map (fn r => r RS subst) (thm :: map mk_thm arities) end;
  12.390 +
  12.391 +    (* prove  inj dt_Rep_i  and  dt_Rep_i x : dt_rep_set_i *)
  12.392 +
  12.393 +    val fun_congs = map (fn T => make_elim (Drule.instantiate'
  12.394 +      [SOME (ctyp_of thy5 T)] [] fun_cong)) branchTs;
  12.395 +
  12.396 +    fun prove_iso_thms (ds, (inj_thms, elem_thms)) =
  12.397 +      let
  12.398 +        val (_, (tname, _, _)) = hd ds;
  12.399 +        val {induction, ...} = the (Symtab.lookup dt_info tname);
  12.400 +
  12.401 +        fun mk_ind_concl (i, _) =
  12.402 +          let
  12.403 +            val T = List.nth (recTs, i);
  12.404 +            val Rep_t = Const (List.nth (all_rep_names, i), T --> Univ_elT);
  12.405 +            val rep_set_name = List.nth (rep_set_names, i)
  12.406 +          in (HOLogic.all_const T $ Abs ("y", T, HOLogic.imp $
  12.407 +                HOLogic.mk_eq (Rep_t $ mk_Free "x" T i, Rep_t $ Bound 0) $
  12.408 +                  HOLogic.mk_eq (mk_Free "x" T i, Bound 0)),
  12.409 +              Const (rep_set_name, UnivT') $ (Rep_t $ mk_Free "x" T i))
  12.410 +          end;
  12.411 +
  12.412 +        val (ind_concl1, ind_concl2) = ListPair.unzip (map mk_ind_concl ds);
  12.413 +
  12.414 +        val rewrites = map mk_meta_eq iso_char_thms;
  12.415 +        val inj_thms' = map snd newT_iso_inj_thms @
  12.416 +          map (fn r => r RS @{thm injD}) inj_thms;
  12.417 +
  12.418 +        val inj_thm = SkipProof.prove_global thy5 [] []
  12.419 +          (HOLogic.mk_Trueprop (mk_conj ind_concl1)) (fn _ => EVERY
  12.420 +            [(indtac induction [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
  12.421 +             REPEAT (EVERY
  12.422 +               [rtac allI 1, rtac impI 1,
  12.423 +                exh_tac (exh_thm_of dt_info) 1,
  12.424 +                REPEAT (EVERY
  12.425 +                  [hyp_subst_tac 1,
  12.426 +                   rewrite_goals_tac rewrites,
  12.427 +                   REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  12.428 +                   (eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1)
  12.429 +                   ORELSE (EVERY
  12.430 +                     [REPEAT (eresolve_tac (Scons_inject ::
  12.431 +                        map make_elim [Leaf_inject, Inl_inject, Inr_inject]) 1),
  12.432 +                      REPEAT (cong_tac 1), rtac refl 1,
  12.433 +                      REPEAT (atac 1 ORELSE (EVERY
  12.434 +                        [REPEAT (rtac ext 1),
  12.435 +                         REPEAT (eresolve_tac (mp :: allE ::
  12.436 +                           map make_elim (Suml_inject :: Sumr_inject ::
  12.437 +                             Lim_inject :: inj_thms') @ fun_congs) 1),
  12.438 +                         atac 1]))])])])]);
  12.439 +
  12.440 +        val inj_thms'' = map (fn r => r RS @{thm datatype_injI})
  12.441 +                             (split_conj_thm inj_thm);
  12.442 +
  12.443 +        val elem_thm = 
  12.444 +            SkipProof.prove_global thy5 [] [] (HOLogic.mk_Trueprop (mk_conj ind_concl2))
  12.445 +              (fn _ =>
  12.446 +               EVERY [(indtac induction [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
  12.447 +                rewrite_goals_tac rewrites,
  12.448 +                REPEAT ((resolve_tac rep_intrs THEN_ALL_NEW
  12.449 +                  ((REPEAT o etac allE) THEN' ares_tac elem_thms)) 1)]);
  12.450 +
  12.451 +      in (inj_thms'' @ inj_thms, elem_thms @ (split_conj_thm elem_thm))
  12.452 +      end;
  12.453 +
  12.454 +    val (iso_inj_thms_unfolded, iso_elem_thms) = List.foldr prove_iso_thms
  12.455 +      ([], map #3 newT_iso_axms) (tl descr);
  12.456 +    val iso_inj_thms = map snd newT_iso_inj_thms @
  12.457 +      map (fn r => r RS @{thm injD}) iso_inj_thms_unfolded;
  12.458 +
  12.459 +    (* prove  dt_rep_set_i x --> x : range dt_Rep_i *)
  12.460 +
  12.461 +    fun mk_iso_t (((set_name, iso_name), i), T) =
  12.462 +      let val isoT = T --> Univ_elT
  12.463 +      in HOLogic.imp $ 
  12.464 +        (Const (set_name, UnivT') $ mk_Free "x" Univ_elT i) $
  12.465 +          (if i < length newTs then HOLogic.true_const
  12.466 +           else HOLogic.mk_mem (mk_Free "x" Univ_elT i,
  12.467 +             Const (@{const_name image}, isoT --> HOLogic.mk_setT T --> UnivT) $
  12.468 +               Const (iso_name, isoT) $ Const (@{const_name UNIV}, HOLogic.mk_setT T)))
  12.469 +      end;
  12.470 +
  12.471 +    val iso_t = HOLogic.mk_Trueprop (mk_conj (map mk_iso_t
  12.472 +      (rep_set_names ~~ all_rep_names ~~ (0 upto (length descr' - 1)) ~~ recTs)));
  12.473 +
  12.474 +    (* all the theorems are proved by one single simultaneous induction *)
  12.475 +
  12.476 +    val range_eqs = map (fn r => mk_meta_eq (r RS @{thm range_ex1_eq}))
  12.477 +      iso_inj_thms_unfolded;
  12.478 +
  12.479 +    val iso_thms = if length descr = 1 then [] else
  12.480 +      Library.drop (length newTs, split_conj_thm
  12.481 +        (SkipProof.prove_global thy5 [] [] iso_t (fn _ => EVERY
  12.482 +           [(indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
  12.483 +            REPEAT (rtac TrueI 1),
  12.484 +            rewrite_goals_tac (mk_meta_eq choice_eq ::
  12.485 +              symmetric (mk_meta_eq @{thm expand_fun_eq}) :: range_eqs),
  12.486 +            rewrite_goals_tac (map symmetric range_eqs),
  12.487 +            REPEAT (EVERY
  12.488 +              [REPEAT (eresolve_tac ([rangeE, ex1_implies_ex RS exE] @
  12.489 +                 maps (mk_funs_inv thy5 o #1) newT_iso_axms) 1),
  12.490 +               TRY (hyp_subst_tac 1),
  12.491 +               rtac (sym RS range_eqI) 1,
  12.492 +               resolve_tac iso_char_thms 1])])));
  12.493 +
  12.494 +    val Abs_inverse_thms' =
  12.495 +      map #1 newT_iso_axms @
  12.496 +      map2 (fn r_inj => fn r => f_myinv_f OF [r_inj, r RS mp])
  12.497 +        iso_inj_thms_unfolded iso_thms;
  12.498 +
  12.499 +    val Abs_inverse_thms = maps (mk_funs_inv thy5) Abs_inverse_thms';
  12.500 +
  12.501 +    (******************* freeness theorems for constructors *******************)
  12.502 +
  12.503 +    val _ = message config "Proving freeness of constructors ...";
  12.504 +
  12.505 +    (* prove theorem  Rep_i (Constr_j ...) = Inj_j ...  *)
  12.506 +    
  12.507 +    fun prove_constr_rep_thm eqn =
  12.508 +      let
  12.509 +        val inj_thms = map fst newT_iso_inj_thms;
  12.510 +        val rewrites = @{thm o_def} :: constr_defs @ (map (mk_meta_eq o #2) newT_iso_axms)
  12.511 +      in SkipProof.prove_global thy5 [] [] eqn (fn _ => EVERY
  12.512 +        [resolve_tac inj_thms 1,
  12.513 +         rewrite_goals_tac rewrites,
  12.514 +         rtac refl 3,
  12.515 +         resolve_tac rep_intrs 2,
  12.516 +         REPEAT (resolve_tac iso_elem_thms 1)])
  12.517 +      end;
  12.518 +
  12.519 +    (*--------------------------------------------------------------*)
  12.520 +    (* constr_rep_thms and rep_congs are used to prove distinctness *)
  12.521 +    (* of constructors.                                             *)
  12.522 +    (*--------------------------------------------------------------*)
  12.523 +
  12.524 +    val constr_rep_thms = map (map prove_constr_rep_thm) constr_rep_eqns;
  12.525 +
  12.526 +    val dist_rewrites = map (fn (rep_thms, dist_lemma) =>
  12.527 +      dist_lemma::(rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0]))
  12.528 +        (constr_rep_thms ~~ dist_lemmas);
  12.529 +
  12.530 +    fun prove_distinct_thms _ _ (_, []) = []
  12.531 +      | prove_distinct_thms lim dist_rewrites' (k, ts as _ :: _) =
  12.532 +          if k >= lim then [] else let
  12.533 +            (*number of constructors < distinctness_limit : C_i ... ~= C_j ...*)
  12.534 +            fun prove [] = []
  12.535 +              | prove (t :: ts) =
  12.536 +                  let
  12.537 +                    val dist_thm = SkipProof.prove_global thy5 [] [] t (fn _ =>
  12.538 +                      EVERY [simp_tac (HOL_ss addsimps dist_rewrites') 1])
  12.539 +                  in dist_thm :: standard (dist_thm RS not_sym) :: prove ts end;
  12.540 +          in prove ts end;
  12.541 +
  12.542 +    val distinct_thms = DatatypeProp.make_distincts descr sorts
  12.543 +      |> map2 (prove_distinct_thms
  12.544 +           (Config.get_thy thy5 distinctness_limit)) dist_rewrites;
  12.545 +
  12.546 +    val simproc_dists = map (fn ((((_, (_, _, constrs)), rep_thms), congr), dists) =>
  12.547 +      if length constrs < Config.get_thy thy5 distinctness_limit
  12.548 +      then FewConstrs dists
  12.549 +      else ManyConstrs (congr, HOL_basic_ss addsimps rep_thms)) (hd descr ~~
  12.550 +        constr_rep_thms ~~ rep_congs ~~ distinct_thms);
  12.551 +
  12.552 +    (* prove injectivity of constructors *)
  12.553 +
  12.554 +    fun prove_constr_inj_thm rep_thms t =
  12.555 +      let val inj_thms = Scons_inject :: (map make_elim
  12.556 +        (iso_inj_thms @
  12.557 +          [In0_inject, In1_inject, Leaf_inject, Inl_inject, Inr_inject,
  12.558 +           Lim_inject, Suml_inject, Sumr_inject]))
  12.559 +      in SkipProof.prove_global thy5 [] [] t (fn _ => EVERY
  12.560 +        [rtac iffI 1,
  12.561 +         REPEAT (etac conjE 2), hyp_subst_tac 2, rtac refl 2,
  12.562 +         dresolve_tac rep_congs 1, dtac box_equals 1,
  12.563 +         REPEAT (resolve_tac rep_thms 1),
  12.564 +         REPEAT (eresolve_tac inj_thms 1),
  12.565 +         REPEAT (ares_tac [conjI] 1 ORELSE (EVERY [REPEAT (rtac ext 1),
  12.566 +           REPEAT (eresolve_tac (make_elim fun_cong :: inj_thms) 1),
  12.567 +           atac 1]))])
  12.568 +      end;
  12.569 +
  12.570 +    val constr_inject = map (fn (ts, thms) => map (prove_constr_inj_thm thms) ts)
  12.571 +      ((DatatypeProp.make_injs descr sorts) ~~ constr_rep_thms);
  12.572 +
  12.573 +    val ((constr_inject', distinct_thms'), thy6) =
  12.574 +      thy5
  12.575 +      |> parent_path (#flat_names config)
  12.576 +      |> store_thmss "inject" new_type_names constr_inject
  12.577 +      ||>> store_thmss "distinct" new_type_names distinct_thms;
  12.578 +
  12.579 +    (*************************** induction theorem ****************************)
  12.580 +
  12.581 +    val _ = message config "Proving induction rule for datatypes ...";
  12.582 +
  12.583 +    val Rep_inverse_thms = (map (fn (_, iso, _) => iso RS subst) newT_iso_axms) @
  12.584 +      (map (fn r => r RS myinv_f_f RS subst) iso_inj_thms_unfolded);
  12.585 +    val Rep_inverse_thms' = map (fn r => r RS myinv_f_f) iso_inj_thms_unfolded;
  12.586 +
  12.587 +    fun mk_indrule_lemma ((prems, concls), ((i, _), T)) =
  12.588 +      let
  12.589 +        val Rep_t = Const (List.nth (all_rep_names, i), T --> Univ_elT) $
  12.590 +          mk_Free "x" T i;
  12.591 +
  12.592 +        val Abs_t = if i < length newTs then
  12.593 +            Const (Sign.intern_const thy6
  12.594 +              ("Abs_" ^ (List.nth (new_type_names, i))), Univ_elT --> T)
  12.595 +          else Const ("Inductive.myinv", [T --> Univ_elT, Univ_elT] ---> T) $
  12.596 +            Const (List.nth (all_rep_names, i), T --> Univ_elT)
  12.597 +
  12.598 +      in (prems @ [HOLogic.imp $
  12.599 +            (Const (List.nth (rep_set_names, i), UnivT') $ Rep_t) $
  12.600 +              (mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
  12.601 +          concls @ [mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ mk_Free "x" T i])
  12.602 +      end;
  12.603 +
  12.604 +    val (indrule_lemma_prems, indrule_lemma_concls) =
  12.605 +      Library.foldl mk_indrule_lemma (([], []), (descr' ~~ recTs));
  12.606 +
  12.607 +    val cert = cterm_of thy6;
  12.608 +
  12.609 +    val indrule_lemma = SkipProof.prove_global thy6 [] []
  12.610 +      (Logic.mk_implies
  12.611 +        (HOLogic.mk_Trueprop (mk_conj indrule_lemma_prems),
  12.612 +         HOLogic.mk_Trueprop (mk_conj indrule_lemma_concls))) (fn _ => EVERY
  12.613 +           [REPEAT (etac conjE 1),
  12.614 +            REPEAT (EVERY
  12.615 +              [TRY (rtac conjI 1), resolve_tac Rep_inverse_thms 1,
  12.616 +               etac mp 1, resolve_tac iso_elem_thms 1])]);
  12.617 +
  12.618 +    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
  12.619 +    val frees = if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))] else
  12.620 +      map (Free o apfst fst o dest_Var) Ps;
  12.621 +    val indrule_lemma' = cterm_instantiate (map cert Ps ~~ map cert frees) indrule_lemma;
  12.622 +
  12.623 +    val dt_induct_prop = DatatypeProp.make_ind descr sorts;
  12.624 +    val dt_induct = SkipProof.prove_global thy6 []
  12.625 +      (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
  12.626 +      (fn {prems, ...} => EVERY
  12.627 +        [rtac indrule_lemma' 1,
  12.628 +         (indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
  12.629 +         EVERY (map (fn (prem, r) => (EVERY
  12.630 +           [REPEAT (eresolve_tac Abs_inverse_thms 1),
  12.631 +            simp_tac (HOL_basic_ss addsimps ((symmetric r)::Rep_inverse_thms')) 1,
  12.632 +            DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
  12.633 +                (prems ~~ (constr_defs @ (map mk_meta_eq iso_char_thms))))]);
  12.634 +
  12.635 +    val ([dt_induct'], thy7) =
  12.636 +      thy6
  12.637 +      |> Sign.add_path big_name
  12.638 +      |> PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])]
  12.639 +      ||> Sign.parent_path
  12.640 +      ||> Theory.checkpoint;
  12.641 +
  12.642 +  in
  12.643 +    ((constr_inject', distinct_thms', dist_rewrites, simproc_dists, dt_induct'), thy7)
  12.644 +  end;
  12.645 +
  12.646 +end;
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Tools/Function/auto_term.ML	Tue Jun 23 12:09:30 2009 +0200
    13.3 @@ -0,0 +1,36 @@
    13.4 +(*  Title:      HOL/Tools/Function/auto_term.ML
    13.5 +    Author:     Alexander Krauss, TU Muenchen
    13.6 +
    13.7 +A package for general recursive function definitions.
    13.8 +Method "relation" to commence a termination proof using a user-specified relation.
    13.9 +*)
   13.10 +
   13.11 +signature FUNDEF_RELATION =
   13.12 +sig
   13.13 +  val relation_tac: Proof.context -> term -> int -> tactic
   13.14 +  val setup: theory -> theory
   13.15 +end
   13.16 +
   13.17 +structure FundefRelation : FUNDEF_RELATION =
   13.18 +struct
   13.19 +
   13.20 +fun inst_thm ctxt rel st =
   13.21 +    let
   13.22 +      val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
   13.23 +      val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
   13.24 +      val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
   13.25 +      val Rvar = cert (Var (the_single (Term.add_vars (prop_of st') [])))
   13.26 +    in 
   13.27 +      Drule.cterm_instantiate [(Rvar, rel')] st' 
   13.28 +    end
   13.29 +
   13.30 +fun relation_tac ctxt rel i = 
   13.31 +    TRY (FundefCommon.apply_termination_rule ctxt i)
   13.32 +    THEN PRIMITIVE (inst_thm ctxt rel)
   13.33 +
   13.34 +val setup =
   13.35 +  Method.setup @{binding relation}
   13.36 +    (Args.term >> (fn rel => fn ctxt => SIMPLE_METHOD' (relation_tac ctxt rel)))
   13.37 +    "proves termination using a user-specified wellfounded relation"
   13.38 +
   13.39 +end
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Tools/Function/context_tree.ML	Tue Jun 23 12:09:30 2009 +0200
    14.3 @@ -0,0 +1,278 @@
    14.4 +(*  Title:      HOL/Tools/Function/context_tree.ML
    14.5 +    Author:     Alexander Krauss, TU Muenchen
    14.6 +
    14.7 +A package for general recursive function definitions. 
    14.8 +Builds and traverses trees of nested contexts along a term.
    14.9 +*)
   14.10 +
   14.11 +signature FUNDEF_CTXTREE =
   14.12 +sig
   14.13 +    type ctxt = (string * typ) list * thm list (* poor man's contexts: fixes + assumes *)
   14.14 +    type ctx_tree
   14.15 +
   14.16 +    (* FIXME: This interface is a mess and needs to be cleaned up! *)
   14.17 +    val get_fundef_congs : Proof.context -> thm list
   14.18 +    val add_fundef_cong : thm -> Context.generic -> Context.generic
   14.19 +    val map_fundef_congs : (thm list -> thm list) -> Context.generic -> Context.generic
   14.20 +
   14.21 +    val cong_add: attribute
   14.22 +    val cong_del: attribute
   14.23 +
   14.24 +    val mk_tree: (string * typ) -> term -> Proof.context -> term -> ctx_tree
   14.25 +
   14.26 +    val inst_tree: theory -> term -> term -> ctx_tree -> ctx_tree
   14.27 +
   14.28 +    val export_term : ctxt -> term -> term
   14.29 +    val export_thm : theory -> ctxt -> thm -> thm
   14.30 +    val import_thm : theory -> ctxt -> thm -> thm
   14.31 +
   14.32 +    val traverse_tree : 
   14.33 +   (ctxt -> term ->
   14.34 +   (ctxt * thm) list ->
   14.35 +   (ctxt * thm) list * 'b ->
   14.36 +   (ctxt * thm) list * 'b)
   14.37 +   -> ctx_tree -> 'b -> 'b
   14.38 +
   14.39 +    val rewrite_by_tree : theory -> term -> thm -> (thm * thm) list -> ctx_tree -> thm * (thm * thm) list
   14.40 +end
   14.41 +
   14.42 +structure FundefCtxTree : FUNDEF_CTXTREE =
   14.43 +struct
   14.44 +
   14.45 +type ctxt = (string * typ) list * thm list
   14.46 +
   14.47 +open FundefCommon
   14.48 +open FundefLib
   14.49 +
   14.50 +structure FundefCongs = GenericDataFun
   14.51 +(
   14.52 +  type T = thm list
   14.53 +  val empty = []
   14.54 +  val extend = I
   14.55 +  fun merge _ = Thm.merge_thms
   14.56 +);
   14.57 +
   14.58 +val get_fundef_congs = FundefCongs.get o Context.Proof
   14.59 +val map_fundef_congs = FundefCongs.map
   14.60 +val add_fundef_cong = FundefCongs.map o Thm.add_thm
   14.61 +
   14.62 +(* congruence rules *)
   14.63 +
   14.64 +val cong_add = Thm.declaration_attribute (map_fundef_congs o Thm.add_thm o safe_mk_meta_eq);
   14.65 +val cong_del = Thm.declaration_attribute (map_fundef_congs o Thm.del_thm o safe_mk_meta_eq);
   14.66 +
   14.67 +
   14.68 +type depgraph = int IntGraph.T
   14.69 +
   14.70 +datatype ctx_tree 
   14.71 +  = Leaf of term
   14.72 +  | Cong of (thm * depgraph * (ctxt * ctx_tree) list)
   14.73 +  | RCall of (term * ctx_tree)
   14.74 +
   14.75 +
   14.76 +(* Maps "Trueprop A = B" to "A" *)
   14.77 +val rhs_of = snd o HOLogic.dest_eq o HOLogic.dest_Trueprop
   14.78 +
   14.79 +
   14.80 +(*** Dependency analysis for congruence rules ***)
   14.81 +
   14.82 +fun branch_vars t = 
   14.83 +    let 
   14.84 +      val t' = snd (dest_all_all t)
   14.85 +      val (assumes, concl) = Logic.strip_horn t'
   14.86 +    in (fold Term.add_vars assumes [], Term.add_vars concl [])
   14.87 +    end
   14.88 +
   14.89 +fun cong_deps crule =
   14.90 +    let
   14.91 +      val num_branches = map_index (apsnd branch_vars) (prems_of crule)
   14.92 +    in
   14.93 +      IntGraph.empty
   14.94 +        |> fold (fn (i,_)=> IntGraph.new_node (i,i)) num_branches
   14.95 +        |> fold_product (fn (i, (c1, _)) => fn (j, (_, t2)) => 
   14.96 +               if i = j orelse null (c1 inter t2) 
   14.97 +               then I else IntGraph.add_edge_acyclic (i,j))
   14.98 +             num_branches num_branches
   14.99 +    end
  14.100 +    
  14.101 +val default_congs = map (fn c => c RS eq_reflection) [@{thm "cong"}, @{thm "ext"}] 
  14.102 +
  14.103 +
  14.104 +
  14.105 +(* Called on the INSTANTIATED branches of the congruence rule *)
  14.106 +fun mk_branch ctx t = 
  14.107 +    let
  14.108 +      val (ctx', fixes, impl) = dest_all_all_ctx ctx t
  14.109 +      val (assms, concl) = Logic.strip_horn impl
  14.110 +    in
  14.111 +      (ctx', fixes, assms, rhs_of concl)
  14.112 +    end
  14.113 +    
  14.114 +fun find_cong_rule ctx fvar h ((r,dep)::rs) t =
  14.115 +    (let
  14.116 +       val thy = ProofContext.theory_of ctx
  14.117 +
  14.118 +       val tt' = Logic.mk_equals (Pattern.rewrite_term thy [(Free fvar, h)] [] t, t)
  14.119 +       val (c, subs) = (concl_of r, prems_of r)
  14.120 +
  14.121 +       val subst = Pattern.match (ProofContext.theory_of ctx) (c, tt') (Vartab.empty, Vartab.empty)
  14.122 +       val branches = map (mk_branch ctx o Envir.beta_norm o Envir.subst_vars subst) subs
  14.123 +       val inst = map (fn v => (cterm_of thy (Var v), cterm_of thy (Envir.subst_vars subst (Var v)))) (Term.add_vars c [])
  14.124 +     in
  14.125 +   (cterm_instantiate inst r, dep, branches)
  14.126 +     end
  14.127 +    handle Pattern.MATCH => find_cong_rule ctx fvar h rs t)
  14.128 +  | find_cong_rule _ _ _ [] _ = sys_error "Function/context_tree.ML: No cong rule found!"
  14.129 +
  14.130 +
  14.131 +fun mk_tree fvar h ctxt t =
  14.132 +    let 
  14.133 +      val congs = get_fundef_congs ctxt
  14.134 +      val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs) (* FIXME: Save in theory *)
  14.135 +
  14.136 +      fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE
  14.137 +        | matchcall _ = NONE
  14.138 +
  14.139 +      fun mk_tree' ctx t =
  14.140 +          case matchcall t of
  14.141 +            SOME arg => RCall (t, mk_tree' ctx arg)
  14.142 +          | NONE => 
  14.143 +            if not (exists_subterm (fn Free v => v = fvar | _ => false) t) then Leaf t
  14.144 +            else 
  14.145 +              let val (r, dep, branches) = find_cong_rule ctx fvar h congs_deps t in
  14.146 +                Cong (r, dep, 
  14.147 +                      map (fn (ctx', fixes, assumes, st) => 
  14.148 +                              ((fixes, map (assume o cterm_of (ProofContext.theory_of ctx)) assumes), 
  14.149 +                               mk_tree' ctx' st)) branches)
  14.150 +              end
  14.151 +    in
  14.152 +      mk_tree' ctxt t
  14.153 +    end
  14.154 +    
  14.155 +
  14.156 +fun inst_tree thy fvar f tr =
  14.157 +    let
  14.158 +      val cfvar = cterm_of thy fvar
  14.159 +      val cf = cterm_of thy f
  14.160 +               
  14.161 +      fun inst_term t = 
  14.162 +          subst_bound(f, abstract_over (fvar, t))
  14.163 +
  14.164 +      val inst_thm = forall_elim cf o forall_intr cfvar 
  14.165 +
  14.166 +      fun inst_tree_aux (Leaf t) = Leaf t
  14.167 +        | inst_tree_aux (Cong (crule, deps, branches)) =
  14.168 +          Cong (inst_thm crule, deps, map inst_branch branches)
  14.169 +        | inst_tree_aux (RCall (t, str)) =
  14.170 +          RCall (inst_term t, inst_tree_aux str)
  14.171 +      and inst_branch ((fxs, assms), str) = 
  14.172 +          ((fxs, map (assume o cterm_of thy o inst_term o prop_of) assms), inst_tree_aux str)
  14.173 +    in
  14.174 +      inst_tree_aux tr
  14.175 +    end
  14.176 +
  14.177 +
  14.178 +(* Poor man's contexts: Only fixes and assumes *)
  14.179 +fun compose (fs1, as1) (fs2, as2) = (fs1 @ fs2, as1 @ as2)
  14.180 +
  14.181 +fun export_term (fixes, assumes) =
  14.182 +    fold_rev (curry Logic.mk_implies o prop_of) assumes 
  14.183 + #> fold_rev (Logic.all o Free) fixes
  14.184 +
  14.185 +fun export_thm thy (fixes, assumes) =
  14.186 +    fold_rev (implies_intr o cprop_of) assumes
  14.187 + #> fold_rev (forall_intr o cterm_of thy o Free) fixes
  14.188 +
  14.189 +fun import_thm thy (fixes, athms) =
  14.190 +    fold (forall_elim o cterm_of thy o Free) fixes
  14.191 + #> fold Thm.elim_implies athms
  14.192 +
  14.193 +
  14.194 +(* folds in the order of the dependencies of a graph. *)
  14.195 +fun fold_deps G f x =
  14.196 +    let
  14.197 +      fun fill_table i (T, x) =
  14.198 +          case Inttab.lookup T i of
  14.199 +            SOME _ => (T, x)
  14.200 +          | NONE => 
  14.201 +            let
  14.202 +              val (T', x') = fold fill_table (IntGraph.imm_succs G i) (T, x)
  14.203 +              val (v, x'') = f (the o Inttab.lookup T') i x'
  14.204 +            in
  14.205 +              (Inttab.update (i, v) T', x'')
  14.206 +            end
  14.207 +            
  14.208 +      val (T, x) = fold fill_table (IntGraph.keys G) (Inttab.empty, x)
  14.209 +    in
  14.210 +      (Inttab.fold (cons o snd) T [], x)
  14.211 +    end
  14.212 +    
  14.213 +fun traverse_tree rcOp tr =
  14.214 +    let 
  14.215 +  fun traverse_help ctx (Leaf _) _ x = ([], x)
  14.216 +    | traverse_help ctx (RCall (t, st)) u x =
  14.217 +      rcOp ctx t u (traverse_help ctx st u x)
  14.218 +    | traverse_help ctx (Cong (_, deps, branches)) u x =
  14.219 +      let
  14.220 +    fun sub_step lu i x =
  14.221 +        let
  14.222 +          val (ctx', subtree) = nth branches i
  14.223 +          val used = fold_rev (append o lu) (IntGraph.imm_succs deps i) u
  14.224 +          val (subs, x') = traverse_help (compose ctx ctx') subtree used x
  14.225 +          val exported_subs = map (apfst (compose ctx')) subs (* FIXME: Right order of composition? *)
  14.226 +        in
  14.227 +          (exported_subs, x')
  14.228 +        end
  14.229 +      in
  14.230 +        fold_deps deps sub_step x
  14.231 +          |> apfst flat
  14.232 +      end
  14.233 +    in
  14.234 +      snd o traverse_help ([], []) tr []
  14.235 +    end
  14.236 +
  14.237 +fun rewrite_by_tree thy h ih x tr =
  14.238 +    let
  14.239 +      fun rewrite_help _ _ x (Leaf t) = (reflexive (cterm_of thy t), x)
  14.240 +        | rewrite_help fix h_as x (RCall (_ $ arg, st)) =
  14.241 +          let
  14.242 +            val (inner, (lRi,ha)::x') = rewrite_help fix h_as x st (* "a' = a" *)
  14.243 +                                                     
  14.244 +            val iha = import_thm thy (fix, h_as) ha (* (a', h a') : G *)
  14.245 +                 |> Conv.fconv_rule (Conv.arg_conv (Conv.comb_conv (Conv.arg_conv (K inner))))
  14.246 +                                                    (* (a, h a) : G   *)
  14.247 +            val inst_ih = instantiate' [] [SOME (cterm_of thy arg)] ih
  14.248 +            val eq = implies_elim (implies_elim inst_ih lRi) iha (* h a = f a *)
  14.249 +                     
  14.250 +            val h_a'_eq_h_a = combination (reflexive (cterm_of thy h)) inner
  14.251 +            val h_a_eq_f_a = eq RS eq_reflection
  14.252 +            val result = transitive h_a'_eq_h_a h_a_eq_f_a
  14.253 +          in
  14.254 +            (result, x')
  14.255 +          end
  14.256 +        | rewrite_help fix h_as x (Cong (crule, deps, branches)) =
  14.257 +          let
  14.258 +            fun sub_step lu i x =
  14.259 +                let
  14.260 +                  val ((fixes, assumes), st) = nth branches i
  14.261 +                  val used = map lu (IntGraph.imm_succs deps i)
  14.262 +                             |> map (fn u_eq => (u_eq RS sym) RS eq_reflection)
  14.263 +                             |> filter_out Thm.is_reflexive
  14.264 +
  14.265 +                  val assumes' = map (simplify (HOL_basic_ss addsimps used)) assumes
  14.266 +                                 
  14.267 +                  val (subeq, x') = rewrite_help (fix @ fixes) (h_as @ assumes') x st
  14.268 +                  val subeq_exp = export_thm thy (fixes, assumes) (subeq RS meta_eq_to_obj_eq)
  14.269 +                in
  14.270 +                  (subeq_exp, x')
  14.271 +                end
  14.272 +                
  14.273 +            val (subthms, x') = fold_deps deps sub_step x
  14.274 +          in
  14.275 +            (fold_rev (curry op COMP) subthms crule, x')
  14.276 +          end
  14.277 +    in
  14.278 +      rewrite_help [] [] x tr
  14.279 +    end
  14.280 +    
  14.281 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Tools/Function/decompose.ML	Tue Jun 23 12:09:30 2009 +0200
    15.3 @@ -0,0 +1,105 @@
    15.4 +(*  Title:       HOL/Tools/Function/decompose.ML
    15.5 +    Author:      Alexander Krauss, TU Muenchen
    15.6 +
    15.7 +Graph decomposition using "Shallow Dependency Pairs".
    15.8 +*)
    15.9 +
   15.10 +signature DECOMPOSE =
   15.11 +sig
   15.12 +
   15.13 +  val derive_chains : Proof.context -> tactic
   15.14 +                      -> (Termination.data -> int -> tactic)
   15.15 +                      -> Termination.data -> int -> tactic
   15.16 +
   15.17 +  val decompose_tac : Proof.context -> tactic
   15.18 +                      -> Termination.ttac
   15.19 +
   15.20 +end
   15.21 +
   15.22 +structure Decompose : DECOMPOSE =
   15.23 +struct
   15.24 +
   15.25 +structure TermGraph = GraphFun(type key = term val ord = TermOrd.fast_term_ord);
   15.26 +
   15.27 +
   15.28 +fun derive_chains ctxt chain_tac cont D = Termination.CALLS (fn (cs, i) =>
   15.29 +  let
   15.30 +      val thy = ProofContext.theory_of ctxt
   15.31 +
   15.32 +      fun prove_chain c1 c2 D =
   15.33 +          if is_some (Termination.get_chain D c1 c2) then D else
   15.34 +          let
   15.35 +            val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name "Relation.rel_comp"} (c1, c2),
   15.36 +                                      Const (@{const_name Set.empty}, fastype_of c1))
   15.37 +                       |> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *)
   15.38 +
   15.39 +            val chain = case FundefLib.try_proof (cterm_of thy goal) chain_tac of
   15.40 +                          FundefLib.Solved thm => SOME thm
   15.41 +                        | _ => NONE
   15.42 +          in
   15.43 +            Termination.note_chain c1 c2 chain D
   15.44 +          end
   15.45 +  in
   15.46 +    cont (fold_product prove_chain cs cs D) i
   15.47 +  end)
   15.48 +
   15.49 +
   15.50 +fun mk_dgraph D cs =
   15.51 +    TermGraph.empty
   15.52 +    |> fold (fn c => TermGraph.new_node (c,())) cs
   15.53 +    |> fold_product (fn c1 => fn c2 =>
   15.54 +         if is_none (Termination.get_chain D c1 c2 |> the_default NONE)
   15.55 +         then TermGraph.add_edge (c1, c2) else I)
   15.56 +       cs cs
   15.57 +
   15.58 +
   15.59 +fun ucomp_empty_tac T =
   15.60 +    REPEAT_ALL_NEW (rtac @{thm union_comp_emptyR}
   15.61 +                    ORELSE' rtac @{thm union_comp_emptyL}
   15.62 +                    ORELSE' SUBGOAL (fn (_ $ (_ $ (_ $ c1 $ c2) $ _), i) => rtac (T c1 c2) i))
   15.63 +
   15.64 +fun regroup_calls_tac cs = Termination.CALLS (fn (cs', i) =>
   15.65 +   let
   15.66 +     val is = map (fn c => find_index (curry op aconv c) cs') cs
   15.67 +   in
   15.68 +     CONVERSION (Conv.arg_conv (Conv.arg_conv (FundefLib.regroup_union_conv is))) i
   15.69 +   end)
   15.70 +
   15.71 +
   15.72 +fun solve_trivial_tac D = Termination.CALLS
   15.73 +(fn ([c], i) =>
   15.74 +    (case Termination.get_chain D c c of
   15.75 +       SOME (SOME thm) => rtac @{thm wf_no_loop} i
   15.76 +                          THEN rtac thm i
   15.77 +     | _ => no_tac)
   15.78 +  | _ => no_tac)
   15.79 +
   15.80 +fun decompose_tac' ctxt cont err_cont D = Termination.CALLS (fn (cs, i) =>
   15.81 +    let
   15.82 +      val G = mk_dgraph D cs
   15.83 +      val sccs = TermGraph.strong_conn G
   15.84 +
   15.85 +      fun split [SCC] i = (solve_trivial_tac D i ORELSE cont D i)
   15.86 +        | split (SCC::rest) i =
   15.87 +            regroup_calls_tac SCC i
   15.88 +            THEN rtac @{thm wf_union_compatible} i
   15.89 +            THEN rtac @{thm less_by_empty} (i + 2)
   15.90 +            THEN ucomp_empty_tac (the o the oo Termination.get_chain D) (i + 2)
   15.91 +            THEN split rest (i + 1)
   15.92 +            THEN (solve_trivial_tac D i ORELSE cont D i)
   15.93 +    in
   15.94 +      if length sccs > 1 then split sccs i
   15.95 +      else solve_trivial_tac D i ORELSE err_cont D i
   15.96 +    end)
   15.97 +
   15.98 +fun decompose_tac ctxt chain_tac cont err_cont =
   15.99 +    derive_chains ctxt chain_tac
  15.100 +    (decompose_tac' ctxt cont err_cont)
  15.101 +
  15.102 +fun auto_decompose_tac ctxt =
  15.103 +    Termination.TERMINATION ctxt
  15.104 +      (decompose_tac ctxt (auto_tac (local_clasimpset_of ctxt))
  15.105 +                     (K (K all_tac)) (K (K no_tac)))
  15.106 +
  15.107 +
  15.108 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Tools/Function/descent.ML	Tue Jun 23 12:09:30 2009 +0200
    16.3 @@ -0,0 +1,44 @@
    16.4 +(*  Title:       HOL/Tools/Function/descent.ML
    16.5 +    Author:      Alexander Krauss, TU Muenchen
    16.6 +
    16.7 +Descent proofs for termination
    16.8 +*)
    16.9 +
   16.10 +
   16.11 +signature DESCENT =
   16.12 +sig
   16.13 +
   16.14 +  val derive_diag : Proof.context -> tactic -> (Termination.data -> int -> tactic)
   16.15 +                    -> Termination.data -> int -> tactic
   16.16 +
   16.17 +  val derive_all  : Proof.context -> tactic -> (Termination.data -> int -> tactic)
   16.18 +                    -> Termination.data -> int -> tactic
   16.19 +
   16.20 +end
   16.21 +
   16.22 +
   16.23 +structure Descent : DESCENT =
   16.24 +struct
   16.25 +
   16.26 +fun gen_descent diag ctxt tac cont D = Termination.CALLS (fn (cs, i) =>
   16.27 +  let
   16.28 +    val thy = ProofContext.theory_of ctxt
   16.29 +    val measures_of = Termination.get_measures D
   16.30 +
   16.31 +    fun derive c D =
   16.32 +      let
   16.33 +        val (_, p, _, q, _, _) = Termination.dest_call D c
   16.34 +      in
   16.35 +        if diag andalso p = q
   16.36 +        then fold (fn m => Termination.derive_descent thy tac c m m) (measures_of p) D
   16.37 +        else fold_product (Termination.derive_descent thy tac c)
   16.38 +               (measures_of p) (measures_of q) D
   16.39 +      end
   16.40 +  in
   16.41 +    cont (FundefCommon.PROFILE "deriving descents" (fold derive cs) D) i
   16.42 +  end)
   16.43 +
   16.44 +val derive_diag = gen_descent true
   16.45 +val derive_all = gen_descent false
   16.46 +
   16.47 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Tools/Function/fundef.ML	Tue Jun 23 12:09:30 2009 +0200
    17.3 @@ -0,0 +1,226 @@
    17.4 +(*  Title:      HOL/Tools/Function/fundef.ML
    17.5 +    Author:     Alexander Krauss, TU Muenchen
    17.6 +
    17.7 +A package for general recursive function definitions.
    17.8 +Isar commands.
    17.9 +*)
   17.10 +
   17.11 +signature FUNDEF =
   17.12 +sig
   17.13 +    val add_fundef :  (binding * typ option * mixfix) list
   17.14 +                       -> (Attrib.binding * term) list
   17.15 +                       -> FundefCommon.fundef_config
   17.16 +                       -> local_theory
   17.17 +                       -> Proof.state
   17.18 +    val add_fundef_cmd :  (binding * string option * mixfix) list
   17.19 +                      -> (Attrib.binding * string) list
   17.20 +                      -> FundefCommon.fundef_config
   17.21 +                      -> local_theory
   17.22 +                      -> Proof.state
   17.23 +
   17.24 +    val termination_proof : term option -> local_theory -> Proof.state
   17.25 +    val termination_proof_cmd : string option -> local_theory -> Proof.state
   17.26 +    val termination : term option -> local_theory -> Proof.state
   17.27 +    val termination_cmd : string option -> local_theory -> Proof.state
   17.28 +
   17.29 +    val setup : theory -> theory
   17.30 +    val get_congs : Proof.context -> thm list
   17.31 +end
   17.32 +
   17.33 +
   17.34 +structure Fundef : FUNDEF =
   17.35 +struct
   17.36 +
   17.37 +open FundefLib
   17.38 +open FundefCommon
   17.39 +
   17.40 +val simp_attribs = map (Attrib.internal o K)
   17.41 +    [Simplifier.simp_add,
   17.42 +     Code.add_default_eqn_attribute,
   17.43 +     Nitpick_Const_Simp_Thms.add,
   17.44 +     Quickcheck_RecFun_Simp_Thms.add]
   17.45 +
   17.46 +val psimp_attribs = map (Attrib.internal o K)
   17.47 +    [Simplifier.simp_add,
   17.48 +     Nitpick_Const_Psimp_Thms.add]
   17.49 +
   17.50 +fun note_theorem ((name, atts), ths) =
   17.51 +  LocalTheory.note Thm.generatedK ((Binding.qualified_name name, atts), ths)
   17.52 +
   17.53 +fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
   17.54 +
   17.55 +fun add_simps fnames post sort extra_qualify label moreatts simps lthy =
   17.56 +    let
   17.57 +      val spec = post simps
   17.58 +                   |> map (apfst (apsnd (fn ats => moreatts @ ats)))
   17.59 +                   |> map (apfst (apfst extra_qualify))
   17.60 +
   17.61 +      val (saved_spec_simps, lthy) =
   17.62 +        fold_map (LocalTheory.note Thm.generatedK) spec lthy
   17.63 +
   17.64 +      val saved_simps = flat (map snd saved_spec_simps)
   17.65 +      val simps_by_f = sort saved_simps
   17.66 +
   17.67 +      fun add_for_f fname simps =
   17.68 +        note_theorem ((Long_Name.qualify fname label, []), simps) #> snd
   17.69 +    in
   17.70 +      (saved_simps,
   17.71 +       fold2 add_for_f fnames simps_by_f lthy)
   17.72 +    end
   17.73 +
   17.74 +fun gen_add_fundef is_external prep default_constraint fixspec eqns config lthy =
   17.75 +    let
   17.76 +      val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
   17.77 +      val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
   17.78 +      val fixes = map (apfst (apfst Binding.name_of)) fixes0;
   17.79 +      val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
   17.80 +      val (eqs, post, sort_cont, cnames) = FundefCommon.get_preproc lthy config ctxt' fixes spec
   17.81 +
   17.82 +      val defname = mk_defname fixes
   17.83 +
   17.84 +      val ((goalstate, cont), lthy) =
   17.85 +          FundefMutual.prepare_fundef_mutual config defname fixes eqs lthy
   17.86 +
   17.87 +      fun afterqed [[proof]] lthy =
   17.88 +        let
   17.89 +          val FundefResult {fs, R, psimps, trsimps,  simple_pinducts, termination,
   17.90 +                            domintros, cases, ...} =
   17.91 +          cont (Thm.close_derivation proof)
   17.92 +
   17.93 +          val fnames = map (fst o fst) fixes
   17.94 +          val qualify = Long_Name.qualify defname
   17.95 +          val addsmps = add_simps fnames post sort_cont
   17.96 +
   17.97 +          val (((psimps', pinducts'), (_, [termination'])), lthy) =
   17.98 +            lthy
   17.99 +            |> addsmps (Binding.qualify false "partial") "psimps"
  17.100 +                 psimp_attribs psimps
  17.101 +            ||> fold_option (snd oo addsmps I "simps" simp_attribs) trsimps
  17.102 +            ||>> note_theorem ((qualify "pinduct",
  17.103 +                   [Attrib.internal (K (RuleCases.case_names cnames)),
  17.104 +                    Attrib.internal (K (RuleCases.consumes 1)),
  17.105 +                    Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
  17.106 +            ||>> note_theorem ((qualify "termination", []), [termination])
  17.107 +            ||> (snd o note_theorem ((qualify "cases",
  17.108 +                   [Attrib.internal (K (RuleCases.case_names cnames))]), [cases]))
  17.109 +            ||> fold_option (snd oo curry note_theorem (qualify "domintros", [])) domintros
  17.110 +
  17.111 +          val cdata = FundefCtxData { add_simps=addsmps, case_names=cnames, psimps=psimps',
  17.112 +                                      pinducts=snd pinducts', termination=termination',
  17.113 +                                      fs=fs, R=R, defname=defname }
  17.114 +          val _ =
  17.115 +            if not is_external then ()
  17.116 +            else Specification.print_consts lthy (K false) (map fst fixes)
  17.117 +        in
  17.118 +          lthy
  17.119 +          |> LocalTheory.declaration (add_fundef_data o morph_fundef_data cdata)
  17.120 +        end
  17.121 +    in
  17.122 +      lthy
  17.123 +        |> is_external ? LocalTheory.set_group (serial_string ())
  17.124 +        |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
  17.125 +        |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
  17.126 +    end
  17.127 +
  17.128 +val add_fundef = gen_add_fundef false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
  17.129 +val add_fundef_cmd = gen_add_fundef true Specification.read_spec "_::type"
  17.130 +
  17.131 +fun gen_termination_proof prep_term raw_term_opt lthy =
  17.132 +    let
  17.133 +      val term_opt = Option.map (prep_term lthy) raw_term_opt
  17.134 +      val data = the (case term_opt of
  17.135 +                        SOME t => (import_fundef_data t lthy
  17.136 +                          handle Option.Option =>
  17.137 +                            error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
  17.138 +                      | NONE => (import_last_fundef lthy handle Option.Option => error "Not a function"))
  17.139 +
  17.140 +        val FundefCtxData { termination, R, add_simps, case_names, psimps,
  17.141 +                            pinducts, defname, ...} = data
  17.142 +        val domT = domain_type (fastype_of R)
  17.143 +        val goal = HOLogic.mk_Trueprop
  17.144 +                     (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
  17.145 +        fun afterqed [[totality]] lthy =
  17.146 +          let
  17.147 +            val totality = Thm.close_derivation totality
  17.148 +            val remove_domain_condition =
  17.149 +              full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
  17.150 +            val tsimps = map remove_domain_condition psimps
  17.151 +            val tinduct = map remove_domain_condition pinducts
  17.152 +            val qualify = Long_Name.qualify defname;
  17.153 +          in
  17.154 +            lthy
  17.155 +            |> add_simps I "simps" simp_attribs tsimps |> snd
  17.156 +            |> note_theorem
  17.157 +               ((qualify "induct",
  17.158 +                 [Attrib.internal (K (RuleCases.case_names case_names))]),
  17.159 +                tinduct) |> snd
  17.160 +          end
  17.161 +    in
  17.162 +      lthy
  17.163 +      |> ProofContext.note_thmss ""
  17.164 +         [((Binding.empty, [ContextRules.rule_del]), [([allI], [])])] |> snd
  17.165 +      |> ProofContext.note_thmss ""
  17.166 +         [((Binding.empty, [ContextRules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
  17.167 +      |> ProofContext.note_thmss ""
  17.168 +         [((Binding.name "termination", [ContextRules.intro_bang (SOME 0)]),
  17.169 +           [([Goal.norm_result termination], [])])] |> snd
  17.170 +      |> Proof.theorem_i NONE afterqed [[(goal, [])]]
  17.171 +    end
  17.172 +
  17.173 +val termination_proof = gen_termination_proof Syntax.check_term;
  17.174 +val termination_proof_cmd = gen_termination_proof Syntax.read_term;
  17.175 +
  17.176 +fun termination term_opt lthy =
  17.177 +  lthy
  17.178 +  |> LocalTheory.set_group (serial_string ())
  17.179 +  |> termination_proof term_opt;
  17.180 +
  17.181 +fun termination_cmd term_opt lthy =
  17.182 +  lthy
  17.183 +  |> LocalTheory.set_group (serial_string ())
  17.184 +  |> termination_proof_cmd term_opt;
  17.185 +
  17.186 +
  17.187 +(* Datatype hook to declare datatype congs as "fundef_congs" *)
  17.188 +
  17.189 +
  17.190 +fun add_case_cong n thy =
  17.191 +    Context.theory_map (FundefCtxTree.map_fundef_congs (Thm.add_thm
  17.192 +                          (Datatype.get_datatype thy n |> the
  17.193 +                           |> #case_cong
  17.194 +                           |> safe_mk_meta_eq)))
  17.195 +                       thy
  17.196 +
  17.197 +val setup_case_cong = Datatype.interpretation (K (fold add_case_cong))
  17.198 +
  17.199 +
  17.200 +(* setup *)
  17.201 +
  17.202 +val setup =
  17.203 +  Attrib.setup @{binding fundef_cong}
  17.204 +    (Attrib.add_del FundefCtxTree.cong_add FundefCtxTree.cong_del)
  17.205 +    "declaration of congruence rule for function definitions"
  17.206 +  #> setup_case_cong
  17.207 +  #> FundefRelation.setup
  17.208 +  #> FundefCommon.TerminationSimps.setup
  17.209 +
  17.210 +val get_congs = FundefCtxTree.get_fundef_congs
  17.211 +
  17.212 +
  17.213 +(* outer syntax *)
  17.214 +
  17.215 +local structure P = OuterParse and K = OuterKeyword in
  17.216 +
  17.217 +val _ =
  17.218 +  OuterSyntax.local_theory_to_proof "function" "define general recursive functions" K.thy_goal
  17.219 +  (fundef_parser default_config
  17.220 +     >> (fn ((config, fixes), statements) => add_fundef_cmd fixes statements config));
  17.221 +
  17.222 +val _ =
  17.223 +  OuterSyntax.local_theory_to_proof "termination" "prove termination of a recursive function" K.thy_goal
  17.224 +  (Scan.option P.term >> termination_cmd);
  17.225 +
  17.226 +end;
  17.227 +
  17.228 +
  17.229 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Tools/Function/fundef_common.ML	Tue Jun 23 12:09:30 2009 +0200
    18.3 @@ -0,0 +1,343 @@
    18.4 +(*  Title:      HOL/Tools/Function/fundef_common.ML
    18.5 +    Author:     Alexander Krauss, TU Muenchen
    18.6 +
    18.7 +A package for general recursive function definitions. 
    18.8 +Common definitions and other infrastructure.
    18.9 +*)
   18.10 +
   18.11 +structure FundefCommon =
   18.12 +struct
   18.13 +
   18.14 +local open FundefLib in
   18.15 +
   18.16 +(* Profiling *)
   18.17 +val profile = ref false;
   18.18 +
   18.19 +fun PROFILE msg = if !profile then timeap_msg msg else I
   18.20 +
   18.21 +
   18.22 +val acc_const_name = @{const_name "accp"}
   18.23 +fun mk_acc domT R =
   18.24 +    Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R 
   18.25 +
   18.26 +val function_name = suffix "C"
   18.27 +val graph_name = suffix "_graph"
   18.28 +val rel_name = suffix "_rel"
   18.29 +val dom_name = suffix "_dom"
   18.30 +
   18.31 +(* Termination rules *)
   18.32 +
   18.33 +structure TerminationRule = GenericDataFun
   18.34 +(
   18.35 +  type T = thm list
   18.36 +  val empty = []
   18.37 +  val extend = I
   18.38 +  fun merge _ = Thm.merge_thms
   18.39 +);
   18.40 +
   18.41 +val get_termination_rules = TerminationRule.get
   18.42 +val store_termination_rule = TerminationRule.map o cons
   18.43 +val apply_termination_rule = resolve_tac o get_termination_rules o Context.Proof
   18.44 +
   18.45 +
   18.46 +(* Function definition result data *)
   18.47 +
   18.48 +datatype fundef_result =
   18.49 +  FundefResult of
   18.50 +     {
   18.51 +      fs: term list,
   18.52 +      G: term,
   18.53 +      R: term,
   18.54 +
   18.55 +      psimps : thm list, 
   18.56 +      trsimps : thm list option, 
   18.57 +
   18.58 +      simple_pinducts : thm list, 
   18.59 +      cases : thm,
   18.60 +      termination : thm,
   18.61 +      domintros : thm list option
   18.62 +     }
   18.63 +
   18.64 +
   18.65 +datatype fundef_context_data =
   18.66 +  FundefCtxData of
   18.67 +     {
   18.68 +      defname : string,
   18.69 +
   18.70 +      (* contains no logical entities: invariant under morphisms *)
   18.71 +      add_simps : (binding -> binding) -> string -> Attrib.src list -> thm list 
   18.72 +                  -> local_theory -> thm list * local_theory,
   18.73 +      case_names : string list,
   18.74 +
   18.75 +      fs : term list,
   18.76 +      R : term,
   18.77 +      
   18.78 +      psimps: thm list,
   18.79 +      pinducts: thm list,
   18.80 +      termination: thm
   18.81 +     }
   18.82 +
   18.83 +fun morph_fundef_data (FundefCtxData {add_simps, case_names, fs, R, 
   18.84 +                                      psimps, pinducts, termination, defname}) phi =
   18.85 +    let
   18.86 +      val term = Morphism.term phi val thm = Morphism.thm phi val fact = Morphism.fact phi
   18.87 +      val name = Binding.name_of o Morphism.binding phi o Binding.name
   18.88 +    in
   18.89 +      FundefCtxData { add_simps = add_simps, case_names = case_names,
   18.90 +                      fs = map term fs, R = term R, psimps = fact psimps, 
   18.91 +                      pinducts = fact pinducts, termination = thm termination,
   18.92 +                      defname = name defname }
   18.93 +    end
   18.94 +
   18.95 +structure FundefData = GenericDataFun
   18.96 +(
   18.97 +  type T = (term * fundef_context_data) Item_Net.T;
   18.98 +  val empty = Item_Net.init
   18.99 +    (op aconv o pairself fst : (term * fundef_context_data) * (term * fundef_context_data) -> bool)
  18.100 +    fst;
  18.101 +  val copy = I;
  18.102 +  val extend = I;
  18.103 +  fun merge _ (tab1, tab2) = Item_Net.merge (tab1, tab2)
  18.104 +);
  18.105 +
  18.106 +val get_fundef = FundefData.get o Context.Proof;
  18.107 +
  18.108 +
  18.109 +(* Generally useful?? *)
  18.110 +fun lift_morphism thy f = 
  18.111 +    let 
  18.112 +      val term = Drule.term_rule thy f
  18.113 +    in
  18.114 +      Morphism.thm_morphism f $> Morphism.term_morphism term 
  18.115 +       $> Morphism.typ_morphism (Logic.type_map term)
  18.116 +    end
  18.117 +
  18.118 +fun import_fundef_data t ctxt =
  18.119 +    let
  18.120 +      val thy = ProofContext.theory_of ctxt
  18.121 +      val ct = cterm_of thy t
  18.122 +      val inst_morph = lift_morphism thy o Thm.instantiate 
  18.123 +
  18.124 +      fun match (trm, data) = 
  18.125 +          SOME (morph_fundef_data data (inst_morph (Thm.match (cterm_of thy trm, ct))))
  18.126 +          handle Pattern.MATCH => NONE
  18.127 +    in 
  18.128 +      get_first match (Item_Net.retrieve (get_fundef ctxt) t)
  18.129 +    end
  18.130 +
  18.131 +fun import_last_fundef ctxt =
  18.132 +    case Item_Net.content (get_fundef ctxt) of
  18.133 +      [] => NONE
  18.134 +    | (t, data) :: _ =>
  18.135 +      let 
  18.136 +        val ([t'], ctxt') = Variable.import_terms true [t] ctxt
  18.137 +      in
  18.138 +        import_fundef_data t' ctxt'
  18.139 +      end
  18.140 +
  18.141 +val all_fundef_data = Item_Net.content o get_fundef
  18.142 +
  18.143 +fun add_fundef_data (data as FundefCtxData {fs, termination, ...}) =
  18.144 +    FundefData.map (fold (fn f => Item_Net.insert (f, data)) fs)
  18.145 +    #> store_termination_rule termination
  18.146 +
  18.147 +
  18.148 +(* Simp rules for termination proofs *)
  18.149 +
  18.150 +structure TerminationSimps = NamedThmsFun
  18.151 +(
  18.152 +  val name = "termination_simp" 
  18.153 +  val description = "Simplification rule for termination proofs"
  18.154 +);
  18.155 +
  18.156 +
  18.157 +(* Default Termination Prover *)
  18.158 +
  18.159 +structure TerminationProver = GenericDataFun
  18.160 +(
  18.161 +  type T = Proof.context -> Proof.method
  18.162 +  val empty = (fn _ => error "Termination prover not configured")
  18.163 +  val extend = I
  18.164 +  fun merge _ (a,b) = b (* FIXME *)
  18.165 +);
  18.166 +
  18.167 +val set_termination_prover = TerminationProver.put
  18.168 +val get_termination_prover = TerminationProver.get o Context.Proof
  18.169 +
  18.170 +
  18.171 +(* Configuration management *)
  18.172 +datatype fundef_opt 
  18.173 +  = Sequential
  18.174 +  | Default of string
  18.175 +  | DomIntros
  18.176 +  | Tailrec
  18.177 +
  18.178 +datatype fundef_config
  18.179 +  = FundefConfig of
  18.180 +   {
  18.181 +    sequential: bool,
  18.182 +    default: string,
  18.183 +    domintros: bool,
  18.184 +    tailrec: bool
  18.185 +   }
  18.186 +
  18.187 +fun apply_opt Sequential (FundefConfig {sequential, default, domintros,tailrec}) = 
  18.188 +    FundefConfig {sequential=true, default=default, domintros=domintros, tailrec=tailrec}
  18.189 +  | apply_opt (Default d) (FundefConfig {sequential, default, domintros,tailrec}) = 
  18.190 +    FundefConfig {sequential=sequential, default=d, domintros=domintros, tailrec=tailrec}
  18.191 +  | apply_opt DomIntros (FundefConfig {sequential, default, domintros,tailrec}) =
  18.192 +    FundefConfig {sequential=sequential, default=default, domintros=true,tailrec=tailrec}
  18.193 +  | apply_opt Tailrec (FundefConfig {sequential, default, domintros,tailrec}) =
  18.194 +    FundefConfig {sequential=sequential, default=default, domintros=domintros,tailrec=true}
  18.195 +
  18.196 +val default_config =
  18.197 +  FundefConfig { sequential=false, default="%x. undefined" (*FIXME dynamic scoping*), 
  18.198 +                 domintros=false, tailrec=false }
  18.199 +
  18.200 +
  18.201 +(* Analyzing function equations *)
  18.202 +
  18.203 +fun split_def ctxt geq =
  18.204 +    let
  18.205 +      fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq]
  18.206 +      val qs = Term.strip_qnt_vars "all" geq
  18.207 +      val imp = Term.strip_qnt_body "all" geq
  18.208 +      val (gs, eq) = Logic.strip_horn imp
  18.209 +
  18.210 +      val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
  18.211 +          handle TERM _ => error (input_error "Not an equation")
  18.212 +
  18.213 +      val (head, args) = strip_comb f_args
  18.214 +
  18.215 +      val fname = fst (dest_Free head)
  18.216 +          handle TERM _ => error (input_error "Head symbol must not be a bound variable")
  18.217 +    in
  18.218 +      (fname, qs, gs, args, rhs)
  18.219 +    end
  18.220 +
  18.221 +(* Check for all sorts of errors in the input *)
  18.222 +fun check_defs ctxt fixes eqs =
  18.223 +    let
  18.224 +      val fnames = map (fst o fst) fixes
  18.225 +                                
  18.226 +      fun check geq = 
  18.227 +          let
  18.228 +            fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq])
  18.229 +                                  
  18.230 +            val fqgar as (fname, qs, gs, args, rhs) = split_def ctxt geq
  18.231 +                                 
  18.232 +            val _ = fname mem fnames 
  18.233 +                    orelse input_error 
  18.234 +                             ("Head symbol of left hand side must be " 
  18.235 +                              ^ plural "" "one out of " fnames ^ commas_quote fnames)
  18.236 +                                            
  18.237 +            val _ = length args > 0 orelse input_error "Function has no arguments:"
  18.238 +
  18.239 +            fun add_bvs t is = add_loose_bnos (t, 0, is)
  18.240 +            val rvs = (add_bvs rhs [] \\ fold add_bvs args [])
  18.241 +                        |> map (fst o nth (rev qs))
  18.242 +                      
  18.243 +            val _ = null rvs orelse input_error 
  18.244 +                        ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs
  18.245 +                         ^ " occur" ^ plural "s" "" rvs ^ " on right hand side only:")
  18.246 +                                    
  18.247 +            val _ = forall (not o Term.exists_subterm 
  18.248 +                             (fn Free (n, _) => n mem fnames | _ => false)) (gs @ args)
  18.249 +                    orelse input_error "Defined function may not occur in premises or arguments"
  18.250 +
  18.251 +            val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args
  18.252 +            val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs
  18.253 +            val _ = null funvars
  18.254 +                    orelse (warning (cat_lines 
  18.255 +                    ["Bound variable" ^ plural " " "s " funvars 
  18.256 +                     ^ commas_quote (map fst funvars) ^  
  18.257 +                     " occur" ^ plural "s" "" funvars ^ " in function position.",  
  18.258 +                     "Misspelled constructor???"]); true)
  18.259 +          in
  18.260 +            (fname, length args)
  18.261 +          end
  18.262 +
  18.263 +      val _ = AList.group (op =) (map check eqs)
  18.264 +        |> map (fn (fname, ars) =>
  18.265 +             length (distinct (op =) ars) = 1
  18.266 +             orelse error ("Function " ^ quote fname ^
  18.267 +                           " has different numbers of arguments in different equations"))
  18.268 +
  18.269 +      fun check_sorts ((fname, fT), _) =
  18.270 +          Sorts.of_sort (Sign.classes_of (ProofContext.theory_of ctxt)) (fT, HOLogic.typeS)
  18.271 +          orelse error (cat_lines 
  18.272 +          ["Type of " ^ quote fname ^ " is not of sort " ^ quote "type" ^ ":",
  18.273 +           setmp show_sorts true (Syntax.string_of_typ ctxt) fT])
  18.274 +
  18.275 +      val _ = map check_sorts fixes
  18.276 +    in
  18.277 +      ()
  18.278 +    end
  18.279 +
  18.280 +(* Preprocessors *)
  18.281 +
  18.282 +type fixes = ((string * typ) * mixfix) list
  18.283 +type 'a spec = (Attrib.binding * 'a list) list
  18.284 +type preproc = fundef_config -> Proof.context -> fixes -> term spec 
  18.285 +               -> (term list * (thm list -> thm spec) * (thm list -> thm list list) * string list)
  18.286 +
  18.287 +val fname_of = fst o dest_Free o fst o strip_comb o fst 
  18.288 + o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all
  18.289 +
  18.290 +fun mk_case_names i "" k = mk_case_names i (string_of_int (i + 1)) k
  18.291 +  | mk_case_names _ n 0 = []
  18.292 +  | mk_case_names _ n 1 = [n]
  18.293 +  | mk_case_names _ n k = map (fn i => n ^ "_" ^ string_of_int i) (1 upto k)
  18.294 +
  18.295 +fun empty_preproc check _ ctxt fixes spec =
  18.296 +    let 
  18.297 +      val (bnds, tss) = split_list spec
  18.298 +      val ts = flat tss
  18.299 +      val _ = check ctxt fixes ts
  18.300 +      val fnames = map (fst o fst) fixes
  18.301 +      val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts
  18.302 +
  18.303 +      fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) 
  18.304 +                                   (indices ~~ xs)
  18.305 +                        |> map (map snd)
  18.306 +
  18.307 +      (* using theorem names for case name currently disabled *)
  18.308 +      val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat
  18.309 +    in
  18.310 +      (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames)
  18.311 +    end
  18.312 +
  18.313 +structure Preprocessor = GenericDataFun
  18.314 +(
  18.315 +  type T = preproc
  18.316 +  val empty : T = empty_preproc check_defs
  18.317 +  val extend = I
  18.318 +  fun merge _ (a, _) = a
  18.319 +);
  18.320 +
  18.321 +val get_preproc = Preprocessor.get o Context.Proof
  18.322 +val set_preproc = Preprocessor.map o K
  18.323 +
  18.324 +
  18.325 +
  18.326 +local 
  18.327 +  structure P = OuterParse and K = OuterKeyword
  18.328 +
  18.329 +  val option_parser = 
  18.330 +      P.group "option" ((P.reserved "sequential" >> K Sequential)
  18.331 +                    || ((P.reserved "default" |-- P.term) >> Default)
  18.332 +                    || (P.reserved "domintros" >> K DomIntros)
  18.333 +                    || (P.reserved "tailrec" >> K Tailrec))
  18.334 +
  18.335 +  fun config_parser default = 
  18.336 +      (Scan.optional (P.$$$ "(" |-- P.!!! (P.list1 option_parser) --| P.$$$ ")") [])
  18.337 +        >> (fn opts => fold apply_opt opts default)
  18.338 +in
  18.339 +  fun fundef_parser default_cfg = 
  18.340 +      config_parser default_cfg -- P.fixes -- SpecParse.where_alt_specs
  18.341 +end
  18.342 +
  18.343 +
  18.344 +end
  18.345 +end
  18.346 +
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Tools/Function/fundef_core.ML	Tue Jun 23 12:09:30 2009 +0200
    19.3 @@ -0,0 +1,954 @@
    19.4 +(*  Title:      HOL/Tools/Function/fundef_core.ML
    19.5 +    Author:     Alexander Krauss, TU Muenchen
    19.6 +
    19.7 +A package for general recursive function definitions:
    19.8 +Main functionality.
    19.9 +*)
   19.10 +
   19.11 +signature FUNDEF_CORE =
   19.12 +sig
   19.13 +    val prepare_fundef : FundefCommon.fundef_config
   19.14 +                         -> string (* defname *)
   19.15 +                         -> ((bstring * typ) * mixfix) list (* defined symbol *)
   19.16 +                         -> ((bstring * typ) list * term list * term * term) list (* specification *)
   19.17 +                         -> local_theory
   19.18 +
   19.19 +                         -> (term   (* f *)
   19.20 +                             * thm  (* goalstate *)
   19.21 +                             * (thm -> FundefCommon.fundef_result) (* continuation *)
   19.22 +                            ) * local_theory
   19.23 +
   19.24 +end
   19.25 +
   19.26 +structure FundefCore : FUNDEF_CORE =
   19.27 +struct
   19.28 +
   19.29 +val boolT = HOLogic.boolT
   19.30 +val mk_eq = HOLogic.mk_eq
   19.31 +
   19.32 +open FundefLib
   19.33 +open FundefCommon
   19.34 +
   19.35 +datatype globals =
   19.36 +   Globals of {
   19.37 +         fvar: term,
   19.38 +         domT: typ,
   19.39 +         ranT: typ,
   19.40 +         h: term,
   19.41 +         y: term,
   19.42 +         x: term,
   19.43 +         z: term,
   19.44 +         a: term,
   19.45 +         P: term,
   19.46 +         D: term,
   19.47 +         Pbool:term
   19.48 +}
   19.49 +
   19.50 +
   19.51 +datatype rec_call_info =
   19.52 +  RCInfo of
   19.53 +  {
   19.54 +   RIvs: (string * typ) list,  (* Call context: fixes and assumes *)
   19.55 +   CCas: thm list,
   19.56 +   rcarg: term,                 (* The recursive argument *)
   19.57 +
   19.58 +   llRI: thm,
   19.59 +   h_assum: term
   19.60 +  }
   19.61 +
   19.62 +
   19.63 +datatype clause_context =
   19.64 +  ClauseContext of
   19.65 +  {
   19.66 +    ctxt : Proof.context,
   19.67 +
   19.68 +    qs : term list,
   19.69 +    gs : term list,
   19.70 +    lhs: term,
   19.71 +    rhs: term,
   19.72 +
   19.73 +    cqs: cterm list,
   19.74 +    ags: thm list,
   19.75 +    case_hyp : thm
   19.76 +  }
   19.77 +
   19.78 +
   19.79 +fun transfer_clause_ctx thy (ClauseContext { ctxt, qs, gs, lhs, rhs, cqs, ags, case_hyp }) =
   19.80 +    ClauseContext { ctxt = ProofContext.transfer thy ctxt,
   19.81 +                    qs = qs, gs = gs, lhs = lhs, rhs = rhs, cqs = cqs, ags = ags, case_hyp = case_hyp }
   19.82 +
   19.83 +
   19.84 +datatype clause_info =
   19.85 +  ClauseInfo of
   19.86 +     {
   19.87 +      no: int,
   19.88 +      qglr : ((string * typ) list * term list * term * term),
   19.89 +      cdata : clause_context,
   19.90 +
   19.91 +      tree: FundefCtxTree.ctx_tree,
   19.92 +      lGI: thm,
   19.93 +      RCs: rec_call_info list
   19.94 +     }
   19.95 +
   19.96 +
   19.97 +(* Theory dependencies. *)
   19.98 +val Pair_inject = @{thm Product_Type.Pair_inject};
   19.99 +
  19.100 +val acc_induct_rule = @{thm accp_induct_rule};
  19.101 +
  19.102 +val ex1_implies_ex = @{thm FunDef.fundef_ex1_existence};
  19.103 +val ex1_implies_un = @{thm FunDef.fundef_ex1_uniqueness};
  19.104 +val ex1_implies_iff = @{thm FunDef.fundef_ex1_iff};
  19.105 +
  19.106 +val acc_downward = @{thm accp_downward};
  19.107 +val accI = @{thm accp.accI};
  19.108 +val case_split = @{thm HOL.case_split};
  19.109 +val fundef_default_value = @{thm FunDef.fundef_default_value};
  19.110 +val not_acc_down = @{thm not_accp_down};
  19.111 +
  19.112 +
  19.113 +
  19.114 +fun find_calls tree =
  19.115 +    let
  19.116 +      fun add_Ri (fixes,assumes) (_ $ arg) _ (_, xs) = ([], (fixes, assumes, arg) :: xs)
  19.117 +        | add_Ri _ _ _ _ = raise Match
  19.118 +    in
  19.119 +      rev (FundefCtxTree.traverse_tree add_Ri tree [])
  19.120 +    end
  19.121 +
  19.122 +
  19.123 +(** building proof obligations *)
  19.124 +
  19.125 +fun mk_compat_proof_obligations domT ranT fvar f glrs =
  19.126 +    let
  19.127 +      fun mk_impl ((qs, gs, lhs, rhs),(qs', gs', lhs', rhs')) =
  19.128 +          let
  19.129 +            val shift = incr_boundvars (length qs')
  19.130 +          in
  19.131 +            Logic.mk_implies
  19.132 +              (HOLogic.mk_Trueprop (HOLogic.eq_const domT $ shift lhs $ lhs'),
  19.133 +                HOLogic.mk_Trueprop (HOLogic.eq_const ranT $ shift rhs $ rhs'))
  19.134 +              |> fold_rev (curry Logic.mk_implies) (map shift gs @ gs')
  19.135 +              |> fold_rev (fn (n,T) => fn b => Term.all T $ Abs(n,T,b)) (qs @ qs')
  19.136 +              |> curry abstract_over fvar
  19.137 +              |> curry subst_bound f
  19.138 +          end
  19.139 +    in
  19.140 +      map mk_impl (unordered_pairs glrs)
  19.141 +    end
  19.142 +
  19.143 +
  19.144 +fun mk_completeness (Globals {x, Pbool, ...}) clauses qglrs =
  19.145 +    let
  19.146 +        fun mk_case (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) =
  19.147 +            HOLogic.mk_Trueprop Pbool
  19.148 +                     |> curry Logic.mk_implies (HOLogic.mk_Trueprop (mk_eq (x, lhs)))
  19.149 +                     |> fold_rev (curry Logic.mk_implies) gs
  19.150 +                     |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  19.151 +    in
  19.152 +        HOLogic.mk_Trueprop Pbool
  19.153 +                 |> fold_rev (curry Logic.mk_implies o mk_case) (clauses ~~ qglrs)
  19.154 +                 |> mk_forall_rename ("x", x)
  19.155 +                 |> mk_forall_rename ("P", Pbool)
  19.156 +    end
  19.157 +
  19.158 +(** making a context with it's own local bindings **)
  19.159 +
  19.160 +fun mk_clause_context x ctxt (pre_qs,pre_gs,pre_lhs,pre_rhs) =
  19.161 +    let
  19.162 +      val (qs, ctxt') = Variable.variant_fixes (map fst pre_qs) ctxt
  19.163 +                                           |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
  19.164 +
  19.165 +      val thy = ProofContext.theory_of ctxt'
  19.166 +
  19.167 +      fun inst t = subst_bounds (rev qs, t)
  19.168 +      val gs = map inst pre_gs
  19.169 +      val lhs = inst pre_lhs
  19.170 +      val rhs = inst pre_rhs
  19.171 +
  19.172 +      val cqs = map (cterm_of thy) qs
  19.173 +      val ags = map (assume o cterm_of thy) gs
  19.174 +
  19.175 +      val case_hyp = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (x, lhs))))
  19.176 +    in
  19.177 +      ClauseContext { ctxt = ctxt', qs = qs, gs = gs, lhs = lhs, rhs = rhs,
  19.178 +                      cqs = cqs, ags = ags, case_hyp = case_hyp }
  19.179 +    end
  19.180 +
  19.181 +
  19.182 +(* lowlevel term function *)
  19.183 +fun abstract_over_list vs body =
  19.184 +  let
  19.185 +    exception SAME;
  19.186 +    fun abs lev v tm =
  19.187 +      if v aconv tm then Bound lev
  19.188 +      else
  19.189 +        (case tm of
  19.190 +          Abs (a, T, t) => Abs (a, T, abs (lev + 1) v t)
  19.191 +        | t $ u => (abs lev v t $ (abs lev v u handle SAME => u) handle SAME => t $ abs lev v u)
  19.192 +        | _ => raise SAME);
  19.193 +  in
  19.194 +    fold_index (fn (i,v) => fn t => abs i v t handle SAME => t) vs body
  19.195 +  end
  19.196 +
  19.197 +
  19.198 +
  19.199 +fun mk_clause_info globals G f no cdata qglr tree RCs GIntro_thm RIntro_thms =
  19.200 +    let
  19.201 +        val Globals {h, fvar, x, ...} = globals
  19.202 +
  19.203 +        val ClauseContext { ctxt, qs, cqs, ags, ... } = cdata
  19.204 +        val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
  19.205 +
  19.206 +        (* Instantiate the GIntro thm with "f" and import into the clause context. *)
  19.207 +        val lGI = GIntro_thm
  19.208 +                    |> forall_elim (cert f)
  19.209 +                    |> fold forall_elim cqs
  19.210 +                    |> fold Thm.elim_implies ags
  19.211 +
  19.212 +        fun mk_call_info (rcfix, rcassm, rcarg) RI =
  19.213 +            let
  19.214 +                val llRI = RI
  19.215 +                             |> fold forall_elim cqs
  19.216 +                             |> fold (forall_elim o cert o Free) rcfix
  19.217 +                             |> fold Thm.elim_implies ags
  19.218 +                             |> fold Thm.elim_implies rcassm
  19.219 +
  19.220 +                val h_assum =
  19.221 +                    HOLogic.mk_Trueprop (G $ rcarg $ (h $ rcarg))
  19.222 +                              |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
  19.223 +                              |> fold_rev (Logic.all o Free) rcfix
  19.224 +                              |> Pattern.rewrite_term (ProofContext.theory_of ctxt) [(f, h)] []
  19.225 +                              |> abstract_over_list (rev qs)
  19.226 +            in
  19.227 +                RCInfo {RIvs=rcfix, rcarg=rcarg, CCas=rcassm, llRI=llRI, h_assum=h_assum}
  19.228 +            end
  19.229 +
  19.230 +        val RC_infos = map2 mk_call_info RCs RIntro_thms
  19.231 +    in
  19.232 +        ClauseInfo
  19.233 +            {
  19.234 +             no=no,
  19.235 +             cdata=cdata,
  19.236 +             qglr=qglr,
  19.237 +
  19.238 +             lGI=lGI,
  19.239 +             RCs=RC_infos,
  19.240 +             tree=tree
  19.241 +            }
  19.242 +    end
  19.243 +
  19.244 +
  19.245 +
  19.246 +
  19.247 +
  19.248 +
  19.249 +
  19.250 +(* replace this by a table later*)
  19.251 +fun store_compat_thms 0 thms = []
  19.252 +  | store_compat_thms n thms =
  19.253 +    let
  19.254 +        val (thms1, thms2) = chop n thms
  19.255 +    in
  19.256 +        (thms1 :: store_compat_thms (n - 1) thms2)
  19.257 +    end
  19.258 +
  19.259 +(* expects i <= j *)
  19.260 +fun lookup_compat_thm i j cts =
  19.261 +    nth (nth cts (i - 1)) (j - i)
  19.262 +
  19.263 +(* Returns "Gsi, Gsj, lhs_i = lhs_j |-- rhs_j_f = rhs_i_f" *)
  19.264 +(* if j < i, then turn around *)
  19.265 +fun get_compat_thm thy cts i j ctxi ctxj =
  19.266 +    let
  19.267 +      val ClauseContext {cqs=cqsi,ags=agsi,lhs=lhsi,...} = ctxi
  19.268 +      val ClauseContext {cqs=cqsj,ags=agsj,lhs=lhsj,...} = ctxj
  19.269 +
  19.270 +      val lhsi_eq_lhsj = cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj)))
  19.271 +    in if j < i then
  19.272 +         let
  19.273 +           val compat = lookup_compat_thm j i cts
  19.274 +         in
  19.275 +           compat         (* "!!qj qi. Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
  19.276 +                |> fold forall_elim (cqsj @ cqsi) (* "Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
  19.277 +                |> fold Thm.elim_implies agsj
  19.278 +                |> fold Thm.elim_implies agsi
  19.279 +                |> Thm.elim_implies ((assume lhsi_eq_lhsj) RS sym) (* "Gsj, Gsi, lhsi = lhsj |-- rhsj = rhsi" *)
  19.280 +         end
  19.281 +       else
  19.282 +         let
  19.283 +           val compat = lookup_compat_thm i j cts
  19.284 +         in
  19.285 +               compat        (* "!!qi qj. Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
  19.286 +                 |> fold forall_elim (cqsi @ cqsj) (* "Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
  19.287 +                 |> fold Thm.elim_implies agsi
  19.288 +                 |> fold Thm.elim_implies agsj
  19.289 +                 |> Thm.elim_implies (assume lhsi_eq_lhsj)
  19.290 +                 |> (fn thm => thm RS sym) (* "Gsi, Gsj, lhsi = lhsj |-- rhsj = rhsi" *)
  19.291 +         end
  19.292 +    end
  19.293 +
  19.294 +
  19.295 +
  19.296 +
  19.297 +(* Generates the replacement lemma in fully quantified form. *)
  19.298 +fun mk_replacement_lemma thy h ih_elim clause =
  19.299 +    let
  19.300 +        val ClauseInfo {cdata=ClauseContext {qs, lhs, rhs, cqs, ags, case_hyp, ...}, RCs, tree, ...} = clause
  19.301 +        local open Conv in
  19.302 +        val ih_conv = arg1_conv o arg_conv o arg_conv
  19.303 +        end
  19.304 +
  19.305 +        val ih_elim_case = Conv.fconv_rule (ih_conv (K (case_hyp RS eq_reflection))) ih_elim
  19.306 +
  19.307 +        val Ris = map (fn RCInfo {llRI, ...} => llRI) RCs
  19.308 +        val h_assums = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qs, h_assum)))) RCs
  19.309 +
  19.310 +        val (eql, _) = FundefCtxTree.rewrite_by_tree thy h ih_elim_case (Ris ~~ h_assums) tree
  19.311 +
  19.312 +        val replace_lemma = (eql RS meta_eq_to_obj_eq)
  19.313 +                                |> implies_intr (cprop_of case_hyp)
  19.314 +                                |> fold_rev (implies_intr o cprop_of) h_assums
  19.315 +                                |> fold_rev (implies_intr o cprop_of) ags
  19.316 +                                |> fold_rev forall_intr cqs
  19.317 +                                |> Thm.close_derivation
  19.318 +    in
  19.319 +      replace_lemma
  19.320 +    end
  19.321 +
  19.322 +
  19.323 +fun mk_uniqueness_clause thy globals f compat_store clausei clausej RLj =
  19.324 +    let
  19.325 +        val Globals {h, y, x, fvar, ...} = globals
  19.326 +        val ClauseInfo {no=i, cdata=cctxi as ClauseContext {ctxt=ctxti, lhs=lhsi, case_hyp, ...}, ...} = clausei
  19.327 +        val ClauseInfo {no=j, qglr=cdescj, RCs=RCsj, ...} = clausej
  19.328 +
  19.329 +        val cctxj as ClauseContext {ags = agsj', lhs = lhsj', rhs = rhsj', qs = qsj', cqs = cqsj', ...}
  19.330 +            = mk_clause_context x ctxti cdescj
  19.331 +
  19.332 +        val rhsj'h = Pattern.rewrite_term thy [(fvar,h)] [] rhsj'
  19.333 +        val compat = get_compat_thm thy compat_store i j cctxi cctxj
  19.334 +        val Ghsj' = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qsj', h_assum)))) RCsj
  19.335 +
  19.336 +        val RLj_import =
  19.337 +            RLj |> fold forall_elim cqsj'
  19.338 +                |> fold Thm.elim_implies agsj'
  19.339 +                |> fold Thm.elim_implies Ghsj'
  19.340 +
  19.341 +        val y_eq_rhsj'h = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (y, rhsj'h))))
  19.342 +        val lhsi_eq_lhsj' = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj')))) (* lhs_i = lhs_j' |-- lhs_i = lhs_j' *)
  19.343 +    in
  19.344 +        (trans OF [case_hyp, lhsi_eq_lhsj']) (* lhs_i = lhs_j' |-- x = lhs_j' *)
  19.345 +        |> implies_elim RLj_import (* Rj1' ... Rjk', lhs_i = lhs_j' |-- rhs_j'_h = rhs_j'_f *)
  19.346 +        |> (fn it => trans OF [it, compat]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk' |-- rhs_j'_h = rhs_i_f *)
  19.347 +        |> (fn it => trans OF [y_eq_rhsj'h, it]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk', y = rhs_j_h' |-- y = rhs_i_f *)
  19.348 +        |> fold_rev (implies_intr o cprop_of) Ghsj'
  19.349 +        |> fold_rev (implies_intr o cprop_of) agsj' (* lhs_i = lhs_j' , y = rhs_j_h' |-- Gj', Rj1'...Rjk' ==> y = rhs_i_f *)
  19.350 +        |> implies_intr (cprop_of y_eq_rhsj'h)
  19.351 +        |> implies_intr (cprop_of lhsi_eq_lhsj')
  19.352 +        |> fold_rev forall_intr (cterm_of thy h :: cqsj')
  19.353 +    end
  19.354 +
  19.355 +
  19.356 +
  19.357 +fun mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_cases compat_store clauses rep_lemmas clausei =
  19.358 +    let
  19.359 +        val Globals {x, y, ranT, fvar, ...} = globals
  19.360 +        val ClauseInfo {cdata = ClauseContext {lhs, rhs, qs, cqs, ags, case_hyp, ...}, lGI, RCs, ...} = clausei
  19.361 +        val rhsC = Pattern.rewrite_term thy [(fvar, f)] [] rhs
  19.362 +
  19.363 +        val ih_intro_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ih_intro
  19.364 +
  19.365 +        fun prep_RC (RCInfo {llRI, RIvs, CCas, ...}) = (llRI RS ih_intro_case)
  19.366 +                                                            |> fold_rev (implies_intr o cprop_of) CCas
  19.367 +                                                            |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
  19.368 +
  19.369 +        val existence = fold (curry op COMP o prep_RC) RCs lGI
  19.370 +
  19.371 +        val P = cterm_of thy (mk_eq (y, rhsC))
  19.372 +        val G_lhs_y = assume (cterm_of thy (HOLogic.mk_Trueprop (G $ lhs $ y)))
  19.373 +
  19.374 +        val unique_clauses = map2 (mk_uniqueness_clause thy globals f compat_store clausei) clauses rep_lemmas
  19.375 +
  19.376 +        val uniqueness = G_cases
  19.377 +                           |> forall_elim (cterm_of thy lhs)
  19.378 +                           |> forall_elim (cterm_of thy y)
  19.379 +                           |> forall_elim P
  19.380 +                           |> Thm.elim_implies G_lhs_y
  19.381 +                           |> fold Thm.elim_implies unique_clauses
  19.382 +                           |> implies_intr (cprop_of G_lhs_y)
  19.383 +                           |> forall_intr (cterm_of thy y)
  19.384 +
  19.385 +        val P2 = cterm_of thy (lambda y (G $ lhs $ y)) (* P2 y := (lhs, y): G *)
  19.386 +
  19.387 +        val exactly_one =
  19.388 +            ex1I |> instantiate' [SOME (ctyp_of thy ranT)] [SOME P2, SOME (cterm_of thy rhsC)]
  19.389 +                 |> curry (op COMP) existence
  19.390 +                 |> curry (op COMP) uniqueness
  19.391 +                 |> simplify (HOL_basic_ss addsimps [case_hyp RS sym])
  19.392 +                 |> implies_intr (cprop_of case_hyp)
  19.393 +                 |> fold_rev (implies_intr o cprop_of) ags
  19.394 +                 |> fold_rev forall_intr cqs
  19.395 +
  19.396 +        val function_value =
  19.397 +            existence
  19.398 +              |> implies_intr ihyp
  19.399 +              |> implies_intr (cprop_of case_hyp)
  19.400 +              |> forall_intr (cterm_of thy x)
  19.401 +              |> forall_elim (cterm_of thy lhs)
  19.402 +              |> curry (op RS) refl
  19.403 +    in
  19.404 +        (exactly_one, function_value)
  19.405 +    end
  19.406 +
  19.407 +
  19.408 +
  19.409 +
  19.410 +fun prove_stuff ctxt globals G f R clauses complete compat compat_store G_elim f_def =
  19.411 +    let
  19.412 +        val Globals {h, domT, ranT, x, ...} = globals
  19.413 +        val thy = ProofContext.theory_of ctxt
  19.414 +
  19.415 +        (* Inductive Hypothesis: !!z. (z,x):R ==> EX!y. (z,y):G *)
  19.416 +        val ihyp = Term.all domT $ Abs ("z", domT,
  19.417 +                                   Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
  19.418 +                                     HOLogic.mk_Trueprop (Const ("Ex1", (ranT --> boolT) --> boolT) $
  19.419 +                                                             Abs ("y", ranT, G $ Bound 1 $ Bound 0))))
  19.420 +                       |> cterm_of thy
  19.421 +
  19.422 +        val ihyp_thm = assume ihyp |> Thm.forall_elim_vars 0
  19.423 +        val ih_intro = ihyp_thm RS (f_def RS ex1_implies_ex)
  19.424 +        val ih_elim = ihyp_thm RS (f_def RS ex1_implies_un)
  19.425 +                        |> instantiate' [] [NONE, SOME (cterm_of thy h)]
  19.426 +
  19.427 +        val _ = Output.debug (K "Proving Replacement lemmas...")
  19.428 +        val repLemmas = map (mk_replacement_lemma thy h ih_elim) clauses
  19.429 +
  19.430 +        val _ = Output.debug (K "Proving cases for unique existence...")
  19.431 +        val (ex1s, values) =
  19.432 +            split_list (map (mk_uniqueness_case ctxt thy globals G f ihyp ih_intro G_elim compat_store clauses repLemmas) clauses)
  19.433 +
  19.434 +        val _ = Output.debug (K "Proving: Graph is a function")
  19.435 +        val graph_is_function = complete
  19.436 +                                  |> Thm.forall_elim_vars 0
  19.437 +                                  |> fold (curry op COMP) ex1s
  19.438 +                                  |> implies_intr (ihyp)
  19.439 +                                  |> implies_intr (cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ x)))
  19.440 +                                  |> forall_intr (cterm_of thy x)
  19.441 +                                  |> (fn it => Drule.compose_single (it, 2, acc_induct_rule)) (* "EX! y. (?x,y):G" *)
  19.442 +                                  |> (fn it => fold (forall_intr o cterm_of thy o Var) (Term.add_vars (prop_of it) []) it)
  19.443 +
  19.444 +        val goalstate =  Conjunction.intr graph_is_function complete
  19.445 +                          |> Thm.close_derivation
  19.446 +                          |> Goal.protect
  19.447 +                          |> fold_rev (implies_intr o cprop_of) compat
  19.448 +                          |> implies_intr (cprop_of complete)
  19.449 +    in
  19.450 +      (goalstate, values)
  19.451 +    end
  19.452 +
  19.453 +
  19.454 +fun define_graph Gname fvar domT ranT clauses RCss lthy =
  19.455 +    let
  19.456 +      val GT = domT --> ranT --> boolT
  19.457 +      val Gvar = Free (the_single (Variable.variant_frees lthy [] [(Gname, GT)]))
  19.458 +
  19.459 +      fun mk_GIntro (ClauseContext {qs, gs, lhs, rhs, ...}) RCs =
  19.460 +          let
  19.461 +            fun mk_h_assm (rcfix, rcassm, rcarg) =
  19.462 +                HOLogic.mk_Trueprop (Gvar $ rcarg $ (fvar $ rcarg))
  19.463 +                          |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
  19.464 +                          |> fold_rev (Logic.all o Free) rcfix
  19.465 +          in
  19.466 +            HOLogic.mk_Trueprop (Gvar $ lhs $ rhs)
  19.467 +                      |> fold_rev (curry Logic.mk_implies o mk_h_assm) RCs
  19.468 +                      |> fold_rev (curry Logic.mk_implies) gs
  19.469 +                      |> fold_rev Logic.all (fvar :: qs)
  19.470 +          end
  19.471 +
  19.472 +      val G_intros = map2 mk_GIntro clauses RCss
  19.473 +
  19.474 +      val (GIntro_thms, (G, G_elim, G_induct, lthy)) =
  19.475 +          FundefInductiveWrap.inductive_def G_intros ((dest_Free Gvar, NoSyn), lthy)
  19.476 +    in
  19.477 +      ((G, GIntro_thms, G_elim, G_induct), lthy)
  19.478 +    end
  19.479 +
  19.480 +
  19.481 +
  19.482 +fun define_function fdefname (fname, mixfix) domT ranT G default lthy =
  19.483 +    let
  19.484 +      val f_def =
  19.485 +          Abs ("x", domT, Const ("FunDef.THE_default", ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $
  19.486 +                                Abs ("y", ranT, G $ Bound 1 $ Bound 0))
  19.487 +              |> Syntax.check_term lthy
  19.488 +
  19.489 +      val ((f, (_, f_defthm)), lthy) =
  19.490 +        LocalTheory.define Thm.internalK ((Binding.name (function_name fname), mixfix), ((Binding.name fdefname, []), f_def)) lthy
  19.491 +    in
  19.492 +      ((f, f_defthm), lthy)
  19.493 +    end
  19.494 +
  19.495 +
  19.496 +fun define_recursion_relation Rname domT ranT fvar f qglrs clauses RCss lthy =
  19.497 +    let
  19.498 +
  19.499 +      val RT = domT --> domT --> boolT
  19.500 +      val Rvar = Free (the_single (Variable.variant_frees lthy [] [(Rname, RT)]))
  19.501 +
  19.502 +      fun mk_RIntro (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) (rcfix, rcassm, rcarg) =
  19.503 +          HOLogic.mk_Trueprop (Rvar $ rcarg $ lhs)
  19.504 +                    |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
  19.505 +                    |> fold_rev (curry Logic.mk_implies) gs
  19.506 +                    |> fold_rev (Logic.all o Free) rcfix
  19.507 +                    |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  19.508 +                    (* "!!qs xs. CS ==> G => (r, lhs) : R" *)
  19.509 +
  19.510 +      val R_intross = map2 (map o mk_RIntro) (clauses ~~ qglrs) RCss
  19.511 +
  19.512 +      val (RIntro_thmss, (R, R_elim, _, lthy)) =
  19.513 +          fold_burrow FundefInductiveWrap.inductive_def R_intross ((dest_Free Rvar, NoSyn), lthy)
  19.514 +    in
  19.515 +      ((R, RIntro_thmss, R_elim), lthy)
  19.516 +    end
  19.517 +
  19.518 +
  19.519 +fun fix_globals domT ranT fvar ctxt =
  19.520 +    let
  19.521 +      val ([h, y, x, z, a, D, P, Pbool],ctxt') =
  19.522 +          Variable.variant_fixes ["h_fd", "y_fd", "x_fd", "z_fd", "a_fd", "D_fd", "P_fd", "Pb_fd"] ctxt
  19.523 +    in
  19.524 +      (Globals {h = Free (h, domT --> ranT),
  19.525 +                y = Free (y, ranT),
  19.526 +                x = Free (x, domT),
  19.527 +                z = Free (z, domT),
  19.528 +                a = Free (a, domT),
  19.529 +                D = Free (D, domT --> boolT),
  19.530 +                P = Free (P, domT --> boolT),
  19.531 +                Pbool = Free (Pbool, boolT),
  19.532 +                fvar = fvar,
  19.533 +                domT = domT,
  19.534 +                ranT = ranT
  19.535 +               },
  19.536 +       ctxt')
  19.537 +    end
  19.538 +
  19.539 +
  19.540 +
  19.541 +fun inst_RC thy fvar f (rcfix, rcassm, rcarg) =
  19.542 +    let
  19.543 +      fun inst_term t = subst_bound(f, abstract_over (fvar, t))
  19.544 +    in
  19.545 +      (rcfix, map (assume o cterm_of thy o inst_term o prop_of) rcassm, inst_term rcarg)
  19.546 +    end
  19.547 +
  19.548 +
  19.549 +
  19.550 +(**********************************************************
  19.551 + *                   PROVING THE RULES
  19.552 + **********************************************************)
  19.553 +
  19.554 +fun mk_psimps thy globals R clauses valthms f_iff graph_is_function =
  19.555 +    let
  19.556 +      val Globals {domT, z, ...} = globals
  19.557 +
  19.558 +      fun mk_psimp (ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {cqs, lhs, ags, ...}, ...}) valthm =
  19.559 +          let
  19.560 +            val lhs_acc = cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ lhs)) (* "acc R lhs" *)
  19.561 +            val z_smaller = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ lhs)) (* "R z lhs" *)
  19.562 +          in
  19.563 +            ((assume z_smaller) RS ((assume lhs_acc) RS acc_downward))
  19.564 +              |> (fn it => it COMP graph_is_function)
  19.565 +              |> implies_intr z_smaller
  19.566 +              |> forall_intr (cterm_of thy z)
  19.567 +              |> (fn it => it COMP valthm)
  19.568 +              |> implies_intr lhs_acc
  19.569 +              |> asm_simplify (HOL_basic_ss addsimps [f_iff])
  19.570 +              |> fold_rev (implies_intr o cprop_of) ags
  19.571 +              |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  19.572 +          end
  19.573 +    in
  19.574 +      map2 mk_psimp clauses valthms
  19.575 +    end
  19.576 +
  19.577 +
  19.578 +(** Induction rule **)
  19.579 +
  19.580 +
  19.581 +val acc_subset_induct = @{thm Orderings.predicate1I} RS @{thm accp_subset_induct}
  19.582 +
  19.583 +
  19.584 +fun binder_conv cv ctxt = Conv.arg_conv (Conv.abs_conv (K cv) ctxt);
  19.585 +
  19.586 +fun mk_partial_induct_rule thy globals R complete_thm clauses =
  19.587 +    let
  19.588 +      val Globals {domT, x, z, a, P, D, ...} = globals
  19.589 +      val acc_R = mk_acc domT R
  19.590 +
  19.591 +      val x_D = assume (cterm_of thy (HOLogic.mk_Trueprop (D $ x)))
  19.592 +      val a_D = cterm_of thy (HOLogic.mk_Trueprop (D $ a))
  19.593 +
  19.594 +      val D_subset = cterm_of thy (Logic.all x
  19.595 +        (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x), HOLogic.mk_Trueprop (acc_R $ x))))
  19.596 +
  19.597 +      val D_dcl = (* "!!x z. [| x: D; (z,x):R |] ==> z:D" *)
  19.598 +                    Logic.all x
  19.599 +                    (Logic.all z (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x),
  19.600 +                                                    Logic.mk_implies (HOLogic.mk_Trueprop (R $ z $ x),
  19.601 +                                                                      HOLogic.mk_Trueprop (D $ z)))))
  19.602 +                    |> cterm_of thy
  19.603 +
  19.604 +
  19.605 +  (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
  19.606 +      val ihyp = Term.all domT $ Abs ("z", domT,
  19.607 +               Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
  19.608 +                 HOLogic.mk_Trueprop (P $ Bound 0)))
  19.609 +           |> cterm_of thy
  19.610 +
  19.611 +      val aihyp = assume ihyp
  19.612 +
  19.613 +  fun prove_case clause =
  19.614 +      let
  19.615 +    val ClauseInfo {cdata = ClauseContext {ctxt, qs, cqs, ags, gs, lhs, case_hyp, ...}, RCs,
  19.616 +                    qglr = (oqs, _, _, _), ...} = clause
  19.617 +
  19.618 +    val case_hyp_conv = K (case_hyp RS eq_reflection)
  19.619 +    local open Conv in
  19.620 +    val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
  19.621 +    val sih = fconv_rule (binder_conv (arg1_conv (arg_conv (arg_conv case_hyp_conv))) ctxt) aihyp
  19.622 +    end
  19.623 +
  19.624 +    fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) =
  19.625 +        sih |> forall_elim (cterm_of thy rcarg)
  19.626 +            |> Thm.elim_implies llRI
  19.627 +            |> fold_rev (implies_intr o cprop_of) CCas
  19.628 +            |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
  19.629 +
  19.630 +    val P_recs = map mk_Prec RCs   (*  [P rec1, P rec2, ... ]  *)
  19.631 +
  19.632 +    val step = HOLogic.mk_Trueprop (P $ lhs)
  19.633 +            |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
  19.634 +            |> fold_rev (curry Logic.mk_implies) gs
  19.635 +            |> curry Logic.mk_implies (HOLogic.mk_Trueprop (D $ lhs))
  19.636 +            |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  19.637 +            |> cterm_of thy
  19.638 +
  19.639 +    val P_lhs = assume step
  19.640 +           |> fold forall_elim cqs
  19.641 +           |> Thm.elim_implies lhs_D
  19.642 +           |> fold Thm.elim_implies ags
  19.643 +           |> fold Thm.elim_implies P_recs
  19.644 +
  19.645 +    val res = cterm_of thy (HOLogic.mk_Trueprop (P $ x))
  19.646 +           |> Conv.arg_conv (Conv.arg_conv case_hyp_conv)
  19.647 +           |> symmetric (* P lhs == P x *)
  19.648 +           |> (fn eql => equal_elim eql P_lhs) (* "P x" *)
  19.649 +           |> implies_intr (cprop_of case_hyp)
  19.650 +           |> fold_rev (implies_intr o cprop_of) ags
  19.651 +           |> fold_rev forall_intr cqs
  19.652 +      in
  19.653 +        (res, step)
  19.654 +      end
  19.655 +
  19.656 +  val (cases, steps) = split_list (map prove_case clauses)
  19.657 +
  19.658 +  val istep = complete_thm
  19.659 +                |> Thm.forall_elim_vars 0
  19.660 +                |> fold (curry op COMP) cases (*  P x  *)
  19.661 +                |> implies_intr ihyp
  19.662 +                |> implies_intr (cprop_of x_D)
  19.663 +                |> forall_intr (cterm_of thy x)
  19.664 +
  19.665 +  val subset_induct_rule =
  19.666 +      acc_subset_induct
  19.667 +        |> (curry op COMP) (assume D_subset)
  19.668 +        |> (curry op COMP) (assume D_dcl)
  19.669 +        |> (curry op COMP) (assume a_D)
  19.670 +        |> (curry op COMP) istep
  19.671 +        |> fold_rev implies_intr steps
  19.672 +        |> implies_intr a_D
  19.673 +        |> implies_intr D_dcl
  19.674 +        |> implies_intr D_subset
  19.675 +
  19.676 +  val subset_induct_all = fold_rev (forall_intr o cterm_of thy) [P, a, D] subset_induct_rule
  19.677 +
  19.678 +  val simple_induct_rule =
  19.679 +      subset_induct_rule
  19.680 +        |> forall_intr (cterm_of thy D)
  19.681 +        |> forall_elim (cterm_of thy acc_R)
  19.682 +        |> assume_tac 1 |> Seq.hd
  19.683 +        |> (curry op COMP) (acc_downward
  19.684 +                              |> (instantiate' [SOME (ctyp_of thy domT)]
  19.685 +                                               (map (SOME o cterm_of thy) [R, x, z]))
  19.686 +                              |> forall_intr (cterm_of thy z)
  19.687 +                              |> forall_intr (cterm_of thy x))
  19.688 +        |> forall_intr (cterm_of thy a)
  19.689 +        |> forall_intr (cterm_of thy P)
  19.690 +    in
  19.691 +      simple_induct_rule
  19.692 +    end
  19.693 +
  19.694 +
  19.695 +
  19.696 +(* FIXME: This should probably use fixed goals, to be more reliable and faster *)
  19.697 +fun mk_domain_intro ctxt (Globals {domT, ...}) R R_cases clause =
  19.698 +    let
  19.699 +      val thy = ProofContext.theory_of ctxt
  19.700 +      val ClauseInfo {cdata = ClauseContext {qs, gs, lhs, rhs, cqs, ...},
  19.701 +                      qglr = (oqs, _, _, _), ...} = clause
  19.702 +      val goal = HOLogic.mk_Trueprop (mk_acc domT R $ lhs)
  19.703 +                          |> fold_rev (curry Logic.mk_implies) gs
  19.704 +                          |> cterm_of thy
  19.705 +    in
  19.706 +      Goal.init goal
  19.707 +      |> (SINGLE (resolve_tac [accI] 1)) |> the
  19.708 +      |> (SINGLE (eresolve_tac [Thm.forall_elim_vars 0 R_cases] 1))  |> the
  19.709 +      |> (SINGLE (auto_tac (local_clasimpset_of ctxt))) |> the
  19.710 +      |> Goal.conclude
  19.711 +      |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  19.712 +    end
  19.713 +
  19.714 +
  19.715 +
  19.716 +(** Termination rule **)
  19.717 +
  19.718 +val wf_induct_rule = @{thm Wellfounded.wfP_induct_rule};
  19.719 +val wf_in_rel = @{thm FunDef.wf_in_rel};
  19.720 +val in_rel_def = @{thm FunDef.in_rel_def};
  19.721 +
  19.722 +fun mk_nest_term_case thy globals R' ihyp clause =
  19.723 +    let
  19.724 +      val Globals {x, z, ...} = globals
  19.725 +      val ClauseInfo {cdata = ClauseContext {qs,cqs,ags,lhs,rhs,case_hyp,...},tree,
  19.726 +                      qglr=(oqs, _, _, _), ...} = clause
  19.727 +
  19.728 +      val ih_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ihyp
  19.729 +
  19.730 +      fun step (fixes, assumes) (_ $ arg) u (sub,(hyps,thms)) =
  19.731 +          let
  19.732 +            val used = map (fn (ctx,thm) => FundefCtxTree.export_thm thy ctx thm) (u @ sub)
  19.733 +
  19.734 +            val hyp = HOLogic.mk_Trueprop (R' $ arg $ lhs)
  19.735 +                      |> fold_rev (curry Logic.mk_implies o prop_of) used (* additional hyps *)
  19.736 +                      |> FundefCtxTree.export_term (fixes, assumes)
  19.737 +                      |> fold_rev (curry Logic.mk_implies o prop_of) ags
  19.738 +                      |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  19.739 +                      |> cterm_of thy
  19.740 +
  19.741 +            val thm = assume hyp
  19.742 +                      |> fold forall_elim cqs
  19.743 +                      |> fold Thm.elim_implies ags
  19.744 +                      |> FundefCtxTree.import_thm thy (fixes, assumes)
  19.745 +                      |> fold Thm.elim_implies used (*  "(arg, lhs) : R'"  *)
  19.746 +
  19.747 +            val z_eq_arg = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (z, arg))))
  19.748 +
  19.749 +            val acc = thm COMP ih_case
  19.750 +            val z_acc_local = acc
  19.751 +            |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (K (symmetric (z_eq_arg RS eq_reflection)))))
  19.752 +
  19.753 +            val ethm = z_acc_local
  19.754 +                         |> FundefCtxTree.export_thm thy (fixes,
  19.755 +                                                          z_eq_arg :: case_hyp :: ags @ assumes)
  19.756 +                         |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  19.757 +
  19.758 +            val sub' = sub @ [(([],[]), acc)]
  19.759 +          in
  19.760 +            (sub', (hyp :: hyps, ethm :: thms))
  19.761 +          end
  19.762 +        | step _ _ _ _ = raise Match
  19.763 +    in
  19.764 +      FundefCtxTree.traverse_tree step tree
  19.765 +    end
  19.766 +
  19.767 +
  19.768 +fun mk_nest_term_rule thy globals R R_cases clauses =
  19.769 +    let
  19.770 +      val Globals { domT, x, z, ... } = globals
  19.771 +      val acc_R = mk_acc domT R
  19.772 +
  19.773 +      val R' = Free ("R", fastype_of R)
  19.774 +
  19.775 +      val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
  19.776 +      val inrel_R = Const ("FunDef.in_rel", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
  19.777 +
  19.778 +      val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name "Wellfounded.wfP"}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
  19.779 +
  19.780 +      (* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
  19.781 +      val ihyp = Term.all domT $ Abs ("z", domT,
  19.782 +                                 Logic.mk_implies (HOLogic.mk_Trueprop (R' $ Bound 0 $ x),
  19.783 +                                   HOLogic.mk_Trueprop (acc_R $ Bound 0)))
  19.784 +                     |> cterm_of thy
  19.785 +
  19.786 +      val ihyp_a = assume ihyp |> Thm.forall_elim_vars 0
  19.787 +
  19.788 +      val R_z_x = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ x))
  19.789 +
  19.790 +      val (hyps,cases) = fold (mk_nest_term_case thy globals R' ihyp_a) clauses ([],[])
  19.791 +    in
  19.792 +      R_cases
  19.793 +        |> forall_elim (cterm_of thy z)
  19.794 +        |> forall_elim (cterm_of thy x)
  19.795 +        |> forall_elim (cterm_of thy (acc_R $ z))
  19.796 +        |> curry op COMP (assume R_z_x)
  19.797 +        |> fold_rev (curry op COMP) cases
  19.798 +        |> implies_intr R_z_x
  19.799 +        |> forall_intr (cterm_of thy z)
  19.800 +        |> (fn it => it COMP accI)
  19.801 +        |> implies_intr ihyp
  19.802 +        |> forall_intr (cterm_of thy x)
  19.803 +        |> (fn it => Drule.compose_single(it,2,wf_induct_rule))
  19.804 +        |> curry op RS (assume wfR')
  19.805 +        |> forall_intr_vars
  19.806 +        |> (fn it => it COMP allI)
  19.807 +        |> fold implies_intr hyps
  19.808 +        |> implies_intr wfR'
  19.809 +        |> forall_intr (cterm_of thy R')
  19.810 +        |> forall_elim (cterm_of thy (inrel_R))
  19.811 +        |> curry op RS wf_in_rel
  19.812 +        |> full_simplify (HOL_basic_ss addsimps [in_rel_def])
  19.813 +        |> forall_intr (cterm_of thy Rrel)
  19.814 +    end
  19.815 +
  19.816 +
  19.817 +
  19.818 +(* Tail recursion (probably very fragile)
  19.819 + *
  19.820 + * FIXME:
  19.821 + * - Need to do forall_elim_vars on psimps: Unneccesary, if psimps would be taken from the same context.
  19.822 + * - Must we really replace the fvar by f here?
  19.823 + * - Splitting is not configured automatically: Problems with case?
  19.824 + *)
  19.825 +fun mk_trsimps octxt globals f G R f_def R_cases G_induct clauses psimps =
  19.826 +    let
  19.827 +      val Globals {domT, ranT, fvar, ...} = globals
  19.828 +
  19.829 +      val R_cases = Thm.forall_elim_vars 0 R_cases (* FIXME: Should be already in standard form. *)
  19.830 +
  19.831 +      val graph_implies_dom = (* "G ?x ?y ==> dom ?x"  *)
  19.832 +          Goal.prove octxt ["x", "y"] [HOLogic.mk_Trueprop (G $ Free ("x", domT) $ Free ("y", ranT))]
  19.833 +                     (HOLogic.mk_Trueprop (mk_acc domT R $ Free ("x", domT)))
  19.834 +                     (fn {prems=[a], ...} =>
  19.835 +                         ((rtac (G_induct OF [a]))
  19.836 +                            THEN_ALL_NEW (rtac accI)
  19.837 +                            THEN_ALL_NEW (etac R_cases)
  19.838 +                            THEN_ALL_NEW (asm_full_simp_tac (local_simpset_of octxt))) 1)
  19.839 +
  19.840 +      val default_thm = (forall_intr_vars graph_implies_dom) COMP (f_def COMP fundef_default_value)
  19.841 +
  19.842 +      fun mk_trsimp clause psimp =
  19.843 +          let
  19.844 +            val ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {ctxt, cqs, qs, gs, lhs, rhs, ...}, ...} = clause
  19.845 +            val thy = ProofContext.theory_of ctxt
  19.846 +            val rhs_f = Pattern.rewrite_term thy [(fvar, f)] [] rhs
  19.847 +
  19.848 +            val trsimp = Logic.list_implies(gs, HOLogic.mk_Trueprop (HOLogic.mk_eq(f $ lhs, rhs_f))) (* "f lhs = rhs" *)
  19.849 +            val lhs_acc = (mk_acc domT R $ lhs) (* "acc R lhs" *)
  19.850 +            fun simp_default_tac ss = asm_full_simp_tac (ss addsimps [default_thm, Let_def])
  19.851 +          in
  19.852 +            Goal.prove ctxt [] [] trsimp
  19.853 +                       (fn _ =>
  19.854 +                           rtac (instantiate' [] [SOME (cterm_of thy lhs_acc)] case_split) 1
  19.855 +                                THEN (rtac (Thm.forall_elim_vars 0 psimp) THEN_ALL_NEW assume_tac) 1
  19.856 +                                THEN (simp_default_tac (local_simpset_of ctxt) 1)
  19.857 +                                THEN (etac not_acc_down 1)
  19.858 +                                THEN ((etac R_cases) THEN_ALL_NEW (simp_default_tac (local_simpset_of ctxt))) 1)
  19.859 +              |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  19.860 +          end
  19.861 +    in
  19.862 +      map2 mk_trsimp clauses psimps
  19.863 +    end
  19.864 +
  19.865 +
  19.866 +fun prepare_fundef config defname [((fname, fT), mixfix)] abstract_qglrs lthy =
  19.867 +    let
  19.868 +      val FundefConfig {domintros, tailrec, default=default_str, ...} = config
  19.869 +
  19.870 +      val fvar = Free (fname, fT)
  19.871 +      val domT = domain_type fT
  19.872 +      val ranT = range_type fT
  19.873 +
  19.874 +      val default = Syntax.parse_term lthy default_str
  19.875 +        |> TypeInfer.constrain fT |> Syntax.check_term lthy
  19.876 +
  19.877 +      val (globals, ctxt') = fix_globals domT ranT fvar lthy
  19.878 +
  19.879 +      val Globals { x, h, ... } = globals
  19.880 +
  19.881 +      val clauses = map (mk_clause_context x ctxt') abstract_qglrs
  19.882 +
  19.883 +      val n = length abstract_qglrs
  19.884 +
  19.885 +      fun build_tree (ClauseContext { ctxt, rhs, ...}) =
  19.886 +            FundefCtxTree.mk_tree (fname, fT) h ctxt rhs
  19.887 +
  19.888 +      val trees = map build_tree clauses
  19.889 +      val RCss = map find_calls trees
  19.890 +
  19.891 +      val ((G, GIntro_thms, G_elim, G_induct), lthy) =
  19.892 +          PROFILE "def_graph" (define_graph (graph_name defname) fvar domT ranT clauses RCss) lthy
  19.893 +
  19.894 +      val ((f, f_defthm), lthy) =
  19.895 +          PROFILE "def_fun" (define_function (defname ^ "_sumC_def") (fname, mixfix) domT ranT G default) lthy
  19.896 +
  19.897 +      val RCss = map (map (inst_RC (ProofContext.theory_of lthy) fvar f)) RCss
  19.898 +      val trees = map (FundefCtxTree.inst_tree (ProofContext.theory_of lthy) fvar f) trees
  19.899 +
  19.900 +      val ((R, RIntro_thmss, R_elim), lthy) =
  19.901 +          PROFILE "def_rel" (define_recursion_relation (rel_name defname) domT ranT fvar f abstract_qglrs clauses RCss) lthy
  19.902 +
  19.903 +      val (_, lthy) =
  19.904 +          LocalTheory.abbrev Syntax.mode_default ((Binding.name (dom_name defname), NoSyn), mk_acc domT R) lthy
  19.905 +
  19.906 +      val newthy = ProofContext.theory_of lthy
  19.907 +      val clauses = map (transfer_clause_ctx newthy) clauses
  19.908 +
  19.909 +      val cert = cterm_of (ProofContext.theory_of lthy)
  19.910 +
  19.911 +      val xclauses = PROFILE "xclauses" (map7 (mk_clause_info globals G f) (1 upto n) clauses abstract_qglrs trees RCss GIntro_thms) RIntro_thmss
  19.912 +
  19.913 +      val complete = mk_completeness globals clauses abstract_qglrs |> cert |> assume
  19.914 +      val compat = mk_compat_proof_obligations domT ranT fvar f abstract_qglrs |> map (cert #> assume)
  19.915 +
  19.916 +      val compat_store = store_compat_thms n compat
  19.917 +
  19.918 +      val (goalstate, values) = PROFILE "prove_stuff" (prove_stuff lthy globals G f R xclauses complete compat compat_store G_elim) f_defthm
  19.919 +
  19.920 +      val mk_trsimps = mk_trsimps lthy globals f G R f_defthm R_elim G_induct xclauses
  19.921 +
  19.922 +      fun mk_partial_rules provedgoal =
  19.923 +          let
  19.924 +            val newthy = theory_of_thm provedgoal (*FIXME*)
  19.925 +
  19.926 +            val (graph_is_function, complete_thm) =
  19.927 +                provedgoal
  19.928 +                  |> Conjunction.elim
  19.929 +                  |> apfst (Thm.forall_elim_vars 0)
  19.930 +
  19.931 +            val f_iff = graph_is_function RS (f_defthm RS ex1_implies_iff)
  19.932 +
  19.933 +            val psimps = PROFILE "Proving simplification rules" (mk_psimps newthy globals R xclauses values f_iff) graph_is_function
  19.934 +
  19.935 +            val simple_pinduct = PROFILE "Proving partial induction rule"
  19.936 +                                                           (mk_partial_induct_rule newthy globals R complete_thm) xclauses
  19.937 +
  19.938 +
  19.939 +            val total_intro = PROFILE "Proving nested termination rule" (mk_nest_term_rule newthy globals R R_elim) xclauses
  19.940 +
  19.941 +            val dom_intros = if domintros
  19.942 +                             then SOME (PROFILE "Proving domain introduction rules" (map (mk_domain_intro lthy globals R R_elim)) xclauses)
  19.943 +                             else NONE
  19.944 +            val trsimps = if tailrec then SOME (mk_trsimps psimps) else NONE
  19.945 +
  19.946 +          in
  19.947 +            FundefResult {fs=[f], G=G, R=R, cases=complete_thm,
  19.948 +                          psimps=psimps, simple_pinducts=[simple_pinduct],
  19.949 +                          termination=total_intro, trsimps=trsimps,
  19.950 +                          domintros=dom_intros}
  19.951 +          end
  19.952 +    in
  19.953 +      ((f, goalstate, mk_partial_rules), lthy)
  19.954 +    end
  19.955 +
  19.956 +
  19.957 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Tools/Function/fundef_datatype.ML	Tue Jun 23 12:09:30 2009 +0200
    20.3 @@ -0,0 +1,330 @@
    20.4 +(*  Title:      HOL/Tools/Function/fundef_datatype.ML
    20.5 +    Author:     Alexander Krauss, TU Muenchen
    20.6 +
    20.7 +A package for general recursive function definitions.
    20.8 +A tactic to prove completeness of datatype patterns.
    20.9 +*)
   20.10 +
   20.11 +signature FUNDEF_DATATYPE =
   20.12 +sig
   20.13 +    val pat_completeness_tac: Proof.context -> int -> tactic
   20.14 +    val pat_completeness: Proof.context -> Proof.method
   20.15 +    val prove_completeness : theory -> term list -> term -> term list list -> term list list -> thm
   20.16 +
   20.17 +    val setup : theory -> theory
   20.18 +
   20.19 +    val add_fun : FundefCommon.fundef_config ->
   20.20 +      (binding * typ option * mixfix) list -> (Attrib.binding * term) list ->
   20.21 +      bool -> local_theory -> Proof.context
   20.22 +    val add_fun_cmd : FundefCommon.fundef_config ->
   20.23 +      (binding * string option * mixfix) list -> (Attrib.binding * string) list ->
   20.24 +      bool -> local_theory -> Proof.context
   20.25 +end
   20.26 +
   20.27 +structure FundefDatatype : FUNDEF_DATATYPE =
   20.28 +struct
   20.29 +
   20.30 +open FundefLib
   20.31 +open FundefCommon
   20.32 +
   20.33 +
   20.34 +fun check_pats ctxt geq =
   20.35 +    let 
   20.36 +      fun err str = error (cat_lines ["Malformed definition:",
   20.37 +                                      str ^ " not allowed in sequential mode.",
   20.38 +                                      Syntax.string_of_term ctxt geq])
   20.39 +      val thy = ProofContext.theory_of ctxt
   20.40 +                
   20.41 +      fun check_constr_pattern (Bound _) = ()
   20.42 +        | check_constr_pattern t =
   20.43 +          let
   20.44 +            val (hd, args) = strip_comb t
   20.45 +          in
   20.46 +            (((case Datatype.datatype_of_constr thy (fst (dest_Const hd)) of
   20.47 +                 SOME _ => ()
   20.48 +               | NONE => err "Non-constructor pattern")
   20.49 +              handle TERM ("dest_Const", _) => err "Non-constructor patterns");
   20.50 +             map check_constr_pattern args; 
   20.51 +             ())
   20.52 +          end
   20.53 +          
   20.54 +      val (fname, qs, gs, args, rhs) = split_def ctxt geq 
   20.55 +                                       
   20.56 +      val _ = if not (null gs) then err "Conditional equations" else ()
   20.57 +      val _ = map check_constr_pattern args
   20.58 +                  
   20.59 +                  (* just count occurrences to check linearity *)
   20.60 +      val _ = if fold (fold_aterms (fn Bound _ => curry (op +) 1 | _ => I)) args 0 > length qs
   20.61 +              then err "Nonlinear patterns" else ()
   20.62 +    in
   20.63 +      ()
   20.64 +    end
   20.65 +    
   20.66 +
   20.67 +fun mk_argvar i T = Free ("_av" ^ (string_of_int i), T)
   20.68 +fun mk_patvar i T = Free ("_pv" ^ (string_of_int i), T)
   20.69 +
   20.70 +fun inst_free var inst thm =
   20.71 +    forall_elim inst (forall_intr var thm)
   20.72 +
   20.73 +
   20.74 +fun inst_case_thm thy x P thm =
   20.75 +    let
   20.76 +        val [Pv, xv] = Term.add_vars (prop_of thm) []
   20.77 +    in
   20.78 +        cterm_instantiate [(cterm_of thy (Var xv), cterm_of thy x), 
   20.79 +                           (cterm_of thy (Var Pv), cterm_of thy P)] thm
   20.80 +    end
   20.81 +
   20.82 +
   20.83 +fun invent_vars constr i =
   20.84 +    let
   20.85 +        val Ts = binder_types (fastype_of constr)
   20.86 +        val j = i + length Ts
   20.87 +        val is = i upto (j - 1)
   20.88 +        val avs = map2 mk_argvar is Ts
   20.89 +        val pvs = map2 mk_patvar is Ts
   20.90 +    in
   20.91 +        (avs, pvs, j)
   20.92 +    end
   20.93 +
   20.94 +
   20.95 +fun filter_pats thy cons pvars [] = []
   20.96 +  | filter_pats thy cons pvars (([], thm) :: pts) = raise Match
   20.97 +  | filter_pats thy cons pvars ((pat :: pats, thm) :: pts) =
   20.98 +    case pat of
   20.99 +        Free _ => let val inst = list_comb (cons, pvars)
  20.100 +                 in (inst :: pats, inst_free (cterm_of thy pat) (cterm_of thy inst) thm)
  20.101 +                    :: (filter_pats thy cons pvars pts) end
  20.102 +      | _ => if fst (strip_comb pat) = cons
  20.103 +             then (pat :: pats, thm) :: (filter_pats thy cons pvars pts)
  20.104 +             else filter_pats thy cons pvars pts
  20.105 +
  20.106 +
  20.107 +fun inst_constrs_of thy (T as Type (name, _)) =
  20.108 +        map (fn (Cn,CT) => Envir.subst_TVars (Sign.typ_match thy (body_type CT, T) Vartab.empty) (Const (Cn, CT)))
  20.109 +            (the (Datatype.get_datatype_constrs thy name))
  20.110 +  | inst_constrs_of thy _ = raise Match
  20.111 +
  20.112 +
  20.113 +fun transform_pat thy avars c_assum ([] , thm) = raise Match
  20.114 +  | transform_pat thy avars c_assum (pat :: pats, thm) =
  20.115 +    let
  20.116 +        val (_, subps) = strip_comb pat
  20.117 +        val eqs = map (cterm_of thy o HOLogic.mk_Trueprop o HOLogic.mk_eq) (avars ~~ subps)
  20.118 +        val a_eqs = map assume eqs
  20.119 +        val c_eq_pat = simplify (HOL_basic_ss addsimps a_eqs) c_assum
  20.120 +    in
  20.121 +        (subps @ pats, fold_rev implies_intr eqs
  20.122 +                                (implies_elim thm c_eq_pat))
  20.123 +    end
  20.124 +
  20.125 +
  20.126 +exception COMPLETENESS
  20.127 +
  20.128 +fun constr_case thy P idx (v :: vs) pats cons =
  20.129 +    let
  20.130 +        val (avars, pvars, newidx) = invent_vars cons idx
  20.131 +        val c_hyp = cterm_of thy (HOLogic.mk_Trueprop (HOLogic.mk_eq (v, list_comb (cons, avars))))
  20.132 +        val c_assum = assume c_hyp
  20.133 +        val newpats = map (transform_pat thy avars c_assum) (filter_pats thy cons pvars pats)
  20.134 +    in
  20.135 +        o_alg thy P newidx (avars @ vs) newpats
  20.136 +              |> implies_intr c_hyp
  20.137 +              |> fold_rev (forall_intr o cterm_of thy) avars
  20.138 +    end
  20.139 +  | constr_case _ _ _ _ _ _ = raise Match
  20.140 +and o_alg thy P idx [] (([], Pthm) :: _)  = Pthm
  20.141 +  | o_alg thy P idx (v :: vs) [] = raise COMPLETENESS
  20.142 +  | o_alg thy P idx (v :: vs) pts =
  20.143 +    if forall (is_Free o hd o fst) pts (* Var case *)
  20.144 +    then o_alg thy P idx vs (map (fn (pv :: pats, thm) =>
  20.145 +                               (pats, refl RS (inst_free (cterm_of thy pv) (cterm_of thy v) thm))) pts)
  20.146 +    else (* Cons case *)
  20.147 +         let
  20.148 +             val T = fastype_of v
  20.149 +             val (tname, _) = dest_Type T
  20.150 +             val {exhaustion=case_thm, ...} = Datatype.the_datatype thy tname
  20.151 +             val constrs = inst_constrs_of thy T
  20.152 +             val c_cases = map (constr_case thy P idx (v :: vs) pts) constrs
  20.153 +         in
  20.154 +             inst_case_thm thy v P case_thm
  20.155 +                           |> fold (curry op COMP) c_cases
  20.156 +         end
  20.157 +  | o_alg _ _ _ _ _ = raise Match
  20.158 +
  20.159 +
  20.160 +fun prove_completeness thy xs P qss patss =
  20.161 +    let
  20.162 +        fun mk_assum qs pats = 
  20.163 +            HOLogic.mk_Trueprop P
  20.164 +            |> fold_rev (curry Logic.mk_implies o HOLogic.mk_Trueprop o HOLogic.mk_eq) (xs ~~ pats)
  20.165 +            |> fold_rev Logic.all qs
  20.166 +            |> cterm_of thy
  20.167 +
  20.168 +        val hyps = map2 mk_assum qss patss
  20.169 +
  20.170 +        fun inst_hyps hyp qs = fold (forall_elim o cterm_of thy) qs (assume hyp)
  20.171 +
  20.172 +        val assums = map2 inst_hyps hyps qss
  20.173 +    in
  20.174 +        o_alg thy P 2 xs (patss ~~ assums)
  20.175 +              |> fold_rev implies_intr hyps
  20.176 +    end
  20.177 +
  20.178 +
  20.179 +
  20.180 +fun pat_completeness_tac ctxt = SUBGOAL (fn (subgoal, i) =>
  20.181 +    let
  20.182 +      val thy = ProofContext.theory_of ctxt
  20.183 +      val (vs, subgf) = dest_all_all subgoal
  20.184 +      val (cases, _ $ thesis) = Logic.strip_horn subgf
  20.185 +          handle Bind => raise COMPLETENESS
  20.186 +
  20.187 +      fun pat_of assum =
  20.188 +            let
  20.189 +                val (qs, imp) = dest_all_all assum
  20.190 +                val prems = Logic.strip_imp_prems imp
  20.191 +            in
  20.192 +              (qs, map (HOLogic.dest_eq o HOLogic.dest_Trueprop) prems)
  20.193 +            end
  20.194 +
  20.195 +        val (qss, x_pats) = split_list (map pat_of cases)
  20.196 +        val xs = map fst (hd x_pats)
  20.197 +                 handle Empty => raise COMPLETENESS
  20.198 +                 
  20.199 +        val patss = map (map snd) x_pats 
  20.200 +
  20.201 +        val complete_thm = prove_completeness thy xs thesis qss patss
  20.202 +             |> fold_rev (forall_intr o cterm_of thy) vs
  20.203 +    in
  20.204 +      PRIMITIVE (fn st => Drule.compose_single(complete_thm, i, st))
  20.205 +    end
  20.206 +    handle COMPLETENESS => no_tac)
  20.207 +
  20.208 +
  20.209 +fun pat_completeness ctxt = SIMPLE_METHOD' (pat_completeness_tac ctxt)
  20.210 +
  20.211 +val by_pat_completeness_auto =
  20.212 +    Proof.global_future_terminal_proof
  20.213 +      (Method.Basic (pat_completeness, Position.none),
  20.214 +       SOME (Method.Source_i (Args.src (("HOL.auto", []), Position.none))))
  20.215 +
  20.216 +fun termination_by method int =
  20.217 +    Fundef.termination_proof NONE
  20.218 +    #> Proof.global_future_terminal_proof
  20.219 +      (Method.Basic (method, Position.none), NONE) int
  20.220 +
  20.221 +fun mk_catchall fixes arity_of =
  20.222 +    let
  20.223 +      fun mk_eqn ((fname, fT), _) =
  20.224 +          let 
  20.225 +            val n = arity_of fname
  20.226 +            val (argTs, rT) = chop n (binder_types fT)
  20.227 +                                   |> apsnd (fn Ts => Ts ---> body_type fT) 
  20.228 +                              
  20.229 +            val qs = map Free (Name.invent_list [] "a" n ~~ argTs)
  20.230 +          in
  20.231 +            HOLogic.mk_eq(list_comb (Free (fname, fT), qs),
  20.232 +                          Const ("HOL.undefined", rT))
  20.233 +              |> HOLogic.mk_Trueprop
  20.234 +              |> fold_rev Logic.all qs
  20.235 +          end
  20.236 +    in
  20.237 +      map mk_eqn fixes
  20.238 +    end
  20.239 +
  20.240 +fun add_catchall ctxt fixes spec =
  20.241 +  let val fqgars = map (split_def ctxt) spec
  20.242 +      val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
  20.243 +                     |> AList.lookup (op =) #> the
  20.244 +  in
  20.245 +    spec @ mk_catchall fixes arity_of
  20.246 +  end
  20.247 +
  20.248 +fun warn_if_redundant ctxt origs tss =
  20.249 +    let
  20.250 +        fun msg t = "Ignoring redundant equation: " ^ quote (Syntax.string_of_term ctxt t)
  20.251 +                    
  20.252 +        val (tss', _) = chop (length origs) tss
  20.253 +        fun check (t, []) = (Output.warning (msg t); [])
  20.254 +          | check (t, s) = s
  20.255 +    in
  20.256 +        (map check (origs ~~ tss'); tss)
  20.257 +    end
  20.258 +
  20.259 +
  20.260 +fun sequential_preproc (config as FundefConfig {sequential, ...}) ctxt fixes spec =
  20.261 +      if sequential then
  20.262 +        let
  20.263 +          val (bnds, eqss) = split_list spec
  20.264 +                            
  20.265 +          val eqs = map the_single eqss
  20.266 +                    
  20.267 +          val feqs = eqs
  20.268 +                      |> tap (check_defs ctxt fixes) (* Standard checks *)
  20.269 +                      |> tap (map (check_pats ctxt))    (* More checks for sequential mode *)
  20.270 +
  20.271 +          val compleqs = add_catchall ctxt fixes feqs   (* Completion *)
  20.272 +
  20.273 +          val spliteqs = warn_if_redundant ctxt feqs
  20.274 +                           (FundefSplit.split_all_equations ctxt compleqs)
  20.275 +
  20.276 +          fun restore_spec thms =
  20.277 +              bnds ~~ Library.take (length bnds, Library.unflat spliteqs thms)
  20.278 +              
  20.279 +          val spliteqs' = flat (Library.take (length bnds, spliteqs))
  20.280 +          val fnames = map (fst o fst) fixes
  20.281 +          val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
  20.282 +
  20.283 +          fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs)
  20.284 +                                       |> map (map snd)
  20.285 +
  20.286 +
  20.287 +          val bnds' = bnds @ replicate (length spliteqs - length bnds) Attrib.empty_binding
  20.288 +
  20.289 +          (* using theorem names for case name currently disabled *)
  20.290 +          val case_names = map_index (fn (i, (_, es)) => mk_case_names i "" (length es)) 
  20.291 +                                     (bnds' ~~ spliteqs)
  20.292 +                           |> flat
  20.293 +        in
  20.294 +          (flat spliteqs, restore_spec, sort, case_names)
  20.295 +        end
  20.296 +      else
  20.297 +        FundefCommon.empty_preproc check_defs config ctxt fixes spec
  20.298 +
  20.299 +val setup =
  20.300 +    Method.setup @{binding pat_completeness} (Scan.succeed pat_completeness)
  20.301 +        "Completeness prover for datatype patterns"
  20.302 +    #> Context.theory_map (FundefCommon.set_preproc sequential_preproc)
  20.303 +
  20.304 +
  20.305 +val fun_config = FundefConfig { sequential=true, default="%x. undefined" (*FIXME dynamic scoping*), 
  20.306 +                                domintros=false, tailrec=false }
  20.307 +
  20.308 +fun gen_fun add config fixes statements int lthy =
  20.309 +  let val group = serial_string () in
  20.310 +    lthy
  20.311 +      |> LocalTheory.set_group group
  20.312 +      |> add fixes statements config
  20.313 +      |> by_pat_completeness_auto int
  20.314 +      |> LocalTheory.restore
  20.315 +      |> LocalTheory.set_group group
  20.316 +      |> termination_by (FundefCommon.get_termination_prover lthy) int
  20.317 +  end;
  20.318 +
  20.319 +val add_fun = gen_fun Fundef.add_fundef
  20.320 +val add_fun_cmd = gen_fun Fundef.add_fundef_cmd
  20.321 +
  20.322 +
  20.323 +
  20.324 +local structure P = OuterParse and K = OuterKeyword in
  20.325 +
  20.326 +val _ =
  20.327 +  OuterSyntax.local_theory' "fun" "define general recursive functions (short version)" K.thy_decl
  20.328 +  (fundef_parser fun_config
  20.329 +     >> (fn ((config, fixes), statements) => add_fun_cmd config fixes statements));
  20.330 +
  20.331 +end
  20.332 +
  20.333 +end
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Tools/Function/fundef_lib.ML	Tue Jun 23 12:09:30 2009 +0200
    21.3 @@ -0,0 +1,176 @@
    21.4 +(*  Title:      HOL/Tools/Function/fundef_lib.ML
    21.5 +    Author:     Alexander Krauss, TU Muenchen
    21.6 +
    21.7 +A package for general recursive function definitions. 
    21.8 +Some fairly general functions that should probably go somewhere else... 
    21.9 +*)
   21.10 +
   21.11 +structure FundefLib = struct
   21.12 +
   21.13 +fun map_option f NONE = NONE 
   21.14 +  | map_option f (SOME x) = SOME (f x);
   21.15 +
   21.16 +fun fold_option f NONE y = y
   21.17 +  | fold_option f (SOME x) y = f x y;
   21.18 +
   21.19 +fun fold_map_option f NONE y = (NONE, y)
   21.20 +  | fold_map_option f (SOME x) y = apfst SOME (f x y);
   21.21 +
   21.22 +(* Ex: "The variable" ^ plural " is" "s are" vs *)
   21.23 +fun plural sg pl [x] = sg
   21.24 +  | plural sg pl _ = pl
   21.25 +
   21.26 +(* lambda-abstracts over an arbitrarily nested tuple
   21.27 +  ==> hologic.ML? *)
   21.28 +fun tupled_lambda vars t =
   21.29 +    case vars of
   21.30 +      (Free v) => lambda (Free v) t
   21.31 +    | (Var v) => lambda (Var v) t
   21.32 +    | (Const ("Pair", Type ("fun", [Ta, Type ("fun", [Tb, _])]))) $ us $ vs =>  
   21.33 +      (HOLogic.split_const (Ta,Tb, fastype_of t)) $ (tupled_lambda us (tupled_lambda vs t))
   21.34 +    | _ => raise Match
   21.35 +                 
   21.36 +                 
   21.37 +fun dest_all (Const ("all", _) $ Abs (a as (_,T,_))) =
   21.38 +    let
   21.39 +      val (n, body) = Term.dest_abs a
   21.40 +    in
   21.41 +      (Free (n, T), body)
   21.42 +    end
   21.43 +  | dest_all _ = raise Match
   21.44 +                         
   21.45 +
   21.46 +(* Removes all quantifiers from a term, replacing bound variables by frees. *)
   21.47 +fun dest_all_all (t as (Const ("all",_) $ _)) = 
   21.48 +    let
   21.49 +      val (v,b) = dest_all t
   21.50 +      val (vs, b') = dest_all_all b
   21.51 +    in
   21.52 +      (v :: vs, b')
   21.53 +    end
   21.54 +  | dest_all_all t = ([],t)
   21.55 +                     
   21.56 +
   21.57 +(* FIXME: similar to Variable.focus *)
   21.58 +fun dest_all_all_ctx ctx (Const ("all", _) $ Abs (a as (n,T,b))) =
   21.59 +    let
   21.60 +      val [(n', _)] = Variable.variant_frees ctx [] [(n,T)]
   21.61 +      val (_, ctx') = ProofContext.add_fixes [(Binding.name n', SOME T, NoSyn)] ctx
   21.62 +
   21.63 +      val (n'', body) = Term.dest_abs (n', T, b) 
   21.64 +      val _ = (n' = n'') orelse error "dest_all_ctx"
   21.65 +      (* Note: We assume that n' does not occur in the body. Otherwise it would be fixed. *)
   21.66 +
   21.67 +      val (ctx'', vs, bd) = dest_all_all_ctx ctx' body
   21.68 +    in
   21.69 +      (ctx'', (n', T) :: vs, bd)
   21.70 +    end
   21.71 +  | dest_all_all_ctx ctx t = 
   21.72 +    (ctx, [], t)
   21.73 +
   21.74 +
   21.75 +fun map3 _ [] [] [] = []
   21.76 +  | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
   21.77 +  | map3 _ _ _ _ = raise Library.UnequalLengths;
   21.78 +
   21.79 +fun map4 _ [] [] [] [] = []
   21.80 +  | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
   21.81 +  | map4 _ _ _ _ _ = raise Library.UnequalLengths;
   21.82 +
   21.83 +fun map6 _ [] [] [] [] [] [] = []
   21.84 +  | map6 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) = f x y z u v w :: map6 f xs ys zs us vs ws
   21.85 +  | map6 _ _ _ _ _ _ _ = raise Library.UnequalLengths;
   21.86 +
   21.87 +fun map7 _ [] [] [] [] [] [] [] = []
   21.88 +  | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
   21.89 +  | map7 _ _ _ _ _ _ _ _ = raise Library.UnequalLengths;
   21.90 +
   21.91 +
   21.92 +
   21.93 +(* forms all "unordered pairs": [1, 2, 3] ==> [(1, 1), (1, 2), (1, 3), (2, 2), (2, 3), (3, 3)] *)
   21.94 +(* ==> library *)
   21.95 +fun unordered_pairs [] = []
   21.96 +  | unordered_pairs (x::xs) = map (pair x) (x::xs) @ unordered_pairs xs
   21.97 +
   21.98 +
   21.99 +(* Replaces Frees by name. Works with loose Bounds. *)
  21.100 +fun replace_frees assoc =
  21.101 +    map_aterms (fn c as Free (n, _) => the_default c (AList.lookup (op =) assoc n)
  21.102 +                 | t => t)
  21.103 +
  21.104 +
  21.105 +fun rename_bound n (Q $ Abs(_, T, b)) = (Q $ Abs(n, T, b))
  21.106 +  | rename_bound n _ = raise Match
  21.107 +
  21.108 +fun mk_forall_rename (n, v) =
  21.109 +    rename_bound n o Logic.all v 
  21.110 +
  21.111 +fun forall_intr_rename (n, cv) thm =
  21.112 +    let
  21.113 +      val allthm = forall_intr cv thm
  21.114 +      val (_ $ abs) = prop_of allthm
  21.115 +    in
  21.116 +      Thm.rename_boundvars abs (Abs (n, dummyT, Term.dummy_pattern dummyT)) allthm
  21.117 +    end
  21.118 +
  21.119 +
  21.120 +(* Returns the frees in a term in canonical order, excluding the fixes from the context *)
  21.121 +fun frees_in_term ctxt t =
  21.122 +    Term.add_frees t []
  21.123 +    |> filter_out (Variable.is_fixed ctxt o fst)
  21.124 +    |> rev
  21.125 +
  21.126 +
  21.127 +datatype proof_attempt = Solved of thm | Stuck of thm | Fail
  21.128 +
  21.129 +fun try_proof cgoal tac = 
  21.130 +    case SINGLE tac (Goal.init cgoal) of
  21.131 +      NONE => Fail
  21.132 +    | SOME st => if Thm.no_prems st then Solved (Goal.finish st) else Stuck st
  21.133 +
  21.134 +
  21.135 +fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) = 
  21.136 +    if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
  21.137 +  | dest_binop_list _ t = [ t ]
  21.138 +
  21.139 +
  21.140 +(* separate two parts in a +-expression:
  21.141 +   "a + b + c + d + e" --> "(a + b + d) + (c + e)"
  21.142 +
  21.143 +   Here, + can be any binary operation that is AC.
  21.144 +
  21.145 +   cn - The name of the binop-constructor (e.g. @{const_name Un})
  21.146 +   ac - the AC rewrite rules for cn
  21.147 +   is - the list of indices of the expressions that should become the first part
  21.148 +        (e.g. [0,1,3] in the above example)
  21.149 +*)
  21.150 +
  21.151 +fun regroup_conv neu cn ac is ct =
  21.152 + let
  21.153 +   val mk = HOLogic.mk_binop cn
  21.154 +   val t = term_of ct
  21.155 +   val xs = dest_binop_list cn t
  21.156 +   val js = 0 upto (length xs) - 1 \\ is
  21.157 +   val ty = fastype_of t
  21.158 +   val thy = theory_of_cterm ct
  21.159 + in
  21.160 +   Goal.prove_internal []
  21.161 +     (cterm_of thy
  21.162 +       (Logic.mk_equals (t,
  21.163 +          if is = []
  21.164 +          then mk (Const (neu, ty), foldr1 mk (map (nth xs) js))
  21.165 +          else if js = []
  21.166 +            then mk (foldr1 mk (map (nth xs) is), Const (neu, ty))
  21.167 +            else mk (foldr1 mk (map (nth xs) is), foldr1 mk (map (nth xs) js)))))
  21.168 +     (K (rewrite_goals_tac ac
  21.169 +         THEN rtac Drule.reflexive_thm 1))
  21.170 + end
  21.171 +
  21.172 +(* instance for unions *)
  21.173 +fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Un}
  21.174 +  (map (fn t => t RS eq_reflection) (@{thms "Un_ac"} @
  21.175 +                                     @{thms "Un_empty_right"} @
  21.176 +                                     @{thms "Un_empty_left"})) t
  21.177 +
  21.178 +
  21.179 +end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Tools/Function/induction_scheme.ML	Tue Jun 23 12:09:30 2009 +0200
    22.3 @@ -0,0 +1,405 @@
    22.4 +(*  Title:      HOL/Tools/Function/induction_scheme.ML
    22.5 +    Author:     Alexander Krauss, TU Muenchen
    22.6 +
    22.7 +A method to prove induction schemes.
    22.8 +*)
    22.9 +
   22.10 +signature INDUCTION_SCHEME =
   22.11 +sig
   22.12 +  val mk_ind_tac : (int -> tactic) -> (int -> tactic) -> (int -> tactic)
   22.13 +                   -> Proof.context -> thm list -> tactic
   22.14 +  val induct_scheme_tac : Proof.context -> thm list -> tactic
   22.15 +  val setup : theory -> theory
   22.16 +end
   22.17 +
   22.18 +
   22.19 +structure InductionScheme : INDUCTION_SCHEME =
   22.20 +struct
   22.21 +
   22.22 +open FundefLib
   22.23 +
   22.24 +
   22.25 +type rec_call_info = int * (string * typ) list * term list * term list
   22.26 +
   22.27 +datatype scheme_case =
   22.28 +  SchemeCase of
   22.29 +  {
   22.30 +   bidx : int,
   22.31 +   qs: (string * typ) list,
   22.32 +   oqnames: string list,
   22.33 +   gs: term list,
   22.34 +   lhs: term list,
   22.35 +   rs: rec_call_info list
   22.36 +  }
   22.37 +
   22.38 +datatype scheme_branch = 
   22.39 +  SchemeBranch of
   22.40 +  {
   22.41 +   P : term,
   22.42 +   xs: (string * typ) list,
   22.43 +   ws: (string * typ) list,
   22.44 +   Cs: term list
   22.45 +  }
   22.46 +
   22.47 +datatype ind_scheme =
   22.48 +  IndScheme of
   22.49 +  {
   22.50 +   T: typ, (* sum of products *)
   22.51 +   branches: scheme_branch list,
   22.52 +   cases: scheme_case list
   22.53 +  }
   22.54 +
   22.55 +val ind_atomize = MetaSimplifier.rewrite true @{thms induct_atomize}
   22.56 +val ind_rulify = MetaSimplifier.rewrite true @{thms induct_rulify}
   22.57 +
   22.58 +fun meta thm = thm RS eq_reflection
   22.59 +
   22.60 +val sum_prod_conv = MetaSimplifier.rewrite true 
   22.61 +                    (map meta (@{thm split_conv} :: @{thms sum.cases}))
   22.62 +
   22.63 +fun term_conv thy cv t = 
   22.64 +    cv (cterm_of thy t)
   22.65 +    |> prop_of |> Logic.dest_equals |> snd
   22.66 +
   22.67 +fun mk_relT T = HOLogic.mk_setT (HOLogic.mk_prodT (T, T))
   22.68 +
   22.69 +fun dest_hhf ctxt t = 
   22.70 +    let 
   22.71 +      val (ctxt', vars, imp) = dest_all_all_ctx ctxt t
   22.72 +    in
   22.73 +      (ctxt', vars, Logic.strip_imp_prems imp, Logic.strip_imp_concl imp)
   22.74 +    end
   22.75 +
   22.76 +
   22.77 +fun mk_scheme' ctxt cases concl =
   22.78 +    let
   22.79 +      fun mk_branch concl =
   22.80 +          let
   22.81 +            val (ctxt', ws, Cs, _ $ Pxs) = dest_hhf ctxt concl
   22.82 +            val (P, xs) = strip_comb Pxs
   22.83 +          in
   22.84 +            SchemeBranch { P=P, xs=map dest_Free xs, ws=ws, Cs=Cs }
   22.85 +          end
   22.86 +
   22.87 +      val (branches, cases') = (* correction *)
   22.88 +          case Logic.dest_conjunction_list concl of
   22.89 +            [conc] => 
   22.90 +            let 
   22.91 +              val _ $ Pxs = Logic.strip_assums_concl conc
   22.92 +              val (P, _) = strip_comb Pxs
   22.93 +              val (cases', conds) = take_prefix (Term.exists_subterm (curry op aconv P)) cases
   22.94 +              val concl' = fold_rev (curry Logic.mk_implies) conds conc
   22.95 +            in
   22.96 +              ([mk_branch concl'], cases')
   22.97 +            end
   22.98 +          | concls => (map mk_branch concls, cases)
   22.99 +
  22.100 +      fun mk_case premise =
  22.101 +          let
  22.102 +            val (ctxt', qs, prems, _ $ Plhs) = dest_hhf ctxt premise
  22.103 +            val (P, lhs) = strip_comb Plhs
  22.104 +                                
  22.105 +            fun bidx Q = find_index (fn SchemeBranch {P=P',...} => Q aconv P') branches
  22.106 +
  22.107 +            fun mk_rcinfo pr =
  22.108 +                let
  22.109 +                  val (ctxt'', Gvs, Gas, _ $ Phyp) = dest_hhf ctxt' pr
  22.110 +                  val (P', rcs) = strip_comb Phyp
  22.111 +                in
  22.112 +                  (bidx P', Gvs, Gas, rcs)
  22.113 +                end
  22.114 +                
  22.115 +            fun is_pred v = exists (fn SchemeBranch {P,...} => v aconv P) branches
  22.116 +
  22.117 +            val (gs, rcprs) = 
  22.118 +                take_prefix (not o Term.exists_subterm is_pred) prems
  22.119 +          in
  22.120 +            SchemeCase {bidx=bidx P, qs=qs, oqnames=map fst qs(*FIXME*), gs=gs, lhs=lhs, rs=map mk_rcinfo rcprs}
  22.121 +          end
  22.122 +
  22.123 +      fun PT_of (SchemeBranch { xs, ...}) =
  22.124 +            foldr1 HOLogic.mk_prodT (map snd xs)
  22.125 +
  22.126 +      val ST = BalancedTree.make (uncurry SumTree.mk_sumT) (map PT_of branches)
  22.127 +    in
  22.128 +      IndScheme {T=ST, cases=map mk_case cases', branches=branches }
  22.129 +    end
  22.130 +
  22.131 +
  22.132 +
  22.133 +fun mk_completeness ctxt (IndScheme {cases, branches, ...}) bidx =
  22.134 +    let
  22.135 +      val SchemeBranch { xs, ws, Cs, ... } = nth branches bidx
  22.136 +      val relevant_cases = filter (fn SchemeCase {bidx=bidx', ...} => bidx' = bidx) cases
  22.137 +
  22.138 +      val allqnames = fold (fn SchemeCase {qs, ...} => fold (insert (op =) o Free) qs) relevant_cases []
  22.139 +      val (Pbool :: xs') = map Free (Variable.variant_frees ctxt allqnames (("P", HOLogic.boolT) :: xs))
  22.140 +      val Cs' = map (Pattern.rewrite_term (ProofContext.theory_of ctxt) (filter_out (op aconv) (map Free xs ~~ xs')) []) Cs
  22.141 +                       
  22.142 +      fun mk_case (SchemeCase {qs, oqnames, gs, lhs, ...}) =
  22.143 +          HOLogic.mk_Trueprop Pbool
  22.144 +                     |> fold_rev (fn x_l => curry Logic.mk_implies (HOLogic.mk_Trueprop(HOLogic.mk_eq x_l)))
  22.145 +                                 (xs' ~~ lhs)
  22.146 +                     |> fold_rev (curry Logic.mk_implies) gs
  22.147 +                     |> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
  22.148 +    in
  22.149 +      HOLogic.mk_Trueprop Pbool
  22.150 +       |> fold_rev (curry Logic.mk_implies o mk_case) relevant_cases
  22.151 +       |> fold_rev (curry Logic.mk_implies) Cs'
  22.152 +       |> fold_rev (Logic.all o Free) ws
  22.153 +       |> fold_rev mk_forall_rename (map fst xs ~~ xs')
  22.154 +       |> mk_forall_rename ("P", Pbool)
  22.155 +    end
  22.156 +
  22.157 +fun mk_wf ctxt R (IndScheme {T, ...}) =
  22.158 +    HOLogic.Trueprop $ (Const (@{const_name "wf"}, mk_relT T --> HOLogic.boolT) $ R)
  22.159 +
  22.160 +fun mk_ineqs R (IndScheme {T, cases, branches}) =
  22.161 +    let
  22.162 +      fun inject i ts =
  22.163 +          SumTree.mk_inj T (length branches) (i + 1) (foldr1 HOLogic.mk_prod ts)
  22.164 +
  22.165 +      val thesis = Free ("thesis", HOLogic.boolT) (* FIXME *)
  22.166 +
  22.167 +      fun mk_pres bdx args = 
  22.168 +          let
  22.169 +            val SchemeBranch { xs, ws, Cs, ... } = nth branches bdx
  22.170 +            fun replace (x, v) t = betapply (lambda (Free x) t, v)
  22.171 +            val Cs' = map (fold replace (xs ~~ args)) Cs
  22.172 +            val cse = 
  22.173 +                HOLogic.mk_Trueprop thesis
  22.174 +                |> fold_rev (curry Logic.mk_implies) Cs'
  22.175 +                |> fold_rev (Logic.all o Free) ws
  22.176 +          in
  22.177 +            Logic.mk_implies (cse, HOLogic.mk_Trueprop thesis)
  22.178 +          end
  22.179 +
  22.180 +      fun f (SchemeCase {bidx, qs, oqnames, gs, lhs, rs, ...}) = 
  22.181 +          let
  22.182 +            fun g (bidx', Gvs, Gas, rcarg) =
  22.183 +                let val export = 
  22.184 +                         fold_rev (curry Logic.mk_implies) Gas
  22.185 +                         #> fold_rev (curry Logic.mk_implies) gs
  22.186 +                         #> fold_rev (Logic.all o Free) Gvs
  22.187 +                         #> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
  22.188 +                in
  22.189 +                (HOLogic.mk_mem (HOLogic.mk_prod (inject bidx' rcarg, inject bidx lhs), R)
  22.190 +                 |> HOLogic.mk_Trueprop
  22.191 +                 |> export,
  22.192 +                 mk_pres bidx' rcarg
  22.193 +                 |> export
  22.194 +                 |> Logic.all thesis)
  22.195 +                end
  22.196 +          in
  22.197 +            map g rs
  22.198 +          end
  22.199 +    in
  22.200 +      map f cases
  22.201 +    end
  22.202 +
  22.203 +
  22.204 +fun mk_hol_imp a b = HOLogic.imp $ a $ b
  22.205 +
  22.206 +fun mk_ind_goal thy branches =
  22.207 +    let
  22.208 +      fun brnch (SchemeBranch { P, xs, ws, Cs, ... }) =
  22.209 +          HOLogic.mk_Trueprop (list_comb (P, map Free xs))
  22.210 +          |> fold_rev (curry Logic.mk_implies) Cs
  22.211 +          |> fold_rev (Logic.all o Free) ws
  22.212 +          |> term_conv thy ind_atomize
  22.213 +          |> ObjectLogic.drop_judgment thy
  22.214 +          |> tupled_lambda (foldr1 HOLogic.mk_prod (map Free xs))
  22.215 +    in
  22.216 +      SumTree.mk_sumcases HOLogic.boolT (map brnch branches)
  22.217 +    end
  22.218 +
  22.219 +
  22.220 +fun mk_induct_rule ctxt R x complete_thms wf_thm ineqss (IndScheme {T, cases=scases, branches}) =
  22.221 +    let
  22.222 +      val n = length branches
  22.223 +
  22.224 +      val scases_idx = map_index I scases
  22.225 +
  22.226 +      fun inject i ts =
  22.227 +          SumTree.mk_inj T n (i + 1) (foldr1 HOLogic.mk_prod ts)
  22.228 +      val P_of = nth (map (fn (SchemeBranch { P, ... }) => P) branches)
  22.229 +
  22.230 +      val thy = ProofContext.theory_of ctxt
  22.231 +      val cert = cterm_of thy 
  22.232 +
  22.233 +      val P_comp = mk_ind_goal thy branches
  22.234 +
  22.235 +      (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
  22.236 +      val ihyp = Term.all T $ Abs ("z", T, 
  22.237 +               Logic.mk_implies
  22.238 +                 (HOLogic.mk_Trueprop (
  22.239 +                  Const ("op :", HOLogic.mk_prodT (T, T) --> mk_relT T --> HOLogic.boolT) 
  22.240 +                    $ (HOLogic.pair_const T T $ Bound 0 $ x) 
  22.241 +                    $ R),
  22.242 +                   HOLogic.mk_Trueprop (P_comp $ Bound 0)))
  22.243 +           |> cert
  22.244 +
  22.245 +      val aihyp = assume ihyp
  22.246 +
  22.247 +     (* Rule for case splitting along the sum types *)
  22.248 +      val xss = map (fn (SchemeBranch { xs, ... }) => map Free xs) branches
  22.249 +      val pats = map_index (uncurry inject) xss
  22.250 +      val sum_split_rule = FundefDatatype.prove_completeness thy [x] (P_comp $ x) xss (map single pats)
  22.251 +
  22.252 +      fun prove_branch (bidx, (SchemeBranch { P, xs, ws, Cs, ... }, (complete_thm, pat))) =
  22.253 +          let
  22.254 +            val fxs = map Free xs
  22.255 +            val branch_hyp = assume (cert (HOLogic.mk_Trueprop (HOLogic.mk_eq (x, pat))))
  22.256 +                             
  22.257 +            val C_hyps = map (cert #> assume) Cs
  22.258 +
  22.259 +            val (relevant_cases, ineqss') = filter (fn ((_, SchemeCase {bidx=bidx', ...}), _) => bidx' = bidx) (scases_idx ~~ ineqss)
  22.260 +                                            |> split_list
  22.261 +                           
  22.262 +            fun prove_case (cidx, SchemeCase {qs, oqnames, gs, lhs, rs, ...}) ineq_press =
  22.263 +                let
  22.264 +                  val case_hyps = map (assume o cert o HOLogic.mk_Trueprop o HOLogic.mk_eq) (fxs ~~ lhs)
  22.265 +                           
  22.266 +                  val cqs = map (cert o Free) qs
  22.267 +                  val ags = map (assume o cert) gs
  22.268 +                            
  22.269 +                  val replace_x_ss = HOL_basic_ss addsimps (branch_hyp :: case_hyps)
  22.270 +                  val sih = full_simplify replace_x_ss aihyp
  22.271 +                            
  22.272 +                  fun mk_Prec (idx, Gvs, Gas, rcargs) (ineq, pres) =
  22.273 +                      let
  22.274 +                        val cGas = map (assume o cert) Gas
  22.275 +                        val cGvs = map (cert o Free) Gvs
  22.276 +                        val import = fold forall_elim (cqs @ cGvs)
  22.277 +                                     #> fold Thm.elim_implies (ags @ cGas)
  22.278 +                        val ipres = pres
  22.279 +                                     |> forall_elim (cert (list_comb (P_of idx, rcargs)))
  22.280 +                                     |> import
  22.281 +                      in
  22.282 +                        sih |> forall_elim (cert (inject idx rcargs))
  22.283 +                            |> Thm.elim_implies (import ineq) (* Psum rcargs *)
  22.284 +                            |> Conv.fconv_rule sum_prod_conv
  22.285 +                            |> Conv.fconv_rule ind_rulify
  22.286 +                            |> (fn th => th COMP ipres) (* P rs *)
  22.287 +                            |> fold_rev (implies_intr o cprop_of) cGas
  22.288 +                            |> fold_rev forall_intr cGvs
  22.289 +                      end
  22.290 +                      
  22.291 +                  val P_recs = map2 mk_Prec rs ineq_press   (*  [P rec1, P rec2, ... ]  *)
  22.292 +                               
  22.293 +                  val step = HOLogic.mk_Trueprop (list_comb (P, lhs))
  22.294 +                             |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
  22.295 +                             |> fold_rev (curry Logic.mk_implies) gs
  22.296 +                             |> fold_rev (Logic.all o Free) qs
  22.297 +                             |> cert
  22.298 +                             
  22.299 +                  val Plhs_to_Pxs_conv = 
  22.300 +                      foldl1 (uncurry Conv.combination_conv) 
  22.301 +                      (Conv.all_conv :: map (fn ch => K (Thm.symmetric (ch RS eq_reflection))) case_hyps)
  22.302 +
  22.303 +                  val res = assume step
  22.304 +                                   |> fold forall_elim cqs
  22.305 +                                   |> fold Thm.elim_implies ags
  22.306 +                                   |> fold Thm.elim_implies P_recs (* P lhs *) 
  22.307 +                                   |> Conv.fconv_rule (Conv.arg_conv Plhs_to_Pxs_conv) (* P xs *)
  22.308 +                                   |> fold_rev (implies_intr o cprop_of) (ags @ case_hyps)
  22.309 +                                   |> fold_rev forall_intr cqs (* !!qs. Gas ==> xs = lhss ==> P xs *)
  22.310 +                in
  22.311 +                  (res, (cidx, step))
  22.312 +                end
  22.313 +
  22.314 +            val (cases, steps) = split_list (map2 prove_case relevant_cases ineqss')
  22.315 +
  22.316 +            val bstep = complete_thm
  22.317 +                |> forall_elim (cert (list_comb (P, fxs)))
  22.318 +                |> fold (forall_elim o cert) (fxs @ map Free ws)
  22.319 +                |> fold Thm.elim_implies C_hyps             (* FIXME: optimization using rotate_prems *)
  22.320 +                |> fold Thm.elim_implies cases (* P xs *)
  22.321 +                |> fold_rev (implies_intr o cprop_of) C_hyps
  22.322 +                |> fold_rev (forall_intr o cert o Free) ws
  22.323 +
  22.324 +            val Pxs = cert (HOLogic.mk_Trueprop (P_comp $ x))
  22.325 +                     |> Goal.init
  22.326 +                     |> (MetaSimplifier.rewrite_goals_tac (map meta (branch_hyp :: @{thm split_conv} :: @{thms sum.cases}))
  22.327 +                         THEN CONVERSION ind_rulify 1)
  22.328 +                     |> Seq.hd
  22.329 +                     |> Thm.elim_implies (Conv.fconv_rule Drule.beta_eta_conversion bstep)
  22.330 +                     |> Goal.finish
  22.331 +                     |> implies_intr (cprop_of branch_hyp)
  22.332 +                     |> fold_rev (forall_intr o cert) fxs
  22.333 +          in
  22.334 +            (Pxs, steps)
  22.335 +          end
  22.336 +
  22.337 +      val (branches, steps) = split_list (map_index prove_branch (branches ~~ (complete_thms ~~ pats)))
  22.338 +                              |> apsnd flat
  22.339 +                           
  22.340 +      val istep = sum_split_rule
  22.341 +                |> fold (fn b => fn th => Drule.compose_single (b, 1, th)) branches
  22.342 +                |> implies_intr ihyp
  22.343 +                |> forall_intr (cert x) (* "!!x. (!!y<x. P y) ==> P x" *)
  22.344 +         
  22.345 +      val induct_rule =
  22.346 +          @{thm "wf_induct_rule"}
  22.347 +            |> (curry op COMP) wf_thm 
  22.348 +            |> (curry op COMP) istep
  22.349 +
  22.350 +      val steps_sorted = map snd (sort (int_ord o pairself fst) steps)
  22.351 +    in
  22.352 +      (steps_sorted, induct_rule)
  22.353 +    end
  22.354 +
  22.355 +
  22.356 +fun mk_ind_tac comp_tac pres_tac term_tac ctxt facts = (ALLGOALS (Method.insert_tac facts)) THEN HEADGOAL 
  22.357 +(SUBGOAL (fn (t, i) =>
  22.358 +  let
  22.359 +    val (ctxt', _, cases, concl) = dest_hhf ctxt t
  22.360 +    val scheme as IndScheme {T=ST, branches, ...} = mk_scheme' ctxt' cases concl
  22.361 +(*     val _ = Output.tracing (makestring scheme)*)
  22.362 +    val ([Rn,xn], ctxt'') = Variable.variant_fixes ["R","x"] ctxt'
  22.363 +    val R = Free (Rn, mk_relT ST)
  22.364 +    val x = Free (xn, ST)
  22.365 +    val cert = cterm_of (ProofContext.theory_of ctxt)
  22.366 +
  22.367 +    val ineqss = mk_ineqs R scheme
  22.368 +                   |> map (map (pairself (assume o cert)))
  22.369 +    val complete = map (mk_completeness ctxt scheme #> cert #> assume) (0 upto (length branches - 1))
  22.370 +    val wf_thm = mk_wf ctxt R scheme |> cert |> assume
  22.371 +
  22.372 +    val (descent, pres) = split_list (flat ineqss)
  22.373 +    val newgoals = complete @ pres @ wf_thm :: descent 
  22.374 +
  22.375 +    val (steps, indthm) = mk_induct_rule ctxt'' R x complete wf_thm ineqss scheme
  22.376 +
  22.377 +    fun project (i, SchemeBranch {xs, ...}) =
  22.378 +        let
  22.379 +          val inst = cert (SumTree.mk_inj ST (length branches) (i + 1) (foldr1 HOLogic.mk_prod (map Free xs)))
  22.380 +        in
  22.381 +          indthm |> Drule.instantiate' [] [SOME inst]
  22.382 +                 |> simplify SumTree.sumcase_split_ss
  22.383 +                 |> Conv.fconv_rule ind_rulify
  22.384 +(*                 |> (fn thm => (Output.tracing (makestring thm); thm))*)
  22.385 +        end                  
  22.386 +
  22.387 +    val res = Conjunction.intr_balanced (map_index project branches)
  22.388 +                 |> fold_rev implies_intr (map cprop_of newgoals @ steps)
  22.389 +                 |> (fn thm => Thm.generalize ([], [Rn]) (Thm.maxidx_of thm + 1) thm)
  22.390 +
  22.391 +    val nbranches = length branches
  22.392 +    val npres = length pres
  22.393 +  in
  22.394 +    Thm.compose_no_flatten false (res, length newgoals) i
  22.395 +    THEN term_tac (i + nbranches + npres)
  22.396 +    THEN (EVERY (map (TRY o pres_tac) ((i + nbranches + npres - 1) downto (i + nbranches))))
  22.397 +    THEN (EVERY (map (TRY o comp_tac) ((i + nbranches - 1) downto i)))
  22.398 +  end))
  22.399 +
  22.400 +
  22.401 +fun induct_scheme_tac ctxt =
  22.402 +  mk_ind_tac (K all_tac) (assume_tac APPEND' Goal.assume_rule_tac ctxt) (K all_tac) ctxt;
  22.403 +
  22.404 +val setup =
  22.405 +  Method.setup @{binding induct_scheme} (Scan.succeed (RAW_METHOD o induct_scheme_tac))
  22.406 +    "proves an induction principle"
  22.407 +
  22.408 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Tools/Function/inductive_wrap.ML	Tue Jun 23 12:09:30 2009 +0200
    23.3 @@ -0,0 +1,67 @@
    23.4 +(*  Title:      HOL/Tools/Function/inductive_wrap.ML
    23.5 +    Author:     Alexander Krauss, TU Muenchen
    23.6 +
    23.7 +
    23.8 +A wrapper around the inductive package, restoring the quantifiers in
    23.9 +the introduction and elimination rules.
   23.10 +*)
   23.11 +
   23.12 +signature FUNDEF_INDUCTIVE_WRAP =
   23.13 +sig
   23.14 +  val inductive_def :  term list 
   23.15 +                       -> ((bstring * typ) * mixfix) * local_theory
   23.16 +                       -> thm list * (term * thm * thm * local_theory)
   23.17 +end
   23.18 +
   23.19 +structure FundefInductiveWrap: FUNDEF_INDUCTIVE_WRAP =
   23.20 +struct
   23.21 +
   23.22 +open FundefLib
   23.23 +
   23.24 +fun requantify ctxt lfix orig_def thm =
   23.25 +    let
   23.26 +      val (qs, t) = dest_all_all orig_def
   23.27 +      val thy = theory_of_thm thm
   23.28 +      val frees = frees_in_term ctxt t 
   23.29 +                  |> remove (op =) lfix
   23.30 +      val vars = Term.add_vars (prop_of thm) [] |> rev
   23.31 +                 
   23.32 +      val varmap = frees ~~ vars
   23.33 +    in
   23.34 +      fold_rev (fn Free (n, T) => 
   23.35 +                   forall_intr_rename (n, cterm_of thy (Var (the_default (("",0), T) (AList.lookup (op =) varmap (n, T))))))
   23.36 +               qs
   23.37 +               thm
   23.38 +    end             
   23.39 +  
   23.40 +  
   23.41 +
   23.42 +fun inductive_def defs (((R, T), mixfix), lthy) =
   23.43 +    let
   23.44 +      val ({intrs = intrs_gen, elims = [elim_gen], preds = [ Rdef ], induct, ...}, lthy) =
   23.45 +          Inductive.add_inductive_i
   23.46 +            {quiet_mode = false,
   23.47 +              verbose = ! Toplevel.debug,
   23.48 +              kind = Thm.internalK,
   23.49 +              alt_name = Binding.empty,
   23.50 +              coind = false,
   23.51 +              no_elim = false,
   23.52 +              no_ind = false,
   23.53 +              skip_mono = true,
   23.54 +              fork_mono = false}
   23.55 +            [((Binding.name R, T), NoSyn)] (* the relation *)
   23.56 +            [] (* no parameters *)
   23.57 +            (map (fn t => (Attrib.empty_binding, t)) defs) (* the intros *)
   23.58 +            [] (* no special monos *)
   23.59 +            lthy
   23.60 +
   23.61 +      val intrs = map2 (requantify lthy (R, T)) defs intrs_gen
   23.62 +                  
   23.63 +      val elim = elim_gen
   23.64 +                   |> forall_intr_vars (* FIXME... *)
   23.65 +
   23.66 +    in
   23.67 +      (intrs, (Rdef, elim, induct, lthy))
   23.68 +    end
   23.69 +    
   23.70 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Tools/Function/lexicographic_order.ML	Tue Jun 23 12:09:30 2009 +0200
    24.3 @@ -0,0 +1,230 @@
    24.4 +(*  Title:       HOL/Tools/Function/lexicographic_order.ML
    24.5 +    Author:      Lukas Bulwahn, TU Muenchen
    24.6 +
    24.7 +Method for termination proofs with lexicographic orderings.
    24.8 +*)
    24.9 +
   24.10 +signature LEXICOGRAPHIC_ORDER =
   24.11 +sig
   24.12 +  val lex_order_tac : Proof.context -> tactic -> tactic
   24.13 +  val lexicographic_order_tac : Proof.context -> tactic
   24.14 +  val lexicographic_order : Proof.context -> Proof.method
   24.15 +
   24.16 +  val setup: theory -> theory
   24.17 +end
   24.18 +
   24.19 +structure LexicographicOrder : LEXICOGRAPHIC_ORDER =
   24.20 +struct
   24.21 +
   24.22 +open FundefLib
   24.23 +
   24.24 +(** General stuff **)
   24.25 +
   24.26 +fun mk_measures domT mfuns =
   24.27 +    let 
   24.28 +        val relT = HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT))
   24.29 +        val mlexT = (domT --> HOLogic.natT) --> relT --> relT
   24.30 +        fun mk_ms [] = Const (@{const_name Set.empty}, relT)
   24.31 +          | mk_ms (f::fs) = 
   24.32 +            Const (@{const_name "mlex_prod"}, mlexT) $ f $ mk_ms fs
   24.33 +    in
   24.34 +        mk_ms mfuns
   24.35 +    end
   24.36 +
   24.37 +fun del_index n [] = []
   24.38 +  | del_index n (x :: xs) =
   24.39 +    if n > 0 then x :: del_index (n - 1) xs else xs
   24.40 +
   24.41 +fun transpose ([]::_) = []
   24.42 +  | transpose xss = map hd xss :: transpose (map tl xss)
   24.43 +
   24.44 +(** Matrix cell datatype **)
   24.45 +
   24.46 +datatype cell = Less of thm| LessEq of (thm * thm) | None of (thm * thm) | False of thm;
   24.47 +
   24.48 +fun is_Less (Less _) = true
   24.49 +  | is_Less _ = false
   24.50 +
   24.51 +fun is_LessEq (LessEq _) = true
   24.52 +  | is_LessEq _ = false
   24.53 +
   24.54 +fun pr_cell (Less _ ) = " < "
   24.55 +  | pr_cell (LessEq _) = " <="
   24.56 +  | pr_cell (None _) = " ? "
   24.57 +  | pr_cell (False _) = " F "
   24.58 +
   24.59 +
   24.60 +(** Proof attempts to build the matrix **)
   24.61 +
   24.62 +fun dest_term (t : term) =
   24.63 +    let
   24.64 +      val (vars, prop) = FundefLib.dest_all_all t
   24.65 +      val (prems, concl) = Logic.strip_horn prop
   24.66 +      val (lhs, rhs) = concl
   24.67 +                         |> HOLogic.dest_Trueprop
   24.68 +                         |> HOLogic.dest_mem |> fst
   24.69 +                         |> HOLogic.dest_prod
   24.70 +    in
   24.71 +      (vars, prems, lhs, rhs)
   24.72 +    end
   24.73 +
   24.74 +fun mk_goal (vars, prems, lhs, rhs) rel =
   24.75 +    let
   24.76 +      val concl = HOLogic.mk_binrel rel (lhs, rhs) |> HOLogic.mk_Trueprop
   24.77 +    in
   24.78 +      fold_rev Logic.all vars (Logic.list_implies (prems, concl))
   24.79 +    end
   24.80 +
   24.81 +fun prove thy solve_tac t =
   24.82 +    cterm_of thy t |> Goal.init
   24.83 +    |> SINGLE solve_tac |> the
   24.84 +
   24.85 +fun mk_cell (thy : theory) solve_tac (vars, prems, lhs, rhs) mfun =
   24.86 +    let
   24.87 +      val goals = cterm_of thy o mk_goal (vars, prems, mfun $ lhs, mfun $ rhs)
   24.88 +    in
   24.89 +      case try_proof (goals @{const_name HOL.less}) solve_tac of
   24.90 +        Solved thm => Less thm
   24.91 +      | Stuck thm => 
   24.92 +        (case try_proof (goals @{const_name HOL.less_eq}) solve_tac of
   24.93 +           Solved thm2 => LessEq (thm2, thm)
   24.94 +         | Stuck thm2 => 
   24.95 +           if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const] then False thm2
   24.96 +           else None (thm2, thm)
   24.97 +         | _ => raise Match) (* FIXME *)
   24.98 +      | _ => raise Match
   24.99 +    end
  24.100 +
  24.101 +
  24.102 +(** Search algorithms **)
  24.103 +
  24.104 +fun check_col ls = forall (fn c => is_Less c orelse is_LessEq c) ls andalso not (forall (is_LessEq) ls)
  24.105 +
  24.106 +fun transform_table table col = table |> filter_out (fn x => is_Less (nth x col)) |> map (del_index col)
  24.107 +
  24.108 +fun transform_order col order = map (fn x => if x >= col then x + 1 else x) order
  24.109 +
  24.110 +(* simple depth-first search algorithm for the table *)
  24.111 +fun search_table table =
  24.112 +    case table of
  24.113 +      [] => SOME []
  24.114 +    | _ =>
  24.115 +      let
  24.116 +        val col = find_index (check_col) (transpose table)
  24.117 +      in case col of
  24.118 +           ~1 => NONE
  24.119 +         | _ =>
  24.120 +           let
  24.121 +             val order_opt = (table, col) |-> transform_table |> search_table
  24.122 +           in case order_opt of
  24.123 +                NONE => NONE
  24.124 +              | SOME order =>SOME (col :: transform_order col order)
  24.125 +           end
  24.126 +      end
  24.127 +
  24.128 +(** Proof Reconstruction **)
  24.129 +
  24.130 +(* prove row :: cell list -> tactic *)
  24.131 +fun prove_row (Less less_thm :: _) =
  24.132 +    (rtac @{thm "mlex_less"} 1)
  24.133 +    THEN PRIMITIVE (Thm.elim_implies less_thm)
  24.134 +  | prove_row (LessEq (lesseq_thm, _) :: tail) =
  24.135 +    (rtac @{thm "mlex_leq"} 1)
  24.136 +    THEN PRIMITIVE (Thm.elim_implies lesseq_thm)
  24.137 +    THEN prove_row tail
  24.138 +  | prove_row _ = sys_error "lexicographic_order"
  24.139 +
  24.140 +
  24.141 +(** Error reporting **)
  24.142 +
  24.143 +fun pr_table table = writeln (cat_lines (map (fn r => concat (map pr_cell r)) table))
  24.144 +
  24.145 +fun pr_goals ctxt st =
  24.146 +    Display.pretty_goals_aux (Syntax.pp ctxt) Markup.none (true, false) (Thm.nprems_of st) st
  24.147 +     |> Pretty.chunks
  24.148 +     |> Pretty.string_of
  24.149 +
  24.150 +fun row_index i = chr (i + 97)
  24.151 +fun col_index j = string_of_int (j + 1)
  24.152 +
  24.153 +fun pr_unprovable_cell _ ((i,j), Less _) = ""
  24.154 +  | pr_unprovable_cell ctxt ((i,j), LessEq (_, st)) =
  24.155 +      "(" ^ row_index i ^ ", " ^ col_index j ^ ", <):\n" ^ pr_goals ctxt st
  24.156 +  | pr_unprovable_cell ctxt ((i,j), None (st_leq, st_less)) =
  24.157 +      "(" ^ row_index i ^ ", " ^ col_index j ^ ", <):\n" ^ pr_goals ctxt st_less
  24.158 +      ^ "\n(" ^ row_index i ^ ", " ^ col_index j ^ ", <=):\n" ^ pr_goals ctxt st_leq
  24.159 +  | pr_unprovable_cell ctxt ((i,j), False st) =
  24.160 +      "(" ^ row_index i ^ ", " ^ col_index j ^ ", <):\n" ^ pr_goals ctxt st
  24.161 +
  24.162 +fun pr_unprovable_subgoals ctxt table =
  24.163 +    table
  24.164 +     |> map_index (fn (i,cs) => map_index (fn (j,x) => ((i,j), x)) cs)
  24.165 +     |> flat
  24.166 +     |> map (pr_unprovable_cell ctxt)
  24.167 +
  24.168 +fun no_order_msg ctxt table tl measure_funs =
  24.169 +    let
  24.170 +      val prterm = Syntax.string_of_term ctxt
  24.171 +      fun pr_fun t i = string_of_int i ^ ") " ^ prterm t
  24.172 +
  24.173 +      fun pr_goal t i =
  24.174 +          let
  24.175 +            val (_, _, lhs, rhs) = dest_term t
  24.176 +          in (* also show prems? *)
  24.177 +               i ^ ") " ^ prterm rhs ^ " ~> " ^ prterm lhs
  24.178 +          end
  24.179 +
  24.180 +      val gc = map (fn i => chr (i + 96)) (1 upto length table)
  24.181 +      val mc = 1 upto length measure_funs
  24.182 +      val tstr = "Result matrix:" ::  ("   " ^ concat (map (enclose " " " " o string_of_int) mc))
  24.183 +                 :: map2 (fn r => fn i => i ^ ": " ^ concat (map pr_cell r)) table gc
  24.184 +      val gstr = "Calls:" :: map2 (prefix "  " oo pr_goal) tl gc
  24.185 +      val mstr = "Measures:" :: map2 (prefix "  " oo pr_fun) measure_funs mc
  24.186 +      val ustr = "Unfinished subgoals:" :: pr_unprovable_subgoals ctxt table
  24.187 +    in
  24.188 +      cat_lines (ustr @ gstr @ mstr @ tstr @ ["", "Could not find lexicographic termination order."])
  24.189 +    end
  24.190 +
  24.191 +(** The Main Function **)
  24.192 +
  24.193 +fun lex_order_tac ctxt solve_tac (st: thm) =
  24.194 +    let
  24.195 +      val thy = ProofContext.theory_of ctxt
  24.196 +      val ((trueprop $ (wf $ rel)) :: tl) = prems_of st
  24.197 +
  24.198 +      val (domT, _) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of rel))
  24.199 +
  24.200 +      val measure_funs = MeasureFunctions.get_measure_functions ctxt domT (* 1: generate measures *)
  24.201 +
  24.202 +      (* 2: create table *)
  24.203 +      val table = map (fn t => map (mk_cell thy solve_tac (dest_term t)) measure_funs) tl
  24.204 +
  24.205 +      val order = the (search_table table) (* 3: search table *)
  24.206 +          handle Option => error (no_order_msg ctxt table tl measure_funs)
  24.207 +
  24.208 +      val clean_table = map (fn x => map (nth x) order) table
  24.209 +
  24.210 +      val relation = mk_measures domT (map (nth measure_funs) order)
  24.211 +      val _ = writeln ("Found termination order: " ^ quote (Syntax.string_of_term ctxt relation))
  24.212 +
  24.213 +    in (* 4: proof reconstruction *)
  24.214 +      st |> (PRIMITIVE (cterm_instantiate [(cterm_of thy rel, cterm_of thy relation)])
  24.215 +              THEN (REPEAT (rtac @{thm "wf_mlex"} 1))
  24.216 +              THEN (rtac @{thm "wf_empty"} 1)
  24.217 +              THEN EVERY (map prove_row clean_table))
  24.218 +    end
  24.219 +
  24.220 +fun lexicographic_order_tac ctxt =
  24.221 +  TRY (FundefCommon.apply_termination_rule ctxt 1)
  24.222 +  THEN lex_order_tac ctxt (auto_tac (local_clasimpset_of ctxt addsimps2 FundefCommon.TerminationSimps.get ctxt))
  24.223 +
  24.224 +val lexicographic_order = SIMPLE_METHOD o lexicographic_order_tac
  24.225 +
  24.226 +val setup =
  24.227 +  Method.setup @{binding lexicographic_order}
  24.228 +    (Method.sections clasimp_modifiers >> (K lexicographic_order))
  24.229 +    "termination prover for lexicographic orderings"
  24.230 +  #> Context.theory_map (FundefCommon.set_termination_prover lexicographic_order)
  24.231 +
  24.232 +end;
  24.233 +
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/Tools/Function/measure_functions.ML	Tue Jun 23 12:09:30 2009 +0200
    25.3 @@ -0,0 +1,58 @@
    25.4 +(*  Title:       HOL/Tools/Function/measure_functions.ML
    25.5 +    Author:      Alexander Krauss, TU Muenchen
    25.6 +
    25.7 +Measure functions, generated heuristically
    25.8 +*)
    25.9 +
   25.10 +signature MEASURE_FUNCTIONS =
   25.11 +sig
   25.12 +
   25.13 +  val get_measure_functions : Proof.context -> typ -> term list
   25.14 +  val setup : theory -> theory                                                      
   25.15 +
   25.16 +end
   25.17 +
   25.18 +structure MeasureFunctions : MEASURE_FUNCTIONS = 
   25.19 +struct 
   25.20 +
   25.21 +(** User-declared size functions **)
   25.22 +structure MeasureHeuristicRules = NamedThmsFun(
   25.23 +  val name = "measure_function" 
   25.24 +  val description = "Rules that guide the heuristic generation of measure functions"
   25.25 +);
   25.26 +
   25.27 +fun mk_is_measures t = Const (@{const_name "is_measure"}, fastype_of t --> HOLogic.boolT) $ t
   25.28 +
   25.29 +fun find_measures ctxt T =
   25.30 +  DEPTH_SOLVE (resolve_tac (MeasureHeuristicRules.get ctxt) 1) 
   25.31 +    (HOLogic.mk_Trueprop (mk_is_measures (Var (("f",0), T --> HOLogic.natT)))
   25.32 +      |> cterm_of (ProofContext.theory_of ctxt) |> Goal.init)
   25.33 +  |> Seq.map (prop_of #> (fn _ $ (_ $ (_ $ f)) => f))
   25.34 +  |> Seq.list_of
   25.35 +
   25.36 +
   25.37 +(** Generating Measure Functions **)
   25.38 +
   25.39 +fun constant_0 T = Abs ("x", T, HOLogic.zero)
   25.40 +fun constant_1 T = Abs ("x", T, HOLogic.Suc_zero)
   25.41 +
   25.42 +fun mk_funorder_funs (Type ("+", [fT, sT])) =
   25.43 +      map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT m (constant_0 sT)) (mk_funorder_funs fT)
   25.44 +    @ map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT (constant_0 fT) m) (mk_funorder_funs sT)
   25.45 +  | mk_funorder_funs T = [ constant_1 T ]
   25.46 +
   25.47 +fun mk_ext_base_funs ctxt (Type("+", [fT, sT])) =
   25.48 +      map_product (SumTree.mk_sumcase fT sT HOLogic.natT)
   25.49 +                  (mk_ext_base_funs ctxt fT) (mk_ext_base_funs ctxt sT)
   25.50 +  | mk_ext_base_funs ctxt T = find_measures ctxt T
   25.51 +
   25.52 +fun mk_all_measure_funs ctxt (T as Type ("+", _)) =
   25.53 +    mk_ext_base_funs ctxt T @ mk_funorder_funs T
   25.54 +  | mk_all_measure_funs ctxt T = find_measures ctxt T
   25.55 +
   25.56 +val get_measure_functions = mk_all_measure_funs
   25.57 +
   25.58 +val setup = MeasureHeuristicRules.setup
   25.59 +
   25.60 +end
   25.61 +
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/Tools/Function/mutual.ML	Tue Jun 23 12:09:30 2009 +0200
    26.3 @@ -0,0 +1,314 @@
    26.4 +(*  Title:      HOL/Tools/Function/mutual.ML
    26.5 +    Author:     Alexander Krauss, TU Muenchen
    26.6 +
    26.7 +A package for general recursive function definitions.
    26.8 +Tools for mutual recursive definitions.
    26.9 +*)
   26.10 +
   26.11 +signature FUNDEF_MUTUAL =
   26.12 +sig
   26.13 +
   26.14 +  val prepare_fundef_mutual : FundefCommon.fundef_config
   26.15 +                              -> string (* defname *)
   26.16 +                              -> ((string * typ) * mixfix) list
   26.17 +                              -> term list
   26.18 +                              -> local_theory
   26.19 +                              -> ((thm (* goalstate *)
   26.20 +                                   * (thm -> FundefCommon.fundef_result) (* proof continuation *)
   26.21 +                                  ) * local_theory)
   26.22 +
   26.23 +end
   26.24 +
   26.25 +
   26.26 +structure FundefMutual: FUNDEF_MUTUAL =
   26.27 +struct
   26.28 +
   26.29 +open FundefLib
   26.30 +open FundefCommon
   26.31 +
   26.32 +
   26.33 +
   26.34 +
   26.35 +type qgar = string * (string * typ) list * term list * term list * term
   26.36 +
   26.37 +fun name_of_fqgar ((f, _, _, _, _): qgar) = f
   26.38 +
   26.39 +datatype mutual_part =
   26.40 +  MutualPart of 
   26.41 +   {
   26.42 +    i : int,
   26.43 +    i' : int,
   26.44 +    fvar : string * typ,
   26.45 +    cargTs: typ list,
   26.46 +    f_def: term,
   26.47 +
   26.48 +    f: term option,
   26.49 +    f_defthm : thm option
   26.50 +   }
   26.51 +   
   26.52 +
   26.53 +datatype mutual_info =
   26.54 +  Mutual of 
   26.55 +   { 
   26.56 +    n : int,
   26.57 +    n' : int,
   26.58 +    fsum_var : string * typ,
   26.59 +
   26.60 +    ST: typ,
   26.61 +    RST: typ,
   26.62 +
   26.63 +    parts: mutual_part list,
   26.64 +    fqgars: qgar list,
   26.65 +    qglrs: ((string * typ) list * term list * term * term) list,
   26.66 +
   26.67 +    fsum : term option
   26.68 +   }
   26.69 +
   26.70 +fun mutual_induct_Pnames n =
   26.71 +    if n < 5 then fst (chop n ["P","Q","R","S"])
   26.72 +    else map (fn i => "P" ^ string_of_int i) (1 upto n)
   26.73 +
   26.74 +fun get_part fname =
   26.75 +    the o find_first (fn (MutualPart {fvar=(n,_), ...}) => n = fname)
   26.76 +                     
   26.77 +(* FIXME *)
   26.78 +fun mk_prod_abs e (t1, t2) =
   26.79 +    let
   26.80 +      val bTs = rev (map snd e)
   26.81 +      val T1 = fastype_of1 (bTs, t1)
   26.82 +      val T2 = fastype_of1 (bTs, t2)
   26.83 +    in
   26.84 +      HOLogic.pair_const T1 T2 $ t1 $ t2
   26.85 +    end;
   26.86 +
   26.87 +
   26.88 +fun analyze_eqs ctxt defname fs eqs =
   26.89 +    let
   26.90 +      val num = length fs
   26.91 +        val fnames = map fst fs
   26.92 +        val fqgars = map (split_def ctxt) eqs
   26.93 +        val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
   26.94 +                       |> AList.lookup (op =) #> the
   26.95 +
   26.96 +        fun curried_types (fname, fT) =
   26.97 +            let
   26.98 +              val (caTs, uaTs) = chop (arity_of fname) (binder_types fT)
   26.99 +            in
  26.100 +                (caTs, uaTs ---> body_type fT)
  26.101 +            end
  26.102 +
  26.103 +        val (caTss, resultTs) = split_list (map curried_types fs)
  26.104 +        val argTs = map (foldr1 HOLogic.mk_prodT) caTss
  26.105 +
  26.106 +        val dresultTs = distinct (Type.eq_type Vartab.empty) resultTs
  26.107 +        val n' = length dresultTs
  26.108 +
  26.109 +        val RST = BalancedTree.make (uncurry SumTree.mk_sumT) dresultTs
  26.110 +        val ST = BalancedTree.make (uncurry SumTree.mk_sumT) argTs
  26.111 +
  26.112 +        val fsum_type = ST --> RST
  26.113 +
  26.114 +        val ([fsum_var_name], _) = Variable.add_fixes [ defname ^ "_sum" ] ctxt
  26.115 +        val fsum_var = (fsum_var_name, fsum_type)
  26.116 +
  26.117 +        fun define (fvar as (n, T)) caTs resultT i =
  26.118 +            let
  26.119 +                val vars = map_index (fn (j,T) => Free ("x" ^ string_of_int j, T)) caTs (* FIXME: Bind xs properly *)
  26.120 +                val i' = find_index (fn Ta => Type.eq_type Vartab.empty (Ta, resultT)) dresultTs + 1 
  26.121 +
  26.122 +                val f_exp = SumTree.mk_proj RST n' i' (Free fsum_var $ SumTree.mk_inj ST num i (foldr1 HOLogic.mk_prod vars))
  26.123 +                val def = Term.abstract_over (Free fsum_var, fold_rev lambda vars f_exp)
  26.124 +
  26.125 +                val rew = (n, fold_rev lambda vars f_exp)
  26.126 +            in
  26.127 +                (MutualPart {i=i, i'=i', fvar=fvar,cargTs=caTs,f_def=def,f=NONE,f_defthm=NONE}, rew)
  26.128 +            end
  26.129 +            
  26.130 +        val (parts, rews) = split_list (map4 define fs caTss resultTs (1 upto num))
  26.131 +
  26.132 +        fun convert_eqs (f, qs, gs, args, rhs) =
  26.133 +            let
  26.134 +              val MutualPart {i, i', ...} = get_part f parts
  26.135 +            in
  26.136 +              (qs, gs, SumTree.mk_inj ST num i (foldr1 (mk_prod_abs qs) args),
  26.137 +               SumTree.mk_inj RST n' i' (replace_frees rews rhs)
  26.138 +                               |> Envir.beta_norm)
  26.139 +            end
  26.140 +
  26.141 +        val qglrs = map convert_eqs fqgars
  26.142 +    in
  26.143 +        Mutual {n=num, n'=n', fsum_var=fsum_var, ST=ST, RST=RST, 
  26.144 +                parts=parts, fqgars=fqgars, qglrs=qglrs, fsum=NONE}
  26.145 +    end
  26.146 +
  26.147 +
  26.148 +
  26.149 +
  26.150 +fun define_projections fixes mutual fsum lthy =
  26.151 +    let
  26.152 +      fun def ((MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs, f_def, ...}), (_, mixfix)) lthy =
  26.153 +          let
  26.154 +            val ((f, (_, f_defthm)), lthy') =
  26.155 +              LocalTheory.define Thm.internalK ((Binding.name fname, mixfix),
  26.156 +                                            ((Binding.name (fname ^ "_def"), []), Term.subst_bound (fsum, f_def)))
  26.157 +                              lthy
  26.158 +          in
  26.159 +            (MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs=cargTs, f_def=f_def,
  26.160 +                         f=SOME f, f_defthm=SOME f_defthm },
  26.161 +             lthy')
  26.162 +          end
  26.163 +          
  26.164 +      val Mutual { n, n', fsum_var, ST, RST, parts, fqgars, qglrs, ... } = mutual
  26.165 +      val (parts', lthy') = fold_map def (parts ~~ fixes) lthy
<