avoid nested 'Tools' directories
authorblanchet
Mon Jan 20 18:24:56 2014 +0100 (2014-01-20)
changeset 550603105434fb02f
parent 55059 ef2e0fb783c6
child 55061 a0adf838e2d1
avoid nested 'Tools' directories
src/HOL/Tools/BNF/Tools/bnf_comp.ML
src/HOL/Tools/BNF/Tools/bnf_comp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_decl.ML
src/HOL/Tools/BNF/Tools/bnf_def.ML
src/HOL/Tools/BNF/Tools/bnf_def_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_fp_n2m_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_fp_rec_sugar_util.ML
src/HOL/Tools/BNF/Tools/bnf_fp_util.ML
src/HOL/Tools/BNF/Tools/bnf_gfp.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_rec_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_gfp_util.ML
src/HOL/Tools/BNF/Tools/bnf_lfp.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_compat.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_rec_sugar.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_lfp_util.ML
src/HOL/Tools/BNF/Tools/bnf_tactics.ML
src/HOL/Tools/BNF/Tools/bnf_util.ML
src/HOL/Tools/BNF/bnf_comp.ML
src/HOL/Tools/BNF/bnf_comp_tactics.ML
src/HOL/Tools/BNF/bnf_def.ML
src/HOL/Tools/BNF/bnf_def_tactics.ML
src/HOL/Tools/BNF/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/bnf_fp_def_sugar_tactics.ML
src/HOL/Tools/BNF/bnf_fp_n2m.ML
src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML
src/HOL/Tools/BNF/bnf_fp_n2m_tactics.ML
src/HOL/Tools/BNF/bnf_fp_rec_sugar_util.ML
src/HOL/Tools/BNF/bnf_fp_util.ML
src/HOL/Tools/BNF/bnf_gfp.ML
src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML
src/HOL/Tools/BNF/bnf_gfp_rec_sugar_tactics.ML
src/HOL/Tools/BNF/bnf_gfp_tactics.ML
src/HOL/Tools/BNF/bnf_gfp_util.ML
src/HOL/Tools/BNF/bnf_lfp.ML
src/HOL/Tools/BNF/bnf_lfp_compat.ML
src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML
src/HOL/Tools/BNF/bnf_lfp_tactics.ML
src/HOL/Tools/BNF/bnf_lfp_util.ML
src/HOL/Tools/BNF/bnf_tactics.ML
src/HOL/Tools/BNF/bnf_util.ML
     1.1 --- a/src/HOL/Tools/BNF/Tools/bnf_comp.ML	Mon Jan 20 18:24:56 2014 +0100
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,704 +0,0 @@
     1.4 -(*  Title:      HOL/BNF/Tools/bnf_comp.ML
     1.5 -    Author:     Dmitriy Traytel, TU Muenchen
     1.6 -    Author:     Jasmin Blanchette, TU Muenchen
     1.7 -    Copyright   2012
     1.8 -
     1.9 -Composition of bounded natural functors.
    1.10 -*)
    1.11 -
    1.12 -signature BNF_COMP =
    1.13 -sig
    1.14 -  val ID_bnf: BNF_Def.bnf
    1.15 -  val DEADID_bnf: BNF_Def.bnf
    1.16 -
    1.17 -  type unfold_set
    1.18 -  val empty_unfolds: unfold_set
    1.19 -
    1.20 -  exception BAD_DEAD of typ * typ
    1.21 -
    1.22 -  val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
    1.23 -    ((string * sort) list list -> (string * sort) list) -> (string * sort) list -> typ ->
    1.24 -    unfold_set * Proof.context ->
    1.25 -    (BNF_Def.bnf * (typ list * typ list)) * (unfold_set * Proof.context)
    1.26 -  val default_comp_sort: (string * sort) list list -> (string * sort) list
    1.27 -  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
    1.28 -    (''a list list -> ''a list) -> BNF_Def.bnf list -> unfold_set -> Proof.context ->
    1.29 -    (int list list * ''a list) * (BNF_Def.bnf list * (unfold_set * Proof.context))
    1.30 -  val seal_bnf: (binding -> binding) -> unfold_set -> binding -> typ list -> BNF_Def.bnf ->
    1.31 -    Proof.context -> (BNF_Def.bnf * typ list) * local_theory
    1.32 -end;
    1.33 -
    1.34 -structure BNF_Comp : BNF_COMP =
    1.35 -struct
    1.36 -
    1.37 -open BNF_Def
    1.38 -open BNF_Util
    1.39 -open BNF_Tactics
    1.40 -open BNF_Comp_Tactics
    1.41 -
    1.42 -val ID_bnf = the (bnf_of @{context} "Basic_BNFs.ID");
    1.43 -val DEADID_bnf = the (bnf_of @{context} "Basic_BNFs.DEADID");
    1.44 -
    1.45 -(* TODO: Replace by "BNF_Defs.defs list" *)
    1.46 -type unfold_set = {
    1.47 -  map_unfolds: thm list,
    1.48 -  set_unfoldss: thm list list,
    1.49 -  rel_unfolds: thm list
    1.50 -};
    1.51 -
    1.52 -val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = []};
    1.53 -
    1.54 -fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
    1.55 -fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
    1.56 -
    1.57 -fun add_to_unfolds map sets rel
    1.58 -  {map_unfolds, set_unfoldss, rel_unfolds} =
    1.59 -  {map_unfolds = add_to_thms map_unfolds map,
    1.60 -    set_unfoldss = adds_to_thms set_unfoldss sets,
    1.61 -    rel_unfolds = add_to_thms rel_unfolds rel};
    1.62 -
    1.63 -fun add_bnf_to_unfolds bnf =
    1.64 -  add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf);
    1.65 -
    1.66 -val bdTN = "bdT";
    1.67 -
    1.68 -fun mk_killN n = "_kill" ^ string_of_int n;
    1.69 -fun mk_liftN n = "_lift" ^ string_of_int n;
    1.70 -fun mk_permuteN src dest =
    1.71 -  "_permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest);
    1.72 -
    1.73 -(*copied from Envir.expand_term_free*)
    1.74 -fun expand_term_const defs =
    1.75 -  let
    1.76 -    val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
    1.77 -    val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
    1.78 -  in Envir.expand_term get end;
    1.79 -
    1.80 -fun clean_compose_bnf const_policy qualify b outer inners (unfold_set, lthy) =
    1.81 -  let
    1.82 -    val olive = live_of_bnf outer;
    1.83 -    val onwits = nwits_of_bnf outer;
    1.84 -    val odead = dead_of_bnf outer;
    1.85 -    val inner = hd inners;
    1.86 -    val ilive = live_of_bnf inner;
    1.87 -    val ideads = map dead_of_bnf inners;
    1.88 -    val inwitss = map nwits_of_bnf inners;
    1.89 -
    1.90 -    (* TODO: check olive = length inners > 0,
    1.91 -                   forall inner from inners. ilive = live,
    1.92 -                   forall inner from inners. idead = dead  *)
    1.93 -
    1.94 -    val (oDs, lthy1) = apfst (map TFree)
    1.95 -      (Variable.invent_types (replicate odead HOLogic.typeS) lthy);
    1.96 -    val (Dss, lthy2) = apfst (map (map TFree))
    1.97 -        (fold_map Variable.invent_types (map (fn n => replicate n HOLogic.typeS) ideads) lthy1);
    1.98 -    val (Ass, lthy3) = apfst (replicate ilive o map TFree)
    1.99 -      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy2);
   1.100 -    val As = if ilive > 0 then hd Ass else [];
   1.101 -    val Ass_repl = replicate olive As;
   1.102 -    val (Bs, _(*lthy4*)) = apfst (map TFree)
   1.103 -      (Variable.invent_types (replicate ilive HOLogic.typeS) lthy3);
   1.104 -    val Bss_repl = replicate olive Bs;
   1.105 -
   1.106 -    val ((((fs', Qs'), Asets), xs), _(*names_lthy*)) = lthy
   1.107 -      |> apfst snd o mk_Frees' "f" (map2 (curry op -->) As Bs)
   1.108 -      ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T As Bs)
   1.109 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As)
   1.110 -      ||>> mk_Frees "x" As;
   1.111 -
   1.112 -    val CAs = map3 mk_T_of_bnf Dss Ass_repl inners;
   1.113 -    val CCA = mk_T_of_bnf oDs CAs outer;
   1.114 -    val CBs = map3 mk_T_of_bnf Dss Bss_repl inners;
   1.115 -    val outer_sets = mk_sets_of_bnf (replicate olive oDs) (replicate olive CAs) outer;
   1.116 -    val inner_setss = map3 mk_sets_of_bnf (map (replicate ilive) Dss) (replicate olive Ass) inners;
   1.117 -    val inner_bds = map3 mk_bd_of_bnf Dss Ass_repl inners;
   1.118 -    val outer_bd = mk_bd_of_bnf oDs CAs outer;
   1.119 -
   1.120 -    (*%f1 ... fn. outer.map (inner_1.map f1 ... fn) ... (inner_m.map f1 ... fn)*)
   1.121 -    val mapx = fold_rev Term.abs fs'
   1.122 -      (Term.list_comb (mk_map_of_bnf oDs CAs CBs outer,
   1.123 -        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   1.124 -          mk_map_of_bnf Ds As Bs) Dss inners));
   1.125 -    (*%Q1 ... Qn. outer.rel (inner_1.rel Q1 ... Qn) ... (inner_m.rel Q1 ... Qn)*)
   1.126 -    val rel = fold_rev Term.abs Qs'
   1.127 -      (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
   1.128 -        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   1.129 -          mk_rel_of_bnf Ds As Bs) Dss inners));
   1.130 -
   1.131 -    (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
   1.132 -    (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
   1.133 -    fun mk_set i =
   1.134 -      let
   1.135 -        val (setTs, T) = `(replicate olive o HOLogic.mk_setT) (nth As i);
   1.136 -        val outer_set = mk_collect
   1.137 -          (mk_sets_of_bnf (replicate olive oDs) (replicate olive setTs) outer)
   1.138 -          (mk_T_of_bnf oDs setTs outer --> HOLogic.mk_setT T);
   1.139 -        val inner_sets = map (fn sets => nth sets i) inner_setss;
   1.140 -        val outer_map = mk_map_of_bnf oDs CAs setTs outer;
   1.141 -        val map_inner_sets = Term.list_comb (outer_map, inner_sets);
   1.142 -        val collect_image = mk_collect
   1.143 -          (map2 (fn f => fn set => HOLogic.mk_comp (mk_image f, set)) inner_sets outer_sets)
   1.144 -          (CCA --> HOLogic.mk_setT T);
   1.145 -      in
   1.146 -        (Library.foldl1 HOLogic.mk_comp [mk_Union T, outer_set, map_inner_sets],
   1.147 -        HOLogic.mk_comp (mk_Union T, collect_image))
   1.148 -      end;
   1.149 -
   1.150 -    val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
   1.151 -
   1.152 -    (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
   1.153 -    val bd = mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd;
   1.154 -
   1.155 -    fun map_id0_tac _ =
   1.156 -      mk_comp_map_id0_tac (map_id0_of_bnf outer) (map_cong0_of_bnf outer)
   1.157 -        (map map_id0_of_bnf inners);
   1.158 -
   1.159 -    fun map_comp0_tac _ =
   1.160 -      mk_comp_map_comp0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
   1.161 -        (map map_comp0_of_bnf inners);
   1.162 -
   1.163 -    fun mk_single_set_map0_tac i _ =
   1.164 -      mk_comp_set_map0_tac (map_comp0_of_bnf outer) (map_cong0_of_bnf outer)
   1.165 -        (collect_set_map_of_bnf outer)
   1.166 -        (map ((fn thms => nth thms i) o set_map0_of_bnf) inners);
   1.167 -
   1.168 -    val set_map0_tacs = map mk_single_set_map0_tac (0 upto ilive - 1);
   1.169 -
   1.170 -    fun bd_card_order_tac _ =
   1.171 -      mk_comp_bd_card_order_tac (map bd_card_order_of_bnf inners) (bd_card_order_of_bnf outer);
   1.172 -
   1.173 -    fun bd_cinfinite_tac _ =
   1.174 -      mk_comp_bd_cinfinite_tac (bd_cinfinite_of_bnf inner) (bd_cinfinite_of_bnf outer);
   1.175 -
   1.176 -    val set_alt_thms =
   1.177 -      if Config.get lthy quick_and_dirty then
   1.178 -        []
   1.179 -      else
   1.180 -        map (fn goal =>
   1.181 -          Goal.prove_sorry lthy [] [] goal
   1.182 -            (fn {context = ctxt, prems = _} =>
   1.183 -              mk_comp_set_alt_tac ctxt (collect_set_map_of_bnf outer))
   1.184 -          |> Thm.close_derivation)
   1.185 -        (map2 (curry (HOLogic.mk_Trueprop o HOLogic.mk_eq)) sets sets_alt);
   1.186 -
   1.187 -    fun map_cong0_tac _ =
   1.188 -      mk_comp_map_cong0_tac set_alt_thms (map_cong0_of_bnf outer) (map map_cong0_of_bnf inners);
   1.189 -
   1.190 -    val set_bd_tacs =
   1.191 -      if Config.get lthy quick_and_dirty then
   1.192 -        replicate ilive (K all_tac)
   1.193 -      else
   1.194 -        let
   1.195 -          val outer_set_bds = set_bd_of_bnf outer;
   1.196 -          val inner_set_bdss = map set_bd_of_bnf inners;
   1.197 -          val inner_bd_Card_orders = map bd_Card_order_of_bnf inners;
   1.198 -          fun single_set_bd_thm i j =
   1.199 -            @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
   1.200 -              nth outer_set_bds j]
   1.201 -          val single_set_bd_thmss =
   1.202 -            map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
   1.203 -        in
   1.204 -          map2 (fn set_alt => fn single_set_bds => fn {context = ctxt, prems = _} =>
   1.205 -            mk_comp_set_bd_tac ctxt set_alt single_set_bds)
   1.206 -          set_alt_thms single_set_bd_thmss
   1.207 -        end;
   1.208 -
   1.209 -    val in_alt_thm =
   1.210 -      let
   1.211 -        val inx = mk_in Asets sets CCA;
   1.212 -        val in_alt = mk_in (map2 (mk_in Asets) inner_setss CAs) outer_sets CCA;
   1.213 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   1.214 -      in
   1.215 -        Goal.prove_sorry lthy [] [] goal
   1.216 -          (fn {context = ctxt, prems = _} => mk_comp_in_alt_tac ctxt set_alt_thms)
   1.217 -        |> Thm.close_derivation
   1.218 -      end;
   1.219 -
   1.220 -    fun le_rel_OO_tac _ = mk_le_rel_OO_tac (le_rel_OO_of_bnf outer) (rel_mono_of_bnf outer)
   1.221 -      (map le_rel_OO_of_bnf inners);
   1.222 -
   1.223 -    fun rel_OO_Grp_tac _ =
   1.224 -      let
   1.225 -        val outer_rel_Grp = rel_Grp_of_bnf outer RS sym;
   1.226 -        val outer_rel_cong = rel_cong_of_bnf outer;
   1.227 -        val thm =
   1.228 -          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   1.229 -             trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
   1.230 -               [trans OF [outer_rel_Grp RS @{thm arg_cong[of _ _ conversep]},
   1.231 -                 rel_conversep_of_bnf outer RS sym], outer_rel_Grp],
   1.232 -               trans OF [rel_OO_of_bnf outer RS sym, outer_rel_cong OF
   1.233 -                 (map (fn bnf => rel_OO_Grp_of_bnf bnf RS sym) inners)]]] RS sym)
   1.234 -          (*|> unfold_thms lthy (rel_def_of_bnf outer :: map rel_def_of_bnf inners)*);
   1.235 -      in
   1.236 -        rtac thm 1
   1.237 -      end;
   1.238 -
   1.239 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   1.240 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   1.241 -
   1.242 -    val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
   1.243 -
   1.244 -    val inner_witss = map (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)))
   1.245 -      (map3 (fn Ds => fn n => mk_wits_of_bnf (replicate n Ds) (replicate n As))
   1.246 -        Dss inwitss inners);
   1.247 -
   1.248 -    val inner_witsss = map (map (nth inner_witss) o fst) outer_wits;
   1.249 -
   1.250 -    val wits = (inner_witsss, (map (single o snd) outer_wits))
   1.251 -      |-> map2 (fold (map_product (fn iwit => fn owit => owit $ iwit)))
   1.252 -      |> flat
   1.253 -      |> map (`(fn t => Term.add_frees t []))
   1.254 -      |> minimize_wits
   1.255 -      |> map (fn (frees, t) => fold absfree frees t);
   1.256 -
   1.257 -    fun wit_tac {context = ctxt, prems = _} =
   1.258 -      mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_map_of_bnf outer)
   1.259 -        (maps wit_thms_of_bnf inners);
   1.260 -
   1.261 -    val (bnf', lthy') =
   1.262 -      bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
   1.263 -        Binding.empty [] ((((((b, CCA), mapx), sets), bd), wits), SOME rel) lthy;
   1.264 -  in
   1.265 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   1.266 -  end;
   1.267 -
   1.268 -(* Killing live variables *)
   1.269 -
   1.270 -fun kill_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
   1.271 -  let
   1.272 -    val b = Binding.suffix_name (mk_killN n) (name_of_bnf bnf);
   1.273 -    val live = live_of_bnf bnf;
   1.274 -    val dead = dead_of_bnf bnf;
   1.275 -    val nwits = nwits_of_bnf bnf;
   1.276 -
   1.277 -    (* TODO: check 0 < n <= live *)
   1.278 -
   1.279 -    val (Ds, lthy1) = apfst (map TFree)
   1.280 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   1.281 -    val ((killedAs, As), lthy2) = apfst (`(take n) o map TFree)
   1.282 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   1.283 -    val (Bs, _(*lthy3*)) = apfst (append killedAs o map TFree)
   1.284 -      (Variable.invent_types (replicate (live - n) HOLogic.typeS) lthy2);
   1.285 -
   1.286 -    val ((Asets, lives), _(*names_lthy*)) = lthy
   1.287 -      |> mk_Frees "A" (map HOLogic.mk_setT (drop n As))
   1.288 -      ||>> mk_Frees "x" (drop n As);
   1.289 -    val xs = map (fn T => HOLogic.choice_const T $ absdummy T @{term True}) killedAs @ lives;
   1.290 -
   1.291 -    val T = mk_T_of_bnf Ds As bnf;
   1.292 -
   1.293 -    (*bnf.map id ... id*)
   1.294 -    val mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
   1.295 -    (*bnf.rel (op =) ... (op =)*)
   1.296 -    val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
   1.297 -
   1.298 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   1.299 -    val sets = drop n bnf_sets;
   1.300 -
   1.301 -    (*(|UNIV :: A1 set| +c ... +c |UNIV :: An set|) *c bnf.bd*)
   1.302 -    val bnf_bd = mk_bd_of_bnf Ds As bnf;
   1.303 -    val bd = mk_cprod
   1.304 -      (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
   1.305 -
   1.306 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   1.307 -    fun map_comp0_tac {context = ctxt, prems = _} =
   1.308 -      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
   1.309 -      rtac refl 1;
   1.310 -    fun map_cong0_tac {context = ctxt, prems = _} =
   1.311 -      mk_kill_map_cong0_tac ctxt n (live - n) (map_cong0_of_bnf bnf);
   1.312 -    val set_map0_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_map0_of_bnf bnf));
   1.313 -    fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
   1.314 -    fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
   1.315 -    val set_bd_tacs =
   1.316 -      map (fn thm => fn _ => mk_kill_set_bd_tac (bd_Card_order_of_bnf bnf) thm)
   1.317 -        (drop n (set_bd_of_bnf bnf));
   1.318 -
   1.319 -    val in_alt_thm =
   1.320 -      let
   1.321 -        val inx = mk_in Asets sets T;
   1.322 -        val in_alt = mk_in (map HOLogic.mk_UNIV killedAs @ Asets) bnf_sets T;
   1.323 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   1.324 -      in
   1.325 -        Goal.prove_sorry lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
   1.326 -      end;
   1.327 -
   1.328 -    fun le_rel_OO_tac {context = ctxt, prems = _} =
   1.329 -      EVERY' [rtac @{thm ord_le_eq_trans}, rtac (le_rel_OO_of_bnf bnf)] 1 THEN
   1.330 -      unfold_thms_tac ctxt @{thms eq_OO} THEN rtac refl 1;
   1.331 -
   1.332 -    fun rel_OO_Grp_tac _ =
   1.333 -      let
   1.334 -        val rel_Grp = rel_Grp_of_bnf bnf RS sym
   1.335 -        val thm =
   1.336 -          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   1.337 -            trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
   1.338 -              [trans OF [rel_Grp RS @{thm arg_cong[of _ _ conversep]},
   1.339 -                rel_conversep_of_bnf bnf RS sym], rel_Grp],
   1.340 -              trans OF [rel_OO_of_bnf bnf RS sym, rel_cong_of_bnf bnf OF
   1.341 -                (replicate n @{thm trans[OF Grp_UNIV_id[OF refl] eq_alt[symmetric]]} @
   1.342 -                 replicate (live - n) @{thm Grp_fst_snd})]]] RS sym);
   1.343 -      in
   1.344 -        rtac thm 1
   1.345 -      end;
   1.346 -
   1.347 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   1.348 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   1.349 -
   1.350 -    val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
   1.351 -
   1.352 -    val wits = map (fn t => fold absfree (Term.add_frees t []) t)
   1.353 -      (map (fn (I, wit) => Term.list_comb (wit, map (nth xs) I)) bnf_wits);
   1.354 -
   1.355 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   1.356 -
   1.357 -    val (bnf', lthy') =
   1.358 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME (killedAs @ Ds)) Binding.empty
   1.359 -        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   1.360 -  in
   1.361 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   1.362 -  end;
   1.363 -
   1.364 -(* Adding dummy live variables *)
   1.365 -
   1.366 -fun lift_bnf qualify n bnf (unfold_set, lthy) = if n = 0 then (bnf, (unfold_set, lthy)) else
   1.367 -  let
   1.368 -    val b = Binding.suffix_name (mk_liftN n) (name_of_bnf bnf);
   1.369 -    val live = live_of_bnf bnf;
   1.370 -    val dead = dead_of_bnf bnf;
   1.371 -    val nwits = nwits_of_bnf bnf;
   1.372 -
   1.373 -    (* TODO: check 0 < n *)
   1.374 -
   1.375 -    val (Ds, lthy1) = apfst (map TFree)
   1.376 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   1.377 -    val ((newAs, As), lthy2) = apfst (chop n o map TFree)
   1.378 -      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy1);
   1.379 -    val ((newBs, Bs), _(*lthy3*)) = apfst (chop n o map TFree)
   1.380 -      (Variable.invent_types (replicate (n + live) HOLogic.typeS) lthy2);
   1.381 -
   1.382 -    val (Asets, _(*names_lthy*)) = lthy
   1.383 -      |> mk_Frees "A" (map HOLogic.mk_setT (newAs @ As));
   1.384 -
   1.385 -    val T = mk_T_of_bnf Ds As bnf;
   1.386 -
   1.387 -    (*%f1 ... fn. bnf.map*)
   1.388 -    val mapx =
   1.389 -      fold_rev Term.absdummy (map2 (curry op -->) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
   1.390 -    (*%Q1 ... Qn. bnf.rel*)
   1.391 -    val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
   1.392 -
   1.393 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   1.394 -    val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
   1.395 -
   1.396 -    val bd = mk_bd_of_bnf Ds As bnf;
   1.397 -
   1.398 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   1.399 -    fun map_comp0_tac {context = ctxt, prems = _} =
   1.400 -      unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) :: @{thms o_assoc id_o o_id}) THEN
   1.401 -      rtac refl 1;
   1.402 -    fun map_cong0_tac {context = ctxt, prems = _} =
   1.403 -      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   1.404 -    val set_map0_tacs =
   1.405 -      if Config.get lthy quick_and_dirty then
   1.406 -        replicate (n + live) (K all_tac)
   1.407 -      else
   1.408 -        replicate n (K empty_natural_tac) @
   1.409 -        map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf);
   1.410 -    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   1.411 -    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   1.412 -    val set_bd_tacs =
   1.413 -      if Config.get lthy quick_and_dirty then
   1.414 -        replicate (n + live) (K all_tac)
   1.415 -      else
   1.416 -        replicate n (K (mk_lift_set_bd_tac (bd_Card_order_of_bnf bnf))) @
   1.417 -        (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   1.418 -
   1.419 -    val in_alt_thm =
   1.420 -      let
   1.421 -        val inx = mk_in Asets sets T;
   1.422 -        val in_alt = mk_in (drop n Asets) bnf_sets T;
   1.423 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   1.424 -      in
   1.425 -        Goal.prove_sorry lthy [] [] goal (K lift_in_alt_tac) |> Thm.close_derivation
   1.426 -      end;
   1.427 -
   1.428 -    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
   1.429 -
   1.430 -    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
   1.431 -
   1.432 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   1.433 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   1.434 -
   1.435 -    val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   1.436 -
   1.437 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   1.438 -
   1.439 -    val (bnf', lthy') =
   1.440 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   1.441 -        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   1.442 -  in
   1.443 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   1.444 -  end;
   1.445 -
   1.446 -(* Changing the order of live variables *)
   1.447 -
   1.448 -fun permute_bnf qualify src dest bnf (unfold_set, lthy) =
   1.449 -  if src = dest then (bnf, (unfold_set, lthy)) else
   1.450 -  let
   1.451 -    val b = Binding.suffix_name (mk_permuteN src dest) (name_of_bnf bnf);
   1.452 -    val live = live_of_bnf bnf;
   1.453 -    val dead = dead_of_bnf bnf;
   1.454 -    val nwits = nwits_of_bnf bnf;
   1.455 -    fun permute xs = permute_like (op =) src dest xs;
   1.456 -    fun unpermute xs = permute_like (op =) dest src xs;
   1.457 -
   1.458 -    val (Ds, lthy1) = apfst (map TFree)
   1.459 -      (Variable.invent_types (replicate dead HOLogic.typeS) lthy);
   1.460 -    val (As, lthy2) = apfst (map TFree)
   1.461 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   1.462 -    val (Bs, _(*lthy3*)) = apfst (map TFree)
   1.463 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy2);
   1.464 -
   1.465 -    val (Asets, _(*names_lthy*)) = lthy
   1.466 -      |> mk_Frees "A" (map HOLogic.mk_setT (permute As));
   1.467 -
   1.468 -    val T = mk_T_of_bnf Ds As bnf;
   1.469 -
   1.470 -    (*%f(1) ... f(n). bnf.map f\<sigma>(1) ... f\<sigma>(n)*)
   1.471 -    val mapx = fold_rev Term.absdummy (permute (map2 (curry op -->) As Bs))
   1.472 -      (Term.list_comb (mk_map_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
   1.473 -    (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
   1.474 -    val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
   1.475 -      (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
   1.476 -
   1.477 -    val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   1.478 -    val sets = permute bnf_sets;
   1.479 -
   1.480 -    val bd = mk_bd_of_bnf Ds As bnf;
   1.481 -
   1.482 -    fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   1.483 -    fun map_comp0_tac _ = rtac (map_comp0_of_bnf bnf) 1;
   1.484 -    fun map_cong0_tac {context = ctxt, prems = _} =
   1.485 -      rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   1.486 -    val set_map0_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf));
   1.487 -    fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   1.488 -    fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   1.489 -    val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   1.490 -
   1.491 -    val in_alt_thm =
   1.492 -      let
   1.493 -        val inx = mk_in Asets sets T;
   1.494 -        val in_alt = mk_in (unpermute Asets) bnf_sets T;
   1.495 -        val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   1.496 -      in
   1.497 -        Goal.prove_sorry lthy [] [] goal (K (mk_permute_in_alt_tac src dest))
   1.498 -        |> Thm.close_derivation
   1.499 -      end;
   1.500 -
   1.501 -    fun le_rel_OO_tac _ = rtac (le_rel_OO_of_bnf bnf) 1;
   1.502 -
   1.503 -    fun rel_OO_Grp_tac _ = mk_simple_rel_OO_Grp_tac (rel_OO_Grp_of_bnf bnf) in_alt_thm;
   1.504 -
   1.505 -    val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   1.506 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   1.507 -
   1.508 -    val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   1.509 -
   1.510 -    fun wit_tac _ = mk_simple_wit_tac (wit_thms_of_bnf bnf);
   1.511 -
   1.512 -    val (bnf', lthy') =
   1.513 -      bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   1.514 -        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   1.515 -  in
   1.516 -    (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   1.517 -  end;
   1.518 -
   1.519 -(* Composition pipeline *)
   1.520 -
   1.521 -fun permute_and_kill qualify n src dest bnf =
   1.522 -  bnf
   1.523 -  |> permute_bnf qualify src dest
   1.524 -  #> uncurry (kill_bnf qualify n);
   1.525 -
   1.526 -fun lift_and_permute qualify n src dest bnf =
   1.527 -  bnf
   1.528 -  |> lift_bnf qualify n
   1.529 -  #> uncurry (permute_bnf qualify src dest);
   1.530 -
   1.531 -fun normalize_bnfs qualify Ass Ds sort bnfs unfold_set lthy =
   1.532 -  let
   1.533 -    val before_kill_src = map (fn As => 0 upto (length As - 1)) Ass;
   1.534 -    val kill_poss = map (find_indices op = Ds) Ass;
   1.535 -    val live_poss = map2 (subtract op =) kill_poss before_kill_src;
   1.536 -    val before_kill_dest = map2 append kill_poss live_poss;
   1.537 -    val kill_ns = map length kill_poss;
   1.538 -    val (inners', (unfold_set', lthy')) =
   1.539 -      fold_map5 (fn i => permute_and_kill (qualify i))
   1.540 -        (if length bnfs = 1 then [0] else (1 upto length bnfs))
   1.541 -        kill_ns before_kill_src before_kill_dest bnfs (unfold_set, lthy);
   1.542 -
   1.543 -    val Ass' = map2 (map o nth) Ass live_poss;
   1.544 -    val As = sort Ass';
   1.545 -    val after_lift_dest = replicate (length Ass') (0 upto (length As - 1));
   1.546 -    val old_poss = map (map (fn x => find_index (fn y => x = y) As)) Ass';
   1.547 -    val new_poss = map2 (subtract op =) old_poss after_lift_dest;
   1.548 -    val after_lift_src = map2 append new_poss old_poss;
   1.549 -    val lift_ns = map (fn xs => length As - length xs) Ass';
   1.550 -  in
   1.551 -    ((kill_poss, As), fold_map5 (fn i => lift_and_permute (qualify i))
   1.552 -      (if length bnfs = 1 then [0] else (1 upto length bnfs))
   1.553 -      lift_ns after_lift_src after_lift_dest inners' (unfold_set', lthy'))
   1.554 -  end;
   1.555 -
   1.556 -fun default_comp_sort Ass =
   1.557 -  Library.sort (Term_Ord.typ_ord o pairself TFree) (fold (fold (insert (op =))) Ass []);
   1.558 -
   1.559 -fun compose_bnf const_policy qualify sort outer inners oDs Dss tfreess (unfold_set, lthy) =
   1.560 -  let
   1.561 -    val b = name_of_bnf outer;
   1.562 -
   1.563 -    val Ass = map (map Term.dest_TFree) tfreess;
   1.564 -    val Ds = fold (fold Term.add_tfreesT) (oDs :: Dss) [];
   1.565 -
   1.566 -    val ((kill_poss, As), (inners', (unfold_set', lthy'))) =
   1.567 -      normalize_bnfs qualify Ass Ds sort inners unfold_set lthy;
   1.568 -
   1.569 -    val Ds = oDs @ flat (map3 (append oo map o nth) tfreess kill_poss Dss);
   1.570 -    val As = map TFree As;
   1.571 -  in
   1.572 -    apfst (rpair (Ds, As))
   1.573 -      (clean_compose_bnf const_policy (qualify 0) b outer inners' (unfold_set', lthy'))
   1.574 -  end;
   1.575 -
   1.576 -(* Hide the type of the bound (optimization) and unfold the definitions (nicer to the user) *)
   1.577 -
   1.578 -fun seal_bnf qualify (unfold_set : unfold_set) b Ds bnf lthy =
   1.579 -  let
   1.580 -    val live = live_of_bnf bnf;
   1.581 -    val nwits = nwits_of_bnf bnf;
   1.582 -
   1.583 -    val (As, lthy1) = apfst (map TFree)
   1.584 -      (Variable.invent_types (replicate live HOLogic.typeS) (fold Variable.declare_typ Ds lthy));
   1.585 -    val (Bs, _) = apfst (map TFree)
   1.586 -      (Variable.invent_types (replicate live HOLogic.typeS) lthy1);
   1.587 -
   1.588 -    val map_unfolds = #map_unfolds unfold_set;
   1.589 -    val set_unfoldss = #set_unfoldss unfold_set;
   1.590 -    val rel_unfolds = #rel_unfolds unfold_set;
   1.591 -
   1.592 -    val expand_maps =
   1.593 -      fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) map_unfolds);
   1.594 -    val expand_sets =
   1.595 -      fold expand_term_const (map (map (Logic.dest_equals o Thm.prop_of)) set_unfoldss);
   1.596 -    val expand_rels =
   1.597 -      fold expand_term_const (map (single o Logic.dest_equals o Thm.prop_of) rel_unfolds);
   1.598 -    fun unfold_maps ctxt = fold (unfold_thms ctxt o single) map_unfolds;
   1.599 -    fun unfold_sets ctxt = fold (unfold_thms ctxt) set_unfoldss;
   1.600 -    fun unfold_rels ctxt = unfold_thms ctxt rel_unfolds;
   1.601 -    fun unfold_all ctxt = unfold_sets ctxt o unfold_maps ctxt o unfold_rels ctxt;
   1.602 -    val bnf_map = expand_maps (mk_map_of_bnf Ds As Bs bnf);
   1.603 -    val bnf_sets = map (expand_maps o expand_sets)
   1.604 -      (mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf);
   1.605 -    val bnf_bd = mk_bd_of_bnf Ds As bnf;
   1.606 -    val bnf_rel = expand_rels (mk_rel_of_bnf Ds As Bs bnf);
   1.607 -    val T = mk_T_of_bnf Ds As bnf;
   1.608 -
   1.609 -    (*bd should only depend on dead type variables!*)
   1.610 -    val bd_repT = fst (dest_relT (fastype_of bnf_bd));
   1.611 -    val bdT_bind = qualify (Binding.suffix_name ("_" ^ bdTN) b);
   1.612 -    val params = fold Term.add_tfreesT Ds [];
   1.613 -    val deads = map TFree params;
   1.614 -
   1.615 -    val ((bdT_name, (bdT_glob_info, bdT_loc_info)), lthy) =
   1.616 -      typedef (bdT_bind, params, NoSyn)
   1.617 -        (HOLogic.mk_UNIV bd_repT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
   1.618 -
   1.619 -    val bnf_bd' = mk_dir_image bnf_bd
   1.620 -      (Const (#Abs_name bdT_glob_info, bd_repT --> Type (bdT_name, deads)))
   1.621 -
   1.622 -    val Abs_bdT_inj = mk_Abs_inj_thm (#Abs_inject bdT_loc_info);
   1.623 -    val Abs_bdT_bij = mk_Abs_bij_thm lthy Abs_bdT_inj (#Abs_cases bdT_loc_info);
   1.624 -
   1.625 -    val bd_ordIso = @{thm dir_image} OF [Abs_bdT_inj, bd_Card_order_of_bnf bnf];
   1.626 -    val bd_card_order =
   1.627 -      @{thm card_order_dir_image} OF [Abs_bdT_bij, bd_card_order_of_bnf bnf];
   1.628 -    val bd_cinfinite =
   1.629 -      (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
   1.630 -
   1.631 -    val set_bds =
   1.632 -      map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
   1.633 -
   1.634 -    fun mk_tac thm {context = ctxt, prems = _} =
   1.635 -      (rtac (unfold_all ctxt thm) THEN'
   1.636 -      SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
   1.637 -
   1.638 -    val tacs = zip_axioms (mk_tac (map_id0_of_bnf bnf)) (mk_tac (map_comp0_of_bnf bnf))
   1.639 -      (mk_tac (map_cong0_of_bnf bnf)) (map mk_tac (set_map0_of_bnf bnf))
   1.640 -      (K (rtac bd_card_order 1)) (K (rtac bd_cinfinite 1)) (map mk_tac set_bds)
   1.641 -      (mk_tac (le_rel_OO_of_bnf bnf))
   1.642 -      (mk_tac (rel_OO_Grp_of_bnf bnf));
   1.643 -
   1.644 -    val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   1.645 -
   1.646 -    fun wit_tac {context = ctxt, prems = _} =
   1.647 -      mk_simple_wit_tac (map (unfold_all ctxt) (wit_thms_of_bnf bnf));
   1.648 -
   1.649 -    val (bnf', lthy') =
   1.650 -      bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
   1.651 -        Binding.empty Binding.empty []
   1.652 -        ((((((b, T), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
   1.653 -  in
   1.654 -    ((bnf', deads), lthy')
   1.655 -  end;
   1.656 -
   1.657 -exception BAD_DEAD of typ * typ;
   1.658 -
   1.659 -fun bnf_of_typ _ _ _ _ (T as TFree _) accum = ((ID_bnf, ([], [T])), accum)
   1.660 -  | bnf_of_typ _ _ _ _ (TVar _) _ = error "Unexpected schematic variable"
   1.661 -  | bnf_of_typ const_policy qualify' sort Xs (T as Type (C, Ts)) (unfold_set, lthy) =
   1.662 -    let
   1.663 -      fun check_bad_dead ((_, (deads, _)), _) =
   1.664 -        let val Ds = fold Term.add_tfreesT deads [] in
   1.665 -          (case Library.inter (op =) Ds Xs of [] => ()
   1.666 -           | X :: _ => raise BAD_DEAD (TFree X, T))
   1.667 -        end;
   1.668 -
   1.669 -      val tfrees = Term.add_tfreesT T [];
   1.670 -      val bnf_opt = if null tfrees then NONE else bnf_of lthy C;
   1.671 -    in
   1.672 -      (case bnf_opt of
   1.673 -        NONE => ((DEADID_bnf, ([T], [])), (unfold_set, lthy))
   1.674 -      | SOME bnf =>
   1.675 -        if forall (can Term.dest_TFree) Ts andalso length Ts = length tfrees then
   1.676 -          let
   1.677 -            val T' = T_of_bnf bnf;
   1.678 -            val deads = deads_of_bnf bnf;
   1.679 -            val lives = lives_of_bnf bnf;
   1.680 -            val tvars' = Term.add_tvarsT T' [];
   1.681 -            val deads_lives =
   1.682 -              pairself (map (Term.typ_subst_TVars (map fst tvars' ~~ map TFree tfrees)))
   1.683 -                (deads, lives);
   1.684 -          in ((bnf, deads_lives), (unfold_set, lthy)) end
   1.685 -        else
   1.686 -          let
   1.687 -            val name = Long_Name.base_name C;
   1.688 -            fun qualify i =
   1.689 -              let val namei = name ^ nonzero_string_of_int i;
   1.690 -              in qualify' o Binding.qualify true namei end;
   1.691 -            val odead = dead_of_bnf bnf;
   1.692 -            val olive = live_of_bnf bnf;
   1.693 -            val oDs_pos = find_indices op = [TFree ("dead", [])] (snd (Term.dest_Type
   1.694 -              (mk_T_of_bnf (replicate odead (TFree ("dead", []))) (replicate olive dummyT) bnf)));
   1.695 -            val oDs = map (nth Ts) oDs_pos;
   1.696 -            val Ts' = map (nth Ts) (subtract (op =) oDs_pos (0 upto length Ts - 1));
   1.697 -            val ((inners, (Dss, Ass)), (unfold_set', lthy')) =
   1.698 -              apfst (apsnd split_list o split_list)
   1.699 -                (fold_map2 (fn i => bnf_of_typ Smart_Inline (qualify i) sort Xs)
   1.700 -                (if length Ts' = 1 then [0] else (1 upto length Ts')) Ts' (unfold_set, lthy));
   1.701 -          in
   1.702 -            compose_bnf const_policy qualify sort bnf inners oDs Dss Ass (unfold_set', lthy')
   1.703 -          end)
   1.704 -      |> tap check_bad_dead
   1.705 -    end;
   1.706 -
   1.707 -end;
     2.1 --- a/src/HOL/Tools/BNF/Tools/bnf_comp_tactics.ML	Mon Jan 20 18:24:56 2014 +0100
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,252 +0,0 @@
     2.4 -(*  Title:      HOL/BNF/Tools/bnf_comp_tactics.ML
     2.5 -    Author:     Dmitriy Traytel, TU Muenchen
     2.6 -    Author:     Jasmin Blanchette, TU Muenchen
     2.7 -    Copyright   2012
     2.8 -
     2.9 -Tactics for composition of bounded natural functors.
    2.10 -*)
    2.11 -
    2.12 -signature BNF_COMP_TACTICS =
    2.13 -sig
    2.14 -  val mk_comp_bd_card_order_tac: thm list -> thm -> tactic
    2.15 -  val mk_comp_bd_cinfinite_tac: thm -> thm -> tactic
    2.16 -  val mk_comp_in_alt_tac: Proof.context -> thm list -> tactic
    2.17 -  val mk_comp_map_comp0_tac: thm -> thm -> thm list -> tactic
    2.18 -  val mk_comp_map_cong0_tac: thm list -> thm -> thm list -> tactic
    2.19 -  val mk_comp_map_id0_tac: thm -> thm -> thm list -> tactic
    2.20 -  val mk_comp_set_alt_tac: Proof.context -> thm -> tactic
    2.21 -  val mk_comp_set_bd_tac: Proof.context -> thm -> thm list -> tactic
    2.22 -  val mk_comp_set_map0_tac: thm -> thm -> thm -> thm list -> tactic
    2.23 -  val mk_comp_wit_tac: Proof.context -> thm list -> thm -> thm list -> tactic
    2.24 -
    2.25 -  val mk_kill_bd_card_order_tac: int -> thm -> tactic
    2.26 -  val mk_kill_bd_cinfinite_tac: thm -> tactic
    2.27 -  val kill_in_alt_tac: tactic
    2.28 -  val mk_kill_map_cong0_tac: Proof.context -> int -> int -> thm -> tactic
    2.29 -  val mk_kill_set_bd_tac: thm -> thm -> tactic
    2.30 -
    2.31 -  val empty_natural_tac: tactic
    2.32 -  val lift_in_alt_tac: tactic
    2.33 -  val mk_lift_set_bd_tac: thm -> tactic
    2.34 -
    2.35 -  val mk_permute_in_alt_tac: ''a list -> ''a list -> tactic
    2.36 -
    2.37 -  val mk_le_rel_OO_tac: thm -> thm -> thm list -> tactic
    2.38 -  val mk_simple_rel_OO_Grp_tac: thm -> thm -> tactic
    2.39 -  val mk_simple_wit_tac: thm list -> tactic
    2.40 -end;
    2.41 -
    2.42 -structure BNF_Comp_Tactics : BNF_COMP_TACTICS =
    2.43 -struct
    2.44 -
    2.45 -open BNF_Util
    2.46 -open BNF_Tactics
    2.47 -
    2.48 -val Cnotzero_UNIV = @{thm Cnotzero_UNIV};
    2.49 -val arg_cong_Union = @{thm arg_cong[of _ _ Union]};
    2.50 -val csum_Cnotzero1 = @{thm csum_Cnotzero1};
    2.51 -val o_eq_dest_lhs = @{thm o_eq_dest_lhs};
    2.52 -val trans_image_cong_o_apply = @{thm trans[OF image_cong[OF o_apply refl]]};
    2.53 -val trans_o_apply = @{thm trans[OF o_apply]};
    2.54 -
    2.55 -
    2.56 -
    2.57 -(* Composition *)
    2.58 -
    2.59 -fun mk_comp_set_alt_tac ctxt collect_set_map =
    2.60 -  unfold_thms_tac ctxt @{thms sym[OF o_assoc]} THEN
    2.61 -  unfold_thms_tac ctxt [collect_set_map RS sym] THEN
    2.62 -  rtac refl 1;
    2.63 -
    2.64 -fun mk_comp_map_id0_tac Gmap_id0 Gmap_cong0 map_id0s =
    2.65 -  EVERY' ([rtac ext, rtac (Gmap_cong0 RS trans)] @
    2.66 -    map (fn thm => rtac (thm RS fun_cong)) map_id0s @ [rtac (Gmap_id0 RS fun_cong)]) 1;
    2.67 -
    2.68 -fun mk_comp_map_comp0_tac Gmap_comp0 Gmap_cong0 map_comp0s =
    2.69 -  EVERY' ([rtac ext, rtac sym, rtac trans_o_apply,
    2.70 -    rtac (Gmap_comp0 RS sym RS o_eq_dest_lhs RS trans), rtac Gmap_cong0] @
    2.71 -    map (fn thm => rtac (thm RS sym RS fun_cong)) map_comp0s) 1;
    2.72 -
    2.73 -fun mk_comp_set_map0_tac Gmap_comp0 Gmap_cong0 Gset_map0 set_map0s =
    2.74 -  EVERY' ([rtac ext] @
    2.75 -    replicate 3 (rtac trans_o_apply) @
    2.76 -    [rtac (arg_cong_Union RS trans),
    2.77 -     rtac (@{thm arg_cong2[of _ _ _ _ collect, OF refl]} RS trans),
    2.78 -     rtac (Gmap_comp0 RS sym RS o_eq_dest_lhs RS trans),
    2.79 -     rtac Gmap_cong0] @
    2.80 -     map (fn thm => rtac (thm RS fun_cong)) set_map0s @
    2.81 -     [rtac (Gset_map0 RS o_eq_dest_lhs), rtac sym, rtac trans_o_apply,
    2.82 -     rtac trans_image_cong_o_apply, rtac trans_image_cong_o_apply,
    2.83 -     rtac (@{thm image_cong} OF [Gset_map0 RS o_eq_dest_lhs RS arg_cong_Union, refl] RS trans),
    2.84 -     rtac @{thm trans[OF comp_eq_dest[OF Union_natural[symmetric]]]}, rtac arg_cong_Union,
    2.85 -     rtac @{thm trans[OF o_eq_dest_lhs[OF image_o_collect[symmetric]]]},
    2.86 -     rtac @{thm fun_cong[OF arg_cong[of _ _ collect]]}] @
    2.87 -     [REPEAT_DETERM_N (length set_map0s) o EVERY' [rtac @{thm trans[OF image_insert]},
    2.88 -        rtac @{thm arg_cong2[of _ _ _ _ insert]}, rtac ext, rtac trans_o_apply,
    2.89 -        rtac trans_image_cong_o_apply, rtac @{thm trans[OF image_image]},
    2.90 -        rtac @{thm sym[OF trans[OF o_apply]]}, rtac @{thm image_cong[OF refl o_apply]}],
    2.91 -     rtac @{thm image_empty}]) 1;
    2.92 -
    2.93 -fun mk_comp_map_cong0_tac comp_set_alts map_cong0 map_cong0s =
    2.94 -  let
    2.95 -     val n = length comp_set_alts;
    2.96 -  in
    2.97 -    (if n = 0 then rtac refl 1
    2.98 -    else rtac map_cong0 1 THEN
    2.99 -      EVERY' (map_index (fn (i, map_cong0) =>
   2.100 -        rtac map_cong0 THEN' EVERY' (map_index (fn (k, set_alt) =>
   2.101 -          EVERY' [select_prem_tac n (dtac @{thm meta_spec}) (k + 1), etac meta_mp,
   2.102 -            rtac (equalityD2 RS set_mp), rtac (set_alt RS fun_cong RS trans),
   2.103 -            rtac trans_o_apply, rtac (@{thm collect_def} RS arg_cong_Union),
   2.104 -            rtac @{thm UnionI}, rtac @{thm UN_I}, REPEAT_DETERM_N i o rtac @{thm insertI2},
   2.105 -            rtac @{thm insertI1}, rtac (o_apply RS equalityD2 RS set_mp),
   2.106 -            etac @{thm imageI}, atac])
   2.107 -          comp_set_alts))
   2.108 -      map_cong0s) 1)
   2.109 -  end;
   2.110 -
   2.111 -fun mk_comp_bd_card_order_tac Fbd_card_orders Gbd_card_order =
   2.112 -  let
   2.113 -    val (card_orders, last_card_order) = split_last Fbd_card_orders;
   2.114 -    fun gen_before thm = rtac @{thm card_order_csum} THEN' rtac thm;
   2.115 -  in
   2.116 -    (rtac @{thm card_order_cprod} THEN'
   2.117 -    WRAP' gen_before (K (K all_tac)) card_orders (rtac last_card_order) THEN'
   2.118 -    rtac Gbd_card_order) 1
   2.119 -  end;
   2.120 -
   2.121 -fun mk_comp_bd_cinfinite_tac Fbd_cinfinite Gbd_cinfinite =
   2.122 -  (rtac @{thm cinfinite_cprod} THEN'
   2.123 -   ((K (TRY ((rtac @{thm cinfinite_csum} THEN' rtac disjI1) 1)) THEN'
   2.124 -     ((rtac @{thm cinfinite_csum} THEN' rtac disjI1 THEN' rtac Fbd_cinfinite) ORELSE'
   2.125 -      rtac Fbd_cinfinite)) ORELSE'
   2.126 -    rtac Fbd_cinfinite) THEN'
   2.127 -   rtac Gbd_cinfinite) 1;
   2.128 -
   2.129 -fun mk_comp_set_bd_tac ctxt comp_set_alt Gset_Fset_bds =
   2.130 -  let
   2.131 -    val (bds, last_bd) = split_last Gset_Fset_bds;
   2.132 -    fun gen_before bd =
   2.133 -      rtac ctrans THEN' rtac @{thm Un_csum} THEN'
   2.134 -      rtac ctrans THEN' rtac @{thm csum_mono} THEN'
   2.135 -      rtac bd;
   2.136 -    fun gen_after _ = rtac @{thm ordIso_imp_ordLeq} THEN' rtac @{thm cprod_csum_distrib1};
   2.137 -  in
   2.138 -    unfold_thms_tac ctxt [comp_set_alt] THEN
   2.139 -    rtac @{thm comp_set_bd_Union_o_collect} 1 THEN
   2.140 -    unfold_thms_tac ctxt @{thms Union_image_insert Union_image_empty Union_Un_distrib o_apply} THEN
   2.141 -    (rtac ctrans THEN'
   2.142 -     WRAP' gen_before gen_after bds (rtac last_bd) THEN'
   2.143 -     rtac @{thm ordIso_imp_ordLeq} THEN'
   2.144 -     rtac @{thm cprod_com}) 1
   2.145 -  end;
   2.146 -
   2.147 -val comp_in_alt_thms = @{thms o_apply collect_def SUP_def image_insert image_empty Union_insert
   2.148 -  Union_empty Un_empty_right Union_Un_distrib Un_subset_iff conj_subset_def UN_image_subset
   2.149 -  conj_assoc};
   2.150 -
   2.151 -fun mk_comp_in_alt_tac ctxt comp_set_alts =
   2.152 -  unfold_thms_tac ctxt (comp_set_alts @ comp_in_alt_thms) THEN
   2.153 -  unfold_thms_tac ctxt @{thms set_eq_subset} THEN
   2.154 -  rtac conjI 1 THEN
   2.155 -  REPEAT_DETERM (
   2.156 -    rtac @{thm subsetI} 1 THEN
   2.157 -    unfold_thms_tac ctxt @{thms mem_Collect_eq Ball_def} THEN
   2.158 -    (REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
   2.159 -     REPEAT_DETERM (CHANGED ((
   2.160 -       (rtac conjI THEN' (atac ORELSE' rtac subset_UNIV)) ORELSE'
   2.161 -       atac ORELSE'
   2.162 -       (rtac subset_UNIV)) 1)) ORELSE rtac subset_UNIV 1));
   2.163 -
   2.164 -val comp_wit_thms = @{thms Union_empty_conv o_apply collect_def SUP_def
   2.165 -  Union_image_insert Union_image_empty};
   2.166 -
   2.167 -fun mk_comp_wit_tac ctxt Gwit_thms collect_set_map Fwit_thms =
   2.168 -  ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
   2.169 -  unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
   2.170 -  REPEAT_DETERM ((atac ORELSE'
   2.171 -    REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
   2.172 -    etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
   2.173 -    (etac FalseE ORELSE'
   2.174 -    hyp_subst_tac ctxt THEN'
   2.175 -    dresolve_tac Fwit_thms THEN'
   2.176 -    (etac FalseE ORELSE' atac))) 1);
   2.177 -
   2.178 -
   2.179 -
   2.180 -(* Kill operation *)
   2.181 -
   2.182 -fun mk_kill_map_cong0_tac ctxt n m map_cong0 =
   2.183 -  (rtac map_cong0 THEN' EVERY' (replicate n (rtac refl)) THEN'
   2.184 -    EVERY' (replicate m (Goal.assume_rule_tac ctxt))) 1;
   2.185 -
   2.186 -fun mk_kill_bd_card_order_tac n bd_card_order =
   2.187 -  (rtac @{thm card_order_cprod} THEN'
   2.188 -  K (REPEAT_DETERM_N (n - 1)
   2.189 -    ((rtac @{thm card_order_csum} THEN'
   2.190 -    rtac @{thm card_of_card_order_on}) 1)) THEN'
   2.191 -  rtac @{thm card_of_card_order_on} THEN'
   2.192 -  rtac bd_card_order) 1;
   2.193 -
   2.194 -fun mk_kill_bd_cinfinite_tac bd_Cinfinite =
   2.195 -  (rtac @{thm cinfinite_cprod2} THEN'
   2.196 -  TRY o rtac csum_Cnotzero1 THEN'
   2.197 -  rtac Cnotzero_UNIV THEN'
   2.198 -  rtac bd_Cinfinite) 1;
   2.199 -
   2.200 -fun mk_kill_set_bd_tac bd_Card_order set_bd =
   2.201 -  (rtac ctrans THEN'
   2.202 -  rtac set_bd THEN'
   2.203 -  rtac @{thm ordLeq_cprod2} THEN'
   2.204 -  TRY o rtac csum_Cnotzero1 THEN'
   2.205 -  rtac Cnotzero_UNIV THEN'
   2.206 -  rtac bd_Card_order) 1
   2.207 -
   2.208 -val kill_in_alt_tac =
   2.209 -  ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
   2.210 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
   2.211 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
   2.212 -    rtac conjI THEN' rtac subset_UNIV) 1)) THEN
   2.213 -  (rtac subset_UNIV ORELSE' atac) 1 THEN
   2.214 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
   2.215 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1))) ORELSE
   2.216 -  ((rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
   2.217 -    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac subset_UNIV 1));
   2.218 -
   2.219 -
   2.220 -
   2.221 -(* Lift operation *)
   2.222 -
   2.223 -val empty_natural_tac = rtac @{thm empty_natural} 1;
   2.224 -
   2.225 -fun mk_lift_set_bd_tac bd_Card_order = (rtac @{thm Card_order_empty} THEN' rtac bd_Card_order) 1;
   2.226 -
   2.227 -val lift_in_alt_tac =
   2.228 -  ((rtac @{thm Collect_cong} THEN' rtac iffI) 1 THEN
   2.229 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
   2.230 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE' atac) 1)) THEN
   2.231 -  REPEAT_DETERM (CHANGED (etac conjE 1)) THEN
   2.232 -  REPEAT_DETERM (CHANGED ((etac conjI ORELSE'
   2.233 -    rtac conjI THEN' rtac @{thm empty_subsetI}) 1)) THEN
   2.234 -  (rtac @{thm empty_subsetI} ORELSE' atac) 1) ORELSE
   2.235 -  ((rtac sym THEN' rtac @{thm UNIV_eq_I} THEN' rtac CollectI) 1 THEN
   2.236 -    REPEAT_DETERM (TRY (rtac conjI 1) THEN rtac @{thm empty_subsetI} 1));
   2.237 -
   2.238 -
   2.239 -
   2.240 -(* Permute operation *)
   2.241 -
   2.242 -fun mk_permute_in_alt_tac src dest =
   2.243 -  (rtac @{thm Collect_cong} THEN'
   2.244 -  mk_rotate_eq_tac (rtac refl) trans @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
   2.245 -    dest src) 1;
   2.246 -
   2.247 -fun mk_le_rel_OO_tac outer_le_rel_OO outer_rel_mono inner_le_rel_OOs =
   2.248 -  EVERY' (map rtac (@{thm order_trans} :: outer_le_rel_OO :: outer_rel_mono :: inner_le_rel_OOs)) 1;
   2.249 -
   2.250 -fun mk_simple_rel_OO_Grp_tac rel_OO_Grp in_alt_thm =
   2.251 -  rtac (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym]) 1;
   2.252 -
   2.253 -fun mk_simple_wit_tac wit_thms = ALLGOALS (atac ORELSE' eresolve_tac (@{thm emptyE} :: wit_thms));
   2.254 -
   2.255 -end;
     3.1 --- a/src/HOL/Tools/BNF/Tools/bnf_decl.ML	Mon Jan 20 18:24:56 2014 +0100
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,117 +0,0 @@
     3.4 -(*  Title:      HOL/BNF/Tools/bnf_decl.ML
     3.5 -    Author:     Dmitriy Traytel, TU Muenchen
     3.6 -    Copyright   2013
     3.7 -
     3.8 -Axiomatic declaration of bounded natural functors.
     3.9 -*)
    3.10 -
    3.11 -signature BNF_DECL =
    3.12 -sig
    3.13 -  val bnf_decl: (binding option * (typ * sort)) list -> binding -> mixfix -> binding -> binding ->
    3.14 -    typ list -> local_theory -> BNF_Def.bnf * local_theory
    3.15 -end
    3.16 -
    3.17 -structure BNF_Decl : BNF_DECL =
    3.18 -struct
    3.19 -
    3.20 -open BNF_Util
    3.21 -open BNF_Def
    3.22 -
    3.23 -fun prepare_decl prepare_constraint prepare_typ raw_vars b mx user_mapb user_relb user_witTs lthy =
    3.24 -  let
    3.25 -   fun prepare_type_arg (set_opt, (ty, c)) =
    3.26 -      let val s = fst (dest_TFree (prepare_typ lthy ty)) in
    3.27 -        (set_opt, (s, prepare_constraint lthy c))
    3.28 -      end;
    3.29 -    val ((user_setbs, vars), raw_vars') =
    3.30 -      map prepare_type_arg raw_vars
    3.31 -      |> `split_list
    3.32 -      |>> apfst (map_filter I);
    3.33 -    val deads = map_filter (fn (NONE, x) => SOME x | _ => NONE) raw_vars';
    3.34 -
    3.35 -    fun mk_b name user_b =
    3.36 -      (if Binding.is_empty user_b then Binding.prefix_name (name ^ "_") b else user_b)
    3.37 -      |> Binding.qualify false (Binding.name_of b);
    3.38 -    val (Tname, lthy) = Typedecl.basic_typedecl (b, length vars, mx) lthy;
    3.39 -    val (bd_type_Tname, lthy) =
    3.40 -      Typedecl.basic_typedecl (mk_b "bd_type" Binding.empty, length deads, NoSyn) lthy;
    3.41 -    val T = Type (Tname, map TFree vars);
    3.42 -    val bd_type_T = Type (bd_type_Tname, map TFree deads);
    3.43 -    val lives = map TFree (filter_out (member (op =) deads) vars);
    3.44 -    val live = length lives;
    3.45 -    val _ = "Trying to declare a BNF with no live variables" |> null lives ? error;
    3.46 -    val (lives', _) = BNF_Util.mk_TFrees (length lives)
    3.47 -      (fold Variable.declare_typ (map TFree vars) lthy);
    3.48 -    val T' = Term.typ_subst_atomic (lives ~~ lives') T;
    3.49 -    val mapT = map2 (curry op -->) lives lives' ---> T --> T';
    3.50 -    val setTs = map (fn U => T --> HOLogic.mk_setT U) lives;
    3.51 -    val bdT = BNF_Util.mk_relT (bd_type_T, bd_type_T);
    3.52 -    val mapb = mk_b BNF_Def.mapN user_mapb;
    3.53 -    val bdb = mk_b "bd" Binding.empty;
    3.54 -    val setbs = map2 (fn b => fn i => mk_b (BNF_Def.mk_setN i) b) user_setbs
    3.55 -      (if live = 1 then [0] else 1 upto live);
    3.56 -
    3.57 -    val witTs = map (prepare_typ lthy) user_witTs;
    3.58 -    val nwits = length witTs;
    3.59 -    val witbs = map (fn i => mk_b (BNF_Def.mk_witN i) Binding.empty)
    3.60 -      (if nwits = 1 then [0] else 1 upto nwits);
    3.61 -
    3.62 -    val lthy = Local_Theory.background_theory
    3.63 -      (Sign.add_consts_i ((mapb, mapT, NoSyn) :: (bdb, bdT, NoSyn) ::
    3.64 -        map2 (fn b => fn T => (b, T, NoSyn)) setbs setTs @
    3.65 -        map2 (fn b => fn T => (b, T, NoSyn)) witbs witTs))
    3.66 -      lthy;
    3.67 -    val Fmap = Const (Local_Theory.full_name lthy mapb, mapT);
    3.68 -    val Fsets = map2 (fn setb => fn setT =>
    3.69 -      Const (Local_Theory.full_name lthy setb, setT)) setbs setTs;
    3.70 -    val Fbd = Const (Local_Theory.full_name lthy bdb, bdT);
    3.71 -    val Fwits = map2 (fn witb => fn witT =>
    3.72 -      Const (Local_Theory.full_name lthy witb, witT)) witbs witTs;
    3.73 -    val (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, _) =
    3.74 -      prepare_def Do_Inline (user_policy Note_Some) I (K I) (K I) (SOME (map TFree deads))
    3.75 -      user_mapb user_relb user_setbs ((((((Binding.empty, T), Fmap), Fsets), Fbd), Fwits), NONE)
    3.76 -      lthy;
    3.77 -
    3.78 -    fun mk_wits_tac set_maps = K (TRYALL Goal.conjunction_tac) THEN' the triv_tac_opt set_maps;
    3.79 -    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
    3.80 -    val all_goalss = map single goals @ (if nwits > 0 then wit_goalss else []);
    3.81 -
    3.82 -    val (((_, [raw_thms])), (lthy_old, lthy)) = Local_Theory.background_theory_result
    3.83 -      (Specification.axiomatization [] [((mk_b "axioms" Binding.empty, []), flat all_goalss)]) lthy
    3.84 -      ||> `Local_Theory.restore;
    3.85 -
    3.86 -    fun mk_wit_thms set_maps =
    3.87 -      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
    3.88 -      |> Conjunction.elim_balanced (length wit_goals)
    3.89 -      |> map2 (Conjunction.elim_balanced o length) wit_goalss
    3.90 -      |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
    3.91 -    val phi = Proof_Context.export_morphism lthy_old lthy;
    3.92 -    val thms = unflat all_goalss (Morphism.fact phi raw_thms);
    3.93 -  in
    3.94 -    BNF_Def.register_bnf key (after_qed mk_wit_thms thms lthy)
    3.95 -  end;
    3.96 -
    3.97 -val bnf_decl = prepare_decl (K I) (K I);
    3.98 -
    3.99 -fun read_constraint _ NONE = HOLogic.typeS
   3.100 -  | read_constraint ctxt (SOME s) = Syntax.read_sort ctxt s;
   3.101 -
   3.102 -val bnf_decl_cmd = prepare_decl read_constraint Syntax.read_typ;
   3.103 -
   3.104 -val parse_witTs =
   3.105 -  @{keyword "["} |-- (Parse.short_ident --| @{keyword ":"} -- Scan.repeat Parse.typ
   3.106 -    >> (fn ("wits", Ts) => Ts
   3.107 -         | (s, _) => error ("Unknown label " ^ quote s ^ " (expected \"wits\")"))) --|
   3.108 -  @{keyword "]"} || Scan.succeed [];
   3.109 -
   3.110 -val parse_bnf_decl =
   3.111 -  parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings --
   3.112 -    parse_witTs -- Parse.opt_mixfix;
   3.113 -
   3.114 -val _ =
   3.115 -  Outer_Syntax.local_theory @{command_spec "bnf_decl"} "bnf declaration"
   3.116 -    (parse_bnf_decl >> 
   3.117 -      (fn ((((bsTs, b), (mapb, relb)), witTs), mx) =>
   3.118 -         bnf_decl_cmd bsTs b mx mapb relb witTs #> snd));
   3.119 -
   3.120 -end;
     4.1 --- a/src/HOL/Tools/BNF/Tools/bnf_def.ML	Mon Jan 20 18:24:56 2014 +0100
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,1393 +0,0 @@
     4.4 -(*  Title:      HOL/BNF/Tools/bnf_def.ML
     4.5 -    Author:     Dmitriy Traytel, TU Muenchen
     4.6 -    Author:     Jasmin Blanchette, TU Muenchen
     4.7 -    Copyright   2012
     4.8 -
     4.9 -Definition of bounded natural functors.
    4.10 -*)
    4.11 -
    4.12 -signature BNF_DEF =
    4.13 -sig
    4.14 -  type bnf
    4.15 -  type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
    4.16 -
    4.17 -  val morph_bnf: morphism -> bnf -> bnf
    4.18 -  val eq_bnf: bnf * bnf -> bool
    4.19 -  val bnf_of: Proof.context -> string -> bnf option
    4.20 -  val register_bnf: string -> (bnf * local_theory) -> (bnf * local_theory)
    4.21 -
    4.22 -  val name_of_bnf: bnf -> binding
    4.23 -  val T_of_bnf: bnf -> typ
    4.24 -  val live_of_bnf: bnf -> int
    4.25 -  val lives_of_bnf: bnf -> typ list
    4.26 -  val dead_of_bnf: bnf -> int
    4.27 -  val deads_of_bnf: bnf -> typ list
    4.28 -  val nwits_of_bnf: bnf -> int
    4.29 -
    4.30 -  val mapN: string
    4.31 -  val relN: string
    4.32 -  val setN: string
    4.33 -  val mk_setN: int -> string
    4.34 -  val mk_witN: int -> string
    4.35 -
    4.36 -  val map_of_bnf: bnf -> term
    4.37 -  val sets_of_bnf: bnf -> term list
    4.38 -  val rel_of_bnf: bnf -> term
    4.39 -
    4.40 -  val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
    4.41 -  val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
    4.42 -  val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    4.43 -  val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
    4.44 -  val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
    4.45 -  val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
    4.46 -
    4.47 -  val bd_Card_order_of_bnf: bnf -> thm
    4.48 -  val bd_Cinfinite_of_bnf: bnf -> thm
    4.49 -  val bd_Cnotzero_of_bnf: bnf -> thm
    4.50 -  val bd_card_order_of_bnf: bnf -> thm
    4.51 -  val bd_cinfinite_of_bnf: bnf -> thm
    4.52 -  val collect_set_map_of_bnf: bnf -> thm
    4.53 -  val in_bd_of_bnf: bnf -> thm
    4.54 -  val in_cong_of_bnf: bnf -> thm
    4.55 -  val in_mono_of_bnf: bnf -> thm
    4.56 -  val in_rel_of_bnf: bnf -> thm
    4.57 -  val map_comp0_of_bnf: bnf -> thm
    4.58 -  val map_comp_of_bnf: bnf -> thm
    4.59 -  val map_cong0_of_bnf: bnf -> thm
    4.60 -  val map_cong_of_bnf: bnf -> thm
    4.61 -  val map_def_of_bnf: bnf -> thm
    4.62 -  val map_id0_of_bnf: bnf -> thm
    4.63 -  val map_id_of_bnf: bnf -> thm
    4.64 -  val map_transfer_of_bnf: bnf -> thm
    4.65 -  val le_rel_OO_of_bnf: bnf -> thm
    4.66 -  val rel_def_of_bnf: bnf -> thm
    4.67 -  val rel_Grp_of_bnf: bnf -> thm
    4.68 -  val rel_OO_of_bnf: bnf -> thm
    4.69 -  val rel_OO_Grp_of_bnf: bnf -> thm
    4.70 -  val rel_cong_of_bnf: bnf -> thm
    4.71 -  val rel_conversep_of_bnf: bnf -> thm
    4.72 -  val rel_mono_of_bnf: bnf -> thm
    4.73 -  val rel_mono_strong_of_bnf: bnf -> thm
    4.74 -  val rel_eq_of_bnf: bnf -> thm
    4.75 -  val rel_flip_of_bnf: bnf -> thm
    4.76 -  val set_bd_of_bnf: bnf -> thm list
    4.77 -  val set_defs_of_bnf: bnf -> thm list
    4.78 -  val set_map0_of_bnf: bnf -> thm list
    4.79 -  val set_map_of_bnf: bnf -> thm list
    4.80 -  val wit_thms_of_bnf: bnf -> thm list
    4.81 -  val wit_thmss_of_bnf: bnf -> thm list list
    4.82 -
    4.83 -  val mk_map: int -> typ list -> typ list -> term -> term
    4.84 -  val mk_rel: int -> typ list -> typ list -> term -> term
    4.85 -  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
    4.86 -  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
    4.87 -  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
    4.88 -  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
    4.89 -    'a list
    4.90 -
    4.91 -  val mk_witness: int list * term -> thm list -> nonemptiness_witness
    4.92 -  val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
    4.93 -  val wits_of_bnf: bnf -> nonemptiness_witness list
    4.94 -
    4.95 -  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
    4.96 -
    4.97 -  datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
    4.98 -  datatype fact_policy = Dont_Note | Note_Some | Note_All
    4.99 -
   4.100 -  val bnf_note_all: bool Config.T
   4.101 -  val bnf_timing: bool Config.T
   4.102 -  val user_policy: fact_policy -> Proof.context -> fact_policy
   4.103 -  val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> Proof.context ->
   4.104 -    Proof.context
   4.105 -
   4.106 -  val print_bnfs: Proof.context -> unit
   4.107 -  val prepare_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
   4.108 -    (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> typ list option ->
   4.109 -    binding -> binding -> binding list ->
   4.110 -    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
   4.111 -    string * term list *
   4.112 -    ((thm list -> {context: Proof.context, prems: thm list} -> tactic) option * term list list) *
   4.113 -    ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
   4.114 -    local_theory * thm list
   4.115 -
   4.116 -  val define_bnf_consts: const_policy -> fact_policy -> typ list option ->
   4.117 -    binding -> binding -> binding list ->
   4.118 -    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
   4.119 -      ((typ list * typ list * typ list * typ) *
   4.120 -       (term * term list * term * (int list * term) list * term) *
   4.121 -       (thm * thm list * thm * thm list * thm) *
   4.122 -       ((typ list -> typ list -> typ list -> term) *
   4.123 -        (typ list -> typ list -> term -> term) *
   4.124 -        (typ list -> typ list -> typ -> typ) *
   4.125 -        (typ list -> typ list -> typ list -> term) *
   4.126 -        (typ list -> typ list -> typ list -> term))) * local_theory
   4.127 -
   4.128 -  val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
   4.129 -    ({prems: thm list, context: Proof.context} -> tactic) list ->
   4.130 -    ({prems: thm list, context: Proof.context} -> tactic) -> typ list option -> binding ->
   4.131 -    binding -> binding list ->
   4.132 -    (((((binding * typ) * term) * term list) * term) * term list) * term option ->
   4.133 -    local_theory -> bnf * local_theory
   4.134 -end;
   4.135 -
   4.136 -structure BNF_Def : BNF_DEF =
   4.137 -struct
   4.138 -
   4.139 -open BNF_Util
   4.140 -open BNF_Tactics
   4.141 -open BNF_Def_Tactics
   4.142 -
   4.143 -val fundefcong_attrs = @{attributes [fundef_cong]};
   4.144 -
   4.145 -type axioms = {
   4.146 -  map_id0: thm,
   4.147 -  map_comp0: thm,
   4.148 -  map_cong0: thm,
   4.149 -  set_map0: thm list,
   4.150 -  bd_card_order: thm,
   4.151 -  bd_cinfinite: thm,
   4.152 -  set_bd: thm list,
   4.153 -  le_rel_OO: thm,
   4.154 -  rel_OO_Grp: thm
   4.155 -};
   4.156 -
   4.157 -fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
   4.158 -  {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
   4.159 -   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
   4.160 -
   4.161 -fun dest_cons [] = raise List.Empty
   4.162 -  | dest_cons (x :: xs) = (x, xs);
   4.163 -
   4.164 -fun mk_axioms n thms = thms
   4.165 -  |> map the_single
   4.166 -  |> dest_cons
   4.167 -  ||>> dest_cons
   4.168 -  ||>> dest_cons
   4.169 -  ||>> chop n
   4.170 -  ||>> dest_cons
   4.171 -  ||>> dest_cons
   4.172 -  ||>> chop n
   4.173 -  ||>> dest_cons
   4.174 -  ||> the_single
   4.175 -  |> mk_axioms';
   4.176 -
   4.177 -fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
   4.178 -  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
   4.179 -
   4.180 -fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
   4.181 -  le_rel_OO, rel_OO_Grp} =
   4.182 -  zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
   4.183 -    rel_OO_Grp;
   4.184 -
   4.185 -fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
   4.186 -  le_rel_OO, rel_OO_Grp} =
   4.187 -  {map_id0 = f map_id0,
   4.188 -    map_comp0 = f map_comp0,
   4.189 -    map_cong0 = f map_cong0,
   4.190 -    set_map0 = map f set_map0,
   4.191 -    bd_card_order = f bd_card_order,
   4.192 -    bd_cinfinite = f bd_cinfinite,
   4.193 -    set_bd = map f set_bd,
   4.194 -    le_rel_OO = f le_rel_OO,
   4.195 -    rel_OO_Grp = f rel_OO_Grp};
   4.196 -
   4.197 -val morph_axioms = map_axioms o Morphism.thm;
   4.198 -
   4.199 -type defs = {
   4.200 -  map_def: thm,
   4.201 -  set_defs: thm list,
   4.202 -  rel_def: thm
   4.203 -}
   4.204 -
   4.205 -fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
   4.206 -
   4.207 -fun map_defs f {map_def, set_defs, rel_def} =
   4.208 -  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
   4.209 -
   4.210 -val morph_defs = map_defs o Morphism.thm;
   4.211 -
   4.212 -type facts = {
   4.213 -  bd_Card_order: thm,
   4.214 -  bd_Cinfinite: thm,
   4.215 -  bd_Cnotzero: thm,
   4.216 -  collect_set_map: thm lazy,
   4.217 -  in_bd: thm lazy,
   4.218 -  in_cong: thm lazy,
   4.219 -  in_mono: thm lazy,
   4.220 -  in_rel: thm lazy,
   4.221 -  map_comp: thm lazy,
   4.222 -  map_cong: thm lazy,
   4.223 -  map_id: thm lazy,
   4.224 -  map_transfer: thm lazy,
   4.225 -  rel_eq: thm lazy,
   4.226 -  rel_flip: thm lazy,
   4.227 -  set_map: thm lazy list,
   4.228 -  rel_cong: thm lazy,
   4.229 -  rel_mono: thm lazy,
   4.230 -  rel_mono_strong: thm lazy,
   4.231 -  rel_Grp: thm lazy,
   4.232 -  rel_conversep: thm lazy,
   4.233 -  rel_OO: thm lazy
   4.234 -};
   4.235 -
   4.236 -fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
   4.237 -    map_comp map_cong map_id map_transfer rel_eq rel_flip set_map rel_cong rel_mono
   4.238 -    rel_mono_strong rel_Grp rel_conversep rel_OO = {
   4.239 -  bd_Card_order = bd_Card_order,
   4.240 -  bd_Cinfinite = bd_Cinfinite,
   4.241 -  bd_Cnotzero = bd_Cnotzero,
   4.242 -  collect_set_map = collect_set_map,
   4.243 -  in_bd = in_bd,
   4.244 -  in_cong = in_cong,
   4.245 -  in_mono = in_mono,
   4.246 -  in_rel = in_rel,
   4.247 -  map_comp = map_comp,
   4.248 -  map_cong = map_cong,
   4.249 -  map_id = map_id,
   4.250 -  map_transfer = map_transfer,
   4.251 -  rel_eq = rel_eq,
   4.252 -  rel_flip = rel_flip,
   4.253 -  set_map = set_map,
   4.254 -  rel_cong = rel_cong,
   4.255 -  rel_mono = rel_mono,
   4.256 -  rel_mono_strong = rel_mono_strong,
   4.257 -  rel_Grp = rel_Grp,
   4.258 -  rel_conversep = rel_conversep,
   4.259 -  rel_OO = rel_OO};
   4.260 -
   4.261 -fun map_facts f {
   4.262 -  bd_Card_order,
   4.263 -  bd_Cinfinite,
   4.264 -  bd_Cnotzero,
   4.265 -  collect_set_map,
   4.266 -  in_bd,
   4.267 -  in_cong,
   4.268 -  in_mono,
   4.269 -  in_rel,
   4.270 -  map_comp,
   4.271 -  map_cong,
   4.272 -  map_id,
   4.273 -  map_transfer,
   4.274 -  rel_eq,
   4.275 -  rel_flip,
   4.276 -  set_map,
   4.277 -  rel_cong,
   4.278 -  rel_mono,
   4.279 -  rel_mono_strong,
   4.280 -  rel_Grp,
   4.281 -  rel_conversep,
   4.282 -  rel_OO} =
   4.283 -  {bd_Card_order = f bd_Card_order,
   4.284 -    bd_Cinfinite = f bd_Cinfinite,
   4.285 -    bd_Cnotzero = f bd_Cnotzero,
   4.286 -    collect_set_map = Lazy.map f collect_set_map,
   4.287 -    in_bd = Lazy.map f in_bd,
   4.288 -    in_cong = Lazy.map f in_cong,
   4.289 -    in_mono = Lazy.map f in_mono,
   4.290 -    in_rel = Lazy.map f in_rel,
   4.291 -    map_comp = Lazy.map f map_comp,
   4.292 -    map_cong = Lazy.map f map_cong,
   4.293 -    map_id = Lazy.map f map_id,
   4.294 -    map_transfer = Lazy.map f map_transfer,
   4.295 -    rel_eq = Lazy.map f rel_eq,
   4.296 -    rel_flip = Lazy.map f rel_flip,
   4.297 -    set_map = map (Lazy.map f) set_map,
   4.298 -    rel_cong = Lazy.map f rel_cong,
   4.299 -    rel_mono = Lazy.map f rel_mono,
   4.300 -    rel_mono_strong = Lazy.map f rel_mono_strong,
   4.301 -    rel_Grp = Lazy.map f rel_Grp,
   4.302 -    rel_conversep = Lazy.map f rel_conversep,
   4.303 -    rel_OO = Lazy.map f rel_OO};
   4.304 -
   4.305 -val morph_facts = map_facts o Morphism.thm;
   4.306 -
   4.307 -type nonemptiness_witness = {
   4.308 -  I: int list,
   4.309 -  wit: term,
   4.310 -  prop: thm list
   4.311 -};
   4.312 -
   4.313 -fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
   4.314 -fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
   4.315 -fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
   4.316 -
   4.317 -datatype bnf = BNF of {
   4.318 -  name: binding,
   4.319 -  T: typ,
   4.320 -  live: int,
   4.321 -  lives: typ list, (*source type variables of map*)
   4.322 -  lives': typ list, (*target type variables of map*)
   4.323 -  dead: int,
   4.324 -  deads: typ list,
   4.325 -  map: term,
   4.326 -  sets: term list,
   4.327 -  bd: term,
   4.328 -  axioms: axioms,
   4.329 -  defs: defs,
   4.330 -  facts: facts,
   4.331 -  nwits: int,
   4.332 -  wits: nonemptiness_witness list,
   4.333 -  rel: term
   4.334 -};
   4.335 -
   4.336 -(* getters *)
   4.337 -
   4.338 -fun rep_bnf (BNF bnf) = bnf;
   4.339 -val name_of_bnf = #name o rep_bnf;
   4.340 -val T_of_bnf = #T o rep_bnf;
   4.341 -fun mk_T_of_bnf Ds Ts bnf =
   4.342 -  let val bnf_rep = rep_bnf bnf
   4.343 -  in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
   4.344 -val live_of_bnf = #live o rep_bnf;
   4.345 -val lives_of_bnf = #lives o rep_bnf;
   4.346 -val dead_of_bnf = #dead o rep_bnf;
   4.347 -val deads_of_bnf = #deads o rep_bnf;
   4.348 -val axioms_of_bnf = #axioms o rep_bnf;
   4.349 -val facts_of_bnf = #facts o rep_bnf;
   4.350 -val nwits_of_bnf = #nwits o rep_bnf;
   4.351 -val wits_of_bnf = #wits o rep_bnf;
   4.352 -
   4.353 -fun flatten_type_args_of_bnf bnf dead_x xs =
   4.354 -  let
   4.355 -    val Type (_, Ts) = T_of_bnf bnf;
   4.356 -    val lives = lives_of_bnf bnf;
   4.357 -    val deads = deads_of_bnf bnf;
   4.358 -  in
   4.359 -    permute_like (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
   4.360 -  end;
   4.361 -
   4.362 -(*terms*)
   4.363 -val map_of_bnf = #map o rep_bnf;
   4.364 -val sets_of_bnf = #sets o rep_bnf;
   4.365 -fun mk_map_of_bnf Ds Ts Us bnf =
   4.366 -  let val bnf_rep = rep_bnf bnf;
   4.367 -  in
   4.368 -    Term.subst_atomic_types
   4.369 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
   4.370 -  end;
   4.371 -fun mk_sets_of_bnf Dss Tss bnf =
   4.372 -  let val bnf_rep = rep_bnf bnf;
   4.373 -  in
   4.374 -    map2 (fn (Ds, Ts) => Term.subst_atomic_types
   4.375 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
   4.376 -  end;
   4.377 -val bd_of_bnf = #bd o rep_bnf;
   4.378 -fun mk_bd_of_bnf Ds Ts bnf =
   4.379 -  let val bnf_rep = rep_bnf bnf;
   4.380 -  in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
   4.381 -fun mk_wits_of_bnf Dss Tss bnf =
   4.382 -  let
   4.383 -    val bnf_rep = rep_bnf bnf;
   4.384 -    val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
   4.385 -  in
   4.386 -    map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
   4.387 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
   4.388 -  end;
   4.389 -val rel_of_bnf = #rel o rep_bnf;
   4.390 -fun mk_rel_of_bnf Ds Ts Us bnf =
   4.391 -  let val bnf_rep = rep_bnf bnf;
   4.392 -  in
   4.393 -    Term.subst_atomic_types
   4.394 -      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
   4.395 -  end;
   4.396 -
   4.397 -(*thms*)
   4.398 -val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
   4.399 -val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
   4.400 -val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
   4.401 -val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
   4.402 -val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
   4.403 -val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
   4.404 -val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
   4.405 -val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
   4.406 -val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
   4.407 -val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
   4.408 -val map_def_of_bnf = #map_def o #defs o rep_bnf;
   4.409 -val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
   4.410 -val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
   4.411 -val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
   4.412 -val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
   4.413 -val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
   4.414 -val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
   4.415 -val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
   4.416 -val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
   4.417 -val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
   4.418 -val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
   4.419 -val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
   4.420 -val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
   4.421 -val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
   4.422 -val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
   4.423 -val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
   4.424 -val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
   4.425 -val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
   4.426 -val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
   4.427 -val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
   4.428 -val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
   4.429 -val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
   4.430 -val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
   4.431 -val wit_thms_of_bnf = maps #prop o wits_of_bnf;
   4.432 -val wit_thmss_of_bnf = map #prop o wits_of_bnf;
   4.433 -
   4.434 -fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel =
   4.435 -  BNF {name = name, T = T,
   4.436 -       live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
   4.437 -       map = map, sets = sets, bd = bd,
   4.438 -       axioms = axioms, defs = defs, facts = facts,
   4.439 -       nwits = length wits, wits = wits, rel = rel};
   4.440 -
   4.441 -fun morph_bnf phi (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
   4.442 -  dead = dead, deads = deads, map = map, sets = sets, bd = bd,
   4.443 -  axioms = axioms, defs = defs, facts = facts,
   4.444 -  nwits = nwits, wits = wits, rel = rel}) =
   4.445 -  BNF {name = Morphism.binding phi name, T = Morphism.typ phi T,
   4.446 -    live = live, lives = List.map (Morphism.typ phi) lives,
   4.447 -    lives' = List.map (Morphism.typ phi) lives',
   4.448 -    dead = dead, deads = List.map (Morphism.typ phi) deads,
   4.449 -    map = Morphism.term phi map, sets = List.map (Morphism.term phi) sets,
   4.450 -    bd = Morphism.term phi bd,
   4.451 -    axioms = morph_axioms phi axioms,
   4.452 -    defs = morph_defs phi defs,
   4.453 -    facts = morph_facts phi facts,
   4.454 -    nwits = nwits,
   4.455 -    wits = List.map (morph_witness phi) wits,
   4.456 -    rel = Morphism.term phi rel};
   4.457 -
   4.458 -fun eq_bnf (BNF {T = T1, live = live1, dead = dead1, ...},
   4.459 -  BNF {T = T2, live = live2, dead = dead2, ...}) =
   4.460 -  Type.could_unify (T1, T2) andalso live1 = live2 andalso dead1 = dead2;
   4.461 -
   4.462 -structure Data = Generic_Data
   4.463 -(
   4.464 -  type T = bnf Symtab.table;
   4.465 -  val empty = Symtab.empty;
   4.466 -  val extend = I;
   4.467 -  val merge = Symtab.merge eq_bnf;
   4.468 -);
   4.469 -
   4.470 -fun bnf_of ctxt =
   4.471 -  Symtab.lookup (Data.get (Context.Proof ctxt))
   4.472 -  #> Option.map (morph_bnf (Morphism.transfer_morphism (Proof_Context.theory_of ctxt)));
   4.473 -
   4.474 -
   4.475 -(* Utilities *)
   4.476 -
   4.477 -fun normalize_set insts instA set =
   4.478 -  let
   4.479 -    val (T, T') = dest_funT (fastype_of set);
   4.480 -    val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
   4.481 -    val params = Term.add_tvar_namesT T [];
   4.482 -  in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
   4.483 -
   4.484 -fun normalize_rel ctxt instTs instA instB rel =
   4.485 -  let
   4.486 -    val thy = Proof_Context.theory_of ctxt;
   4.487 -    val tyenv =
   4.488 -      Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
   4.489 -        Vartab.empty;
   4.490 -  in Envir.subst_term (tyenv, Vartab.empty) rel end
   4.491 -  handle Type.TYPE_MATCH => error "Bad relator";
   4.492 -
   4.493 -fun normalize_wit insts CA As wit =
   4.494 -  let
   4.495 -    fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
   4.496 -        if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
   4.497 -      | strip_param x = x;
   4.498 -    val (Ts, T) = strip_param ([], fastype_of wit);
   4.499 -    val subst = Term.add_tvar_namesT T [] ~~ insts;
   4.500 -    fun find y = find_index (fn x => x = y) As;
   4.501 -  in
   4.502 -    (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
   4.503 -  end;
   4.504 -
   4.505 -fun minimize_wits wits =
   4.506 - let
   4.507 -   fun minimize done [] = done
   4.508 -     | minimize done ((I, wit) :: todo) =
   4.509 -       if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
   4.510 -       then minimize done todo
   4.511 -       else minimize ((I, wit) :: done) todo;
   4.512 - in minimize [] wits end;
   4.513 -
   4.514 -fun mk_map live Ts Us t =
   4.515 -  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   4.516 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   4.517 -  end;
   4.518 -
   4.519 -fun mk_rel live Ts Us t =
   4.520 -  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   4.521 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   4.522 -  end;
   4.523 -
   4.524 -fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
   4.525 -  let
   4.526 -    fun build (TU as (T, U)) =
   4.527 -      if T = U then
   4.528 -        const T
   4.529 -      else
   4.530 -        (case TU of
   4.531 -          (Type (s, Ts), Type (s', Us)) =>
   4.532 -          if s = s' then
   4.533 -            let
   4.534 -              val bnf = the (bnf_of ctxt s);
   4.535 -              val live = live_of_bnf bnf;
   4.536 -              val mapx = mk live Ts Us (of_bnf bnf);
   4.537 -              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
   4.538 -            in Term.list_comb (mapx, map build TUs') end
   4.539 -          else
   4.540 -            build_simple TU
   4.541 -        | _ => build_simple TU);
   4.542 -  in build end;
   4.543 -
   4.544 -val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
   4.545 -val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
   4.546 -
   4.547 -fun map_flattened_map_args ctxt s map_args fs =
   4.548 -  let
   4.549 -    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
   4.550 -    val flat_fs' = map_args flat_fs;
   4.551 -  in
   4.552 -    permute_like (op aconv) flat_fs fs flat_fs'
   4.553 -  end;
   4.554 -
   4.555 -
   4.556 -(* Names *)
   4.557 -
   4.558 -val mapN = "map";
   4.559 -val setN = "set";
   4.560 -fun mk_setN i = setN ^ nonzero_string_of_int i;
   4.561 -val bdN = "bd";
   4.562 -val witN = "wit";
   4.563 -fun mk_witN i = witN ^ nonzero_string_of_int i;
   4.564 -val relN = "rel";
   4.565 -
   4.566 -val bd_card_orderN = "bd_card_order";
   4.567 -val bd_cinfiniteN = "bd_cinfinite";
   4.568 -val bd_Card_orderN = "bd_Card_order";
   4.569 -val bd_CinfiniteN = "bd_Cinfinite";
   4.570 -val bd_CnotzeroN = "bd_Cnotzero";
   4.571 -val collect_set_mapN = "collect_set_map";
   4.572 -val in_bdN = "in_bd";
   4.573 -val in_monoN = "in_mono";
   4.574 -val in_relN = "in_rel";
   4.575 -val map_id0N = "map_id0";
   4.576 -val map_idN = "map_id";
   4.577 -val map_comp0N = "map_comp0";
   4.578 -val map_compN = "map_comp";
   4.579 -val map_cong0N = "map_cong0";
   4.580 -val map_congN = "map_cong";
   4.581 -val map_transferN = "map_transfer";
   4.582 -val rel_eqN = "rel_eq";
   4.583 -val rel_flipN = "rel_flip";
   4.584 -val set_map0N = "set_map0";
   4.585 -val set_mapN = "set_map";
   4.586 -val set_bdN = "set_bd";
   4.587 -val rel_GrpN = "rel_Grp";
   4.588 -val rel_conversepN = "rel_conversep";
   4.589 -val rel_monoN = "rel_mono"
   4.590 -val rel_mono_strongN = "rel_mono_strong"
   4.591 -val rel_comppN = "rel_compp";
   4.592 -val rel_compp_GrpN = "rel_compp_Grp";
   4.593 -
   4.594 -datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
   4.595 -
   4.596 -datatype fact_policy = Dont_Note | Note_Some | Note_All;
   4.597 -
   4.598 -val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
   4.599 -val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
   4.600 -
   4.601 -fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
   4.602 -
   4.603 -val smart_max_inline_size = 25; (*FUDGE*)
   4.604 -
   4.605 -fun note_bnf_thms fact_policy qualify' bnf_b bnf =
   4.606 -  let
   4.607 -    val axioms = axioms_of_bnf bnf;
   4.608 -    val facts = facts_of_bnf bnf;
   4.609 -    val wits = wits_of_bnf bnf;
   4.610 -    val qualify =
   4.611 -      let val (_, qs, _) = Binding.dest bnf_b;
   4.612 -      in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify' end;
   4.613 -  in
   4.614 -    (if fact_policy = Note_All then
   4.615 -      let
   4.616 -        val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
   4.617 -        val notes =
   4.618 -          [(bd_card_orderN, [#bd_card_order axioms]),
   4.619 -            (bd_cinfiniteN, [#bd_cinfinite axioms]),
   4.620 -            (bd_Card_orderN, [#bd_Card_order facts]),
   4.621 -            (bd_CinfiniteN, [#bd_Cinfinite facts]),
   4.622 -            (bd_CnotzeroN, [#bd_Cnotzero facts]),
   4.623 -            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
   4.624 -            (in_bdN, [Lazy.force (#in_bd facts)]),
   4.625 -            (in_monoN, [Lazy.force (#in_mono facts)]),
   4.626 -            (in_relN, [Lazy.force (#in_rel facts)]),
   4.627 -            (map_comp0N, [#map_comp0 axioms]),
   4.628 -            (map_id0N, [#map_id0 axioms]),
   4.629 -            (map_transferN, [Lazy.force (#map_transfer facts)]),
   4.630 -            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)]),
   4.631 -            (set_map0N, #set_map0 axioms),
   4.632 -            (set_bdN, #set_bd axioms)] @
   4.633 -            (witNs ~~ wit_thmss_of_bnf bnf)
   4.634 -            |> map (fn (thmN, thms) =>
   4.635 -              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
   4.636 -              [(thms, [])]));
   4.637 -        in
   4.638 -          Local_Theory.notes notes #> snd
   4.639 -        end
   4.640 -      else
   4.641 -        I)
   4.642 -    #> (if fact_policy <> Dont_Note then
   4.643 -        let
   4.644 -          val notes =
   4.645 -            [(map_compN, [Lazy.force (#map_comp facts)], []),
   4.646 -            (map_cong0N, [#map_cong0 axioms], []),
   4.647 -            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
   4.648 -            (map_idN, [Lazy.force (#map_id facts)], []),
   4.649 -            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
   4.650 -            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
   4.651 -            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
   4.652 -            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
   4.653 -            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
   4.654 -            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
   4.655 -            (rel_monoN, [Lazy.force (#rel_mono facts)], []),
   4.656 -            (set_mapN, map Lazy.force (#set_map facts), [])]
   4.657 -            |> filter_out (null o #2)
   4.658 -            |> map (fn (thmN, thms, attrs) =>
   4.659 -              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
   4.660 -                attrs), [(thms, [])]));
   4.661 -        in
   4.662 -          Local_Theory.notes notes #> snd
   4.663 -        end
   4.664 -      else
   4.665 -        I)
   4.666 -  end;
   4.667 -
   4.668 -
   4.669 -(* Define new BNFs *)
   4.670 -
   4.671 -fun define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
   4.672 -  ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
   4.673 -  let
   4.674 -    val live = length set_rhss;
   4.675 -
   4.676 -    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
   4.677 -
   4.678 -    fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
   4.679 -
   4.680 -    fun maybe_define user_specified (b, rhs) lthy =
   4.681 -      let
   4.682 -        val inline =
   4.683 -          (user_specified orelse fact_policy = Dont_Note) andalso
   4.684 -          (case const_policy of
   4.685 -            Dont_Inline => false
   4.686 -          | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
   4.687 -          | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_size
   4.688 -          | Do_Inline => true)
   4.689 -      in
   4.690 -        if inline then
   4.691 -          ((rhs, Drule.reflexive_thm), lthy)
   4.692 -        else
   4.693 -          let val b = b () in
   4.694 -            apfst (apsnd snd) (Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), rhs))
   4.695 -              lthy)
   4.696 -          end
   4.697 -      end;
   4.698 -
   4.699 -    fun maybe_restore lthy_old lthy =
   4.700 -      lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
   4.701 -
   4.702 -    val map_bind_def =
   4.703 -      (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
   4.704 -         map_rhs);
   4.705 -    val set_binds_defs =
   4.706 -      let
   4.707 -        fun set_name i get_b =
   4.708 -          (case try (nth set_bs) (i - 1) of
   4.709 -            SOME b => if Binding.is_empty b then get_b else K b
   4.710 -          | NONE => get_b) #> def_qualify;
   4.711 -        val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
   4.712 -          else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
   4.713 -      in bs ~~ set_rhss end;
   4.714 -    val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
   4.715 -
   4.716 -    val ((((bnf_map_term, raw_map_def),
   4.717 -      (bnf_set_terms, raw_set_defs)),
   4.718 -      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
   4.719 -        no_defs_lthy
   4.720 -        |> maybe_define true map_bind_def
   4.721 -        ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
   4.722 -        ||>> maybe_define true bd_bind_def
   4.723 -        ||> `(maybe_restore no_defs_lthy);
   4.724 -
   4.725 -    val phi = Proof_Context.export_morphism lthy_old lthy;
   4.726 -
   4.727 -
   4.728 -    val bnf_map_def = Morphism.thm phi raw_map_def;
   4.729 -    val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
   4.730 -    val bnf_bd_def = Morphism.thm phi raw_bd_def;
   4.731 -
   4.732 -    val bnf_map = Morphism.term phi bnf_map_term;
   4.733 -
   4.734 -    (*TODO: handle errors*)
   4.735 -    (*simple shape analysis of a map function*)
   4.736 -    val ((alphas, betas), (Calpha, _)) =
   4.737 -      fastype_of bnf_map
   4.738 -      |> strip_typeN live
   4.739 -      |>> map_split dest_funT
   4.740 -      ||> dest_funT
   4.741 -      handle TYPE _ => error "Bad map function";
   4.742 -
   4.743 -    val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
   4.744 -
   4.745 -    val bnf_T = Morphism.typ phi T_rhs;
   4.746 -    val bad_args = Term.add_tfreesT bnf_T [];
   4.747 -    val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
   4.748 -      commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
   4.749 -
   4.750 -    val bnf_sets =
   4.751 -      map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
   4.752 -    val bnf_bd =
   4.753 -      Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
   4.754 -        (Morphism.term phi bnf_bd_term);
   4.755 -
   4.756 -    (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
   4.757 -    val deads = (case Ds_opt of
   4.758 -      NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
   4.759 -    | SOME Ds => map (Morphism.typ phi) Ds);
   4.760 -
   4.761 -    (*TODO: further checks of type of bnf_map*)
   4.762 -    (*TODO: check types of bnf_sets*)
   4.763 -    (*TODO: check type of bnf_bd*)
   4.764 -    (*TODO: check type of bnf_rel*)
   4.765 -
   4.766 -    fun mk_bnf_map Ds As' Bs' =
   4.767 -      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
   4.768 -    fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
   4.769 -    fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
   4.770 -
   4.771 -    val (((As, Bs), Ds), names_lthy) = lthy
   4.772 -      |> mk_TFrees live
   4.773 -      ||>> mk_TFrees live
   4.774 -      ||>> mk_TFrees (length deads);
   4.775 -    val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
   4.776 -    val pred2RTs = map2 mk_pred2T As Bs;
   4.777 -    val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst
   4.778 -    val CA = mk_bnf_T Ds As Calpha;
   4.779 -    val CR = mk_bnf_T Ds RTs Calpha;
   4.780 -    val setRs =
   4.781 -      map3 (fn R => fn T => fn U =>
   4.782 -          HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split R) Rs As Bs;
   4.783 -
   4.784 -    (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
   4.785 -      Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
   4.786 -    val OO_Grp =
   4.787 -      let
   4.788 -        val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
   4.789 -        val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
   4.790 -        val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
   4.791 -      in
   4.792 -        mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
   4.793 -        |> fold_rev Term.absfree Rs'
   4.794 -      end;
   4.795 -
   4.796 -    val rel_rhs = the_default OO_Grp rel_rhs_opt;
   4.797 -
   4.798 -    val rel_bind_def =
   4.799 -      (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
   4.800 -         rel_rhs);
   4.801 -
   4.802 -    val wit_rhss =
   4.803 -      if null wit_rhss then
   4.804 -        [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
   4.805 -          map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
   4.806 -          Const (@{const_name undefined}, CA))]
   4.807 -      else wit_rhss;
   4.808 -    val nwits = length wit_rhss;
   4.809 -    val wit_binds_defs =
   4.810 -      let
   4.811 -        val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
   4.812 -          else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
   4.813 -      in bs ~~ wit_rhss end;
   4.814 -
   4.815 -    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
   4.816 -      lthy
   4.817 -      |> maybe_define (is_some rel_rhs_opt) rel_bind_def
   4.818 -      ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
   4.819 -      ||> `(maybe_restore lthy);
   4.820 -
   4.821 -    val phi = Proof_Context.export_morphism lthy_old lthy;
   4.822 -    val bnf_rel_def = Morphism.thm phi raw_rel_def;
   4.823 -    val bnf_rel = Morphism.term phi bnf_rel_term;
   4.824 -    fun mk_bnf_rel Ds As' Bs' =
   4.825 -      normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
   4.826 -        bnf_rel;
   4.827 -
   4.828 -    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
   4.829 -    val bnf_wits =
   4.830 -      map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
   4.831 -
   4.832 -    fun mk_OO_Grp Ds' As' Bs' =
   4.833 -      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
   4.834 -  in
   4.835 -    (((alphas, betas, deads, Calpha),
   4.836 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
   4.837 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
   4.838 -     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
   4.839 -  end;
   4.840 -
   4.841 -fun prepare_def const_policy mk_fact_policy qualify prep_typ prep_term Ds_opt map_b rel_b set_bs
   4.842 -  ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
   4.843 -  no_defs_lthy =
   4.844 -  let
   4.845 -    val fact_policy = mk_fact_policy no_defs_lthy;
   4.846 -    val bnf_b = qualify raw_bnf_b;
   4.847 -    val live = length raw_sets;
   4.848 -
   4.849 -    val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
   4.850 -    val map_rhs = prep_term no_defs_lthy raw_map;
   4.851 -    val set_rhss = map (prep_term no_defs_lthy) raw_sets;
   4.852 -    val bd_rhs = prep_term no_defs_lthy raw_bd;
   4.853 -    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
   4.854 -    val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
   4.855 -
   4.856 -    fun err T =
   4.857 -      error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
   4.858 -        " as unnamed BNF");
   4.859 -
   4.860 -    val (bnf_b, key) =
   4.861 -      if Binding.eq_name (bnf_b, Binding.empty) then
   4.862 -        (case T_rhs of
   4.863 -          Type (C, Ts) => if forall (can dest_TFree) Ts
   4.864 -            then (Binding.qualified_name C, C) else err T_rhs
   4.865 -        | T => err T)
   4.866 -      else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
   4.867 -
   4.868 -    val (((alphas, betas, deads, Calpha),
   4.869 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
   4.870 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
   4.871 -     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
   4.872 -       define_bnf_consts const_policy fact_policy Ds_opt map_b rel_b set_bs
   4.873 -         ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
   4.874 -
   4.875 -    val dead = length deads;
   4.876 -
   4.877 -    val ((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), (Ts, T)) = lthy
   4.878 -      |> mk_TFrees live
   4.879 -      ||>> mk_TFrees live
   4.880 -      ||>> mk_TFrees live
   4.881 -      ||>> mk_TFrees dead
   4.882 -      ||>> mk_TFrees live
   4.883 -      ||>> mk_TFrees live
   4.884 -      ||> fst o mk_TFrees 1
   4.885 -      ||> the_single
   4.886 -      ||> `(replicate live);
   4.887 -
   4.888 -    val mk_bnf_map = mk_bnf_map_Ds Ds;
   4.889 -    val mk_bnf_t = mk_bnf_t_Ds Ds;
   4.890 -    val mk_bnf_T = mk_bnf_T_Ds Ds;
   4.891 -
   4.892 -    val pred2RTs = map2 mk_pred2T As' Bs';
   4.893 -    val pred2RTsAsCs = map2 mk_pred2T As' Cs;
   4.894 -    val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
   4.895 -    val pred2RT's = map2 mk_pred2T Bs' As';
   4.896 -    val self_pred2RTs = map2 mk_pred2T As' As';
   4.897 -    val transfer_domRTs = map2 mk_pred2T As' B1Ts;
   4.898 -    val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
   4.899 -
   4.900 -    val CA' = mk_bnf_T As' Calpha;
   4.901 -    val CB' = mk_bnf_T Bs' Calpha;
   4.902 -    val CC' = mk_bnf_T Cs Calpha;
   4.903 -    val CB1 = mk_bnf_T B1Ts Calpha;
   4.904 -    val CB2 = mk_bnf_T B2Ts Calpha;
   4.905 -
   4.906 -    val bnf_map_AsAs = mk_bnf_map As' As';
   4.907 -    val bnf_map_AsBs = mk_bnf_map As' Bs';
   4.908 -    val bnf_map_AsCs = mk_bnf_map As' Cs;
   4.909 -    val bnf_map_BsCs = mk_bnf_map Bs' Cs;
   4.910 -    val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
   4.911 -    val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
   4.912 -    val bnf_bd_As = mk_bnf_t As' bnf_bd;
   4.913 -    fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
   4.914 -
   4.915 -    val pre_names_lthy = lthy;
   4.916 -    val (((((((((((((((fs, gs), hs), x), y), zs), ys), As),
   4.917 -      As_copy), bs), Rs), Rs_copy), Ss),
   4.918 -      transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
   4.919 -      |> mk_Frees "f" (map2 (curry op -->) As' Bs')
   4.920 -      ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
   4.921 -      ||>> mk_Frees "h" (map2 (curry op -->) As' Ts)
   4.922 -      ||>> yield_singleton (mk_Frees "x") CA'
   4.923 -      ||>> yield_singleton (mk_Frees "y") CB'
   4.924 -      ||>> mk_Frees "z" As'
   4.925 -      ||>> mk_Frees "y" Bs'
   4.926 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
   4.927 -      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
   4.928 -      ||>> mk_Frees "b" As'
   4.929 -      ||>> mk_Frees "R" pred2RTs
   4.930 -      ||>> mk_Frees "R" pred2RTs
   4.931 -      ||>> mk_Frees "S" pred2RTsBsCs
   4.932 -      ||>> mk_Frees "R" transfer_domRTs
   4.933 -      ||>> mk_Frees "S" transfer_ranRTs;
   4.934 -
   4.935 -    val fs_copy = map2 (retype_free o fastype_of) fs gs;
   4.936 -    val x_copy = retype_free CA' y;
   4.937 -
   4.938 -    val rel = mk_bnf_rel pred2RTs CA' CB';
   4.939 -    val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
   4.940 -    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
   4.941 -
   4.942 -    val map_id0_goal =
   4.943 -      let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
   4.944 -        mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
   4.945 -      end;
   4.946 -
   4.947 -    val map_comp0_goal =
   4.948 -      let
   4.949 -        val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
   4.950 -        val comp_bnf_map_app = HOLogic.mk_comp
   4.951 -          (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
   4.952 -      in
   4.953 -        fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
   4.954 -      end;
   4.955 -
   4.956 -    fun mk_map_cong_prem x z set f f_copy =
   4.957 -      Logic.all z (Logic.mk_implies
   4.958 -        (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
   4.959 -        mk_Trueprop_eq (f $ z, f_copy $ z)));
   4.960 -
   4.961 -    val map_cong0_goal =
   4.962 -      let
   4.963 -        val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy;
   4.964 -        val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
   4.965 -          Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
   4.966 -      in
   4.967 -        fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
   4.968 -      end;
   4.969 -
   4.970 -    val set_map0s_goal =
   4.971 -      let
   4.972 -        fun mk_goal setA setB f =
   4.973 -          let
   4.974 -            val set_comp_map =
   4.975 -              HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
   4.976 -            val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
   4.977 -          in
   4.978 -            fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
   4.979 -          end;
   4.980 -      in
   4.981 -        map3 mk_goal bnf_sets_As bnf_sets_Bs fs
   4.982 -      end;
   4.983 -
   4.984 -    val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
   4.985 -
   4.986 -    val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
   4.987 -
   4.988 -    val set_bds_goal =
   4.989 -      let
   4.990 -        fun mk_goal set =
   4.991 -          Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
   4.992 -      in
   4.993 -        map mk_goal bnf_sets_As
   4.994 -      end;
   4.995 -
   4.996 -    val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
   4.997 -    val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
   4.998 -    val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
   4.999 -    val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
  4.1000 -    val le_rel_OO_goal =
  4.1001 -      fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
  4.1002 -
  4.1003 -    val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
  4.1004 -      Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
  4.1005 -
  4.1006 -    val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
  4.1007 -      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
  4.1008 -
  4.1009 -    fun mk_wit_goals (I, wit) =
  4.1010 -      let
  4.1011 -        val xs = map (nth bs) I;
  4.1012 -        fun wit_goal i =
  4.1013 -          let
  4.1014 -            val z = nth zs i;
  4.1015 -            val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
  4.1016 -            val concl = HOLogic.mk_Trueprop
  4.1017 -              (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
  4.1018 -              else @{term False});
  4.1019 -          in
  4.1020 -            fold_rev Logic.all (z :: xs)
  4.1021 -              (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
  4.1022 -          end;
  4.1023 -      in
  4.1024 -        map wit_goal (0 upto live - 1)
  4.1025 -      end;
  4.1026 -
  4.1027 -    val triv_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
  4.1028 -
  4.1029 -    val wit_goalss =
  4.1030 -      (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
  4.1031 -
  4.1032 -    fun after_qed mk_wit_thms thms lthy =
  4.1033 -      let
  4.1034 -        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  4.1035 -
  4.1036 -        val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
  4.1037 -        val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
  4.1038 -        val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
  4.1039 -
  4.1040 -        fun mk_collect_set_map () =
  4.1041 -          let
  4.1042 -            val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
  4.1043 -            val collect_map = HOLogic.mk_comp
  4.1044 -              (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
  4.1045 -              Term.list_comb (mk_bnf_map As' Ts, hs));
  4.1046 -            val image_collect = mk_collect
  4.1047 -              (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
  4.1048 -              defT;
  4.1049 -            (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
  4.1050 -            val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
  4.1051 -          in
  4.1052 -            Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map0 axioms)))
  4.1053 -            |> Thm.close_derivation
  4.1054 -          end;
  4.1055 -
  4.1056 -        val collect_set_map = Lazy.lazy mk_collect_set_map;
  4.1057 -
  4.1058 -        fun mk_in_mono () =
  4.1059 -          let
  4.1060 -            val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
  4.1061 -            val in_mono_goal =
  4.1062 -              fold_rev Logic.all (As @ As_copy)
  4.1063 -                (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
  4.1064 -                  (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
  4.1065 -          in
  4.1066 -            Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
  4.1067 -            |> Thm.close_derivation
  4.1068 -          end;
  4.1069 -
  4.1070 -        val in_mono = Lazy.lazy mk_in_mono;
  4.1071 -
  4.1072 -        fun mk_in_cong () =
  4.1073 -          let
  4.1074 -            val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
  4.1075 -            val in_cong_goal =
  4.1076 -              fold_rev Logic.all (As @ As_copy)
  4.1077 -                (Logic.list_implies (prems_cong,
  4.1078 -                  mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
  4.1079 -          in
  4.1080 -            Goal.prove_sorry lthy [] [] in_cong_goal
  4.1081 -              (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
  4.1082 -            |> Thm.close_derivation
  4.1083 -          end;
  4.1084 -
  4.1085 -        val in_cong = Lazy.lazy mk_in_cong;
  4.1086 -
  4.1087 -        val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
  4.1088 -        val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
  4.1089 -
  4.1090 -        fun mk_map_cong () =
  4.1091 -          let
  4.1092 -            val prem0 = mk_Trueprop_eq (x, x_copy);
  4.1093 -            val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy;
  4.1094 -            val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  4.1095 -              Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
  4.1096 -            val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
  4.1097 -              (Logic.list_implies (prem0 :: prems, eq));
  4.1098 -          in
  4.1099 -            Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms))
  4.1100 -            |> Thm.close_derivation
  4.1101 -          end;
  4.1102 -
  4.1103 -        val map_cong = Lazy.lazy mk_map_cong;
  4.1104 -
  4.1105 -        val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
  4.1106 -
  4.1107 -        val wit_thms =
  4.1108 -          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
  4.1109 -
  4.1110 -        fun mk_in_bd () =
  4.1111 -          let
  4.1112 -            val bdT = fst (dest_relT (fastype_of bnf_bd_As));
  4.1113 -            val bdTs = replicate live bdT;
  4.1114 -            val bd_bnfT = mk_bnf_T bdTs Calpha;
  4.1115 -            val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
  4.1116 -              let
  4.1117 -                val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
  4.1118 -                val funTs = map (fn T => bdT --> T) ranTs;
  4.1119 -                val ran_bnfT = mk_bnf_T ranTs Calpha;
  4.1120 -                val (revTs, Ts) = `rev (bd_bnfT :: funTs);
  4.1121 -                val cTs = map (SOME o certifyT lthy) [ran_bnfT, Library.foldr1 HOLogic.mk_prodT Ts];
  4.1122 -                val tinst = fold (fn T => fn t => HOLogic.mk_split (Term.absdummy T t)) (tl revTs)
  4.1123 -                  (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
  4.1124 -                    map Bound (live - 1 downto 0)) $ Bound live));
  4.1125 -                val cts = [NONE, SOME (certify lthy tinst)];
  4.1126 -              in
  4.1127 -                Drule.instantiate' cTs cts @{thm surj_imp_ordLeq}
  4.1128 -              end);
  4.1129 -            val bd = mk_cexp
  4.1130 -              (if live = 0 then ctwo
  4.1131 -                else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
  4.1132 -              (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
  4.1133 -            val in_bd_goal =
  4.1134 -              fold_rev Logic.all As
  4.1135 -                (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
  4.1136 -          in
  4.1137 -            Goal.prove_sorry lthy [] [] in_bd_goal
  4.1138 -              (mk_in_bd_tac live surj_imp_ordLeq_inst
  4.1139 -                (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
  4.1140 -                (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
  4.1141 -                bd_Card_order bd_Cinfinite bd_Cnotzero)
  4.1142 -            |> Thm.close_derivation
  4.1143 -          end;
  4.1144 -
  4.1145 -        val in_bd = Lazy.lazy mk_in_bd;
  4.1146 -
  4.1147 -        val rel_OO_Grp = #rel_OO_Grp axioms;
  4.1148 -        val rel_OO_Grps = no_refl [rel_OO_Grp];
  4.1149 -
  4.1150 -        fun mk_rel_Grp () =
  4.1151 -          let
  4.1152 -            val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
  4.1153 -            val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
  4.1154 -            val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
  4.1155 -          in
  4.1156 -            Goal.prove_sorry lthy [] [] goal
  4.1157 -              (mk_rel_Grp_tac rel_OO_Grps (#map_id0 axioms) (#map_cong0 axioms) (Lazy.force map_id)
  4.1158 -                (Lazy.force map_comp) (map Lazy.force set_map))
  4.1159 -            |> Thm.close_derivation
  4.1160 -          end;
  4.1161 -
  4.1162 -        val rel_Grp = Lazy.lazy mk_rel_Grp;
  4.1163 -
  4.1164 -        fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
  4.1165 -        fun mk_rel_concl f = HOLogic.mk_Trueprop
  4.1166 -          (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
  4.1167 -
  4.1168 -        fun mk_rel_mono () =
  4.1169 -          let
  4.1170 -            val mono_prems = mk_rel_prems mk_leq;
  4.1171 -            val mono_concl = mk_rel_concl (uncurry mk_leq);
  4.1172 -          in
  4.1173 -            Goal.prove_sorry lthy [] []
  4.1174 -              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
  4.1175 -              (K (mk_rel_mono_tac rel_OO_Grps (Lazy.force in_mono)))
  4.1176 -            |> Thm.close_derivation
  4.1177 -          end;
  4.1178 -
  4.1179 -        fun mk_rel_cong () =
  4.1180 -          let
  4.1181 -            val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
  4.1182 -            val cong_concl = mk_rel_concl HOLogic.mk_eq;
  4.1183 -          in
  4.1184 -            Goal.prove_sorry lthy [] []
  4.1185 -              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
  4.1186 -              (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
  4.1187 -            |> Thm.close_derivation
  4.1188 -          end;
  4.1189 -
  4.1190 -        val rel_mono = Lazy.lazy mk_rel_mono;
  4.1191 -        val rel_cong = Lazy.lazy mk_rel_cong;
  4.1192 -
  4.1193 -        fun mk_rel_eq () =
  4.1194 -          Goal.prove_sorry lthy [] []
  4.1195 -            (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
  4.1196 -              HOLogic.eq_const CA'))
  4.1197 -            (K (mk_rel_eq_tac live (Lazy.force rel_Grp) (Lazy.force rel_cong) (#map_id0 axioms)))
  4.1198 -          |> Thm.close_derivation;
  4.1199 -
  4.1200 -        val rel_eq = Lazy.lazy mk_rel_eq;
  4.1201 -
  4.1202 -        fun mk_rel_conversep () =
  4.1203 -          let
  4.1204 -            val relBsAs = mk_bnf_rel pred2RT's CB' CA';
  4.1205 -            val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
  4.1206 -            val rhs = mk_conversep (Term.list_comb (rel, Rs));
  4.1207 -            val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
  4.1208 -            val le_thm = Goal.prove_sorry lthy [] [] le_goal
  4.1209 -              (mk_rel_conversep_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
  4.1210 -                (Lazy.force map_comp) (map Lazy.force set_map))
  4.1211 -              |> Thm.close_derivation
  4.1212 -            val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
  4.1213 -          in
  4.1214 -            Goal.prove_sorry lthy [] [] goal
  4.1215 -              (K (mk_rel_conversep_tac le_thm (Lazy.force rel_mono)))
  4.1216 -            |> Thm.close_derivation
  4.1217 -          end;
  4.1218 -
  4.1219 -        val rel_conversep = Lazy.lazy mk_rel_conversep;
  4.1220 -
  4.1221 -        fun mk_rel_OO () =
  4.1222 -          Goal.prove_sorry lthy [] []
  4.1223 -            (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
  4.1224 -            (mk_rel_OO_le_tac rel_OO_Grps (Lazy.force rel_eq) (#map_cong0 axioms)
  4.1225 -              (Lazy.force map_comp) (map Lazy.force set_map))
  4.1226 -          |> Thm.close_derivation
  4.1227 -          |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
  4.1228 -
  4.1229 -        val rel_OO = Lazy.lazy mk_rel_OO;
  4.1230 -
  4.1231 -        fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
  4.1232 -
  4.1233 -        val in_rel = Lazy.lazy mk_in_rel;
  4.1234 -
  4.1235 -        fun mk_rel_flip () =
  4.1236 -          let
  4.1237 -            val rel_conversep_thm = Lazy.force rel_conversep;
  4.1238 -            val cts = map (SOME o certify lthy) Rs;
  4.1239 -            val rel_conversep_thm' = cterm_instantiate_pos cts rel_conversep_thm;
  4.1240 -          in
  4.1241 -            unfold_thms lthy @{thms conversep_iff} (rel_conversep_thm' RS @{thm predicate2_eqD})
  4.1242 -            |> singleton (Proof_Context.export names_lthy pre_names_lthy)
  4.1243 -          end;
  4.1244 -
  4.1245 -        val rel_flip = Lazy.lazy mk_rel_flip;
  4.1246 -
  4.1247 -        fun mk_rel_mono_strong () =
  4.1248 -          let
  4.1249 -            fun mk_prem setA setB R S a b =
  4.1250 -              HOLogic.mk_Trueprop
  4.1251 -                (mk_Ball (setA $ x) (Term.absfree (dest_Free a)
  4.1252 -                  (mk_Ball (setB $ y) (Term.absfree (dest_Free b)
  4.1253 -                    (HOLogic.mk_imp (R $ a $ b, S $ a $ b))))));
  4.1254 -            val prems = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs) $ x $ y) :: 
  4.1255 -              map6 mk_prem bnf_sets_As bnf_sets_Bs Rs Rs_copy zs ys;
  4.1256 -            val concl = HOLogic.mk_Trueprop (Term.list_comb (rel, Rs_copy) $ x $ y);
  4.1257 -          in
  4.1258 -            Goal.prove_sorry lthy [] []
  4.1259 -              (fold_rev Logic.all (x :: y :: Rs @ Rs_copy) (Logic.list_implies (prems, concl)))
  4.1260 -              (mk_rel_mono_strong_tac (Lazy.force in_rel) (map Lazy.force set_map))
  4.1261 -            |> Thm.close_derivation
  4.1262 -          end;
  4.1263 -
  4.1264 -        val rel_mono_strong = Lazy.lazy mk_rel_mono_strong;
  4.1265 -
  4.1266 -        fun mk_map_transfer () =
  4.1267 -          let
  4.1268 -            val rels = map2 mk_fun_rel transfer_domRs transfer_ranRs;
  4.1269 -            val rel = mk_fun_rel
  4.1270 -              (Term.list_comb (mk_bnf_rel transfer_domRTs CA' CB1, transfer_domRs))
  4.1271 -              (Term.list_comb (mk_bnf_rel transfer_ranRTs CB' CB2, transfer_ranRs));
  4.1272 -            val concl = HOLogic.mk_Trueprop
  4.1273 -              (fold_rev mk_fun_rel rels rel $ bnf_map_AsBs $ mk_bnf_map B1Ts B2Ts);
  4.1274 -          in
  4.1275 -            Goal.prove_sorry lthy [] []
  4.1276 -              (fold_rev Logic.all (transfer_domRs @ transfer_ranRs) concl)
  4.1277 -              (mk_map_transfer_tac (Lazy.force rel_mono) (Lazy.force in_rel)
  4.1278 -                (map Lazy.force set_map) (#map_cong0 axioms) (Lazy.force map_comp))
  4.1279 -            |> Thm.close_derivation
  4.1280 -          end;
  4.1281 -
  4.1282 -        val map_transfer = Lazy.lazy mk_map_transfer;
  4.1283 -
  4.1284 -        val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def;
  4.1285 -
  4.1286 -        val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
  4.1287 -          in_mono in_rel map_comp map_cong map_id map_transfer rel_eq rel_flip set_map
  4.1288 -          rel_cong rel_mono rel_mono_strong rel_Grp rel_conversep rel_OO;
  4.1289 -
  4.1290 -        val wits = map2 mk_witness bnf_wits wit_thms;
  4.1291 -
  4.1292 -        val bnf_rel =
  4.1293 -          Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
  4.1294 -
  4.1295 -        val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
  4.1296 -          defs facts wits bnf_rel;
  4.1297 -      in
  4.1298 -        (bnf, lthy |> note_bnf_thms fact_policy qualify bnf_b bnf)
  4.1299 -      end;
  4.1300 -
  4.1301 -    val one_step_defs =
  4.1302 -      no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def]);
  4.1303 -  in
  4.1304 -    (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
  4.1305 -  end;
  4.1306 -
  4.1307 -fun register_bnf key (bnf, lthy) =
  4.1308 -  (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
  4.1309 -    (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
  4.1310 -
  4.1311 -fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
  4.1312 -  (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
  4.1313 -  let
  4.1314 -    fun mk_wits_tac set_maps =
  4.1315 -      K (TRYALL Goal.conjunction_tac) THEN'
  4.1316 -      (case triv_tac_opt of
  4.1317 -        SOME tac => tac set_maps
  4.1318 -      | NONE => fn {context = ctxt, prems} =>
  4.1319 -          unfold_thms_tac ctxt one_step_defs THEN wit_tac {context = ctxt, prems = prems});
  4.1320 -    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  4.1321 -    fun mk_wit_thms set_maps =
  4.1322 -      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
  4.1323 -        |> Conjunction.elim_balanced (length wit_goals)
  4.1324 -        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  4.1325 -        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  4.1326 -  in
  4.1327 -    map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  4.1328 -      goals (map (fn tac => fn {context = ctxt, prems} =>
  4.1329 -        unfold_thms_tac ctxt one_step_defs THEN tac {context = ctxt, prems = prems}) tacs)
  4.1330 -    |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
  4.1331 -  end) oo prepare_def const_policy fact_policy qualify (K I) (K I) Ds map_b rel_b set_bs;
  4.1332 -
  4.1333 -val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
  4.1334 -  let
  4.1335 -    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  4.1336 -    fun mk_triv_wit_thms tac set_maps =
  4.1337 -      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  4.1338 -        (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
  4.1339 -        |> Conjunction.elim_balanced (length wit_goals)
  4.1340 -        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  4.1341 -        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  4.1342 -    val (mk_wit_thms, nontriv_wit_goals) = 
  4.1343 -      (case triv_tac_opt of
  4.1344 -        NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
  4.1345 -      | SOME tac => (mk_triv_wit_thms tac, []));
  4.1346 -  in
  4.1347 -    Proof.unfolding ([[(defs, [])]])
  4.1348 -      (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
  4.1349 -        (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
  4.1350 -  end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_typ Syntax.read_term NONE
  4.1351 -    Binding.empty Binding.empty [];
  4.1352 -
  4.1353 -fun print_bnfs ctxt =
  4.1354 -  let
  4.1355 -    fun pretty_set sets i = Pretty.block
  4.1356 -      [Pretty.str (mk_setN (i + 1) ^ ":"), Pretty.brk 1,
  4.1357 -          Pretty.quote (Syntax.pretty_term ctxt (nth sets i))];
  4.1358 -
  4.1359 -    fun pretty_bnf (key, BNF {T = T, map = map, sets = sets, bd = bd,
  4.1360 -      live = live, lives = lives, dead = dead, deads = deads, ...}) =
  4.1361 -      Pretty.big_list
  4.1362 -        (Pretty.string_of (Pretty.block [Pretty.str key, Pretty.str ":", Pretty.brk 1,
  4.1363 -          Pretty.quote (Syntax.pretty_typ ctxt T)]))
  4.1364 -        ([Pretty.block [Pretty.str "live:", Pretty.brk 1, Pretty.str (string_of_int live),
  4.1365 -            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) lives)],
  4.1366 -          Pretty.block [Pretty.str "dead:", Pretty.brk 1, Pretty.str (string_of_int dead),
  4.1367 -            Pretty.brk 3, Pretty.list "[" "]" (List.map (Syntax.pretty_typ ctxt) deads)],
  4.1368 -          Pretty.block [Pretty.str (mapN ^ ":"), Pretty.brk 1,
  4.1369 -            Pretty.quote (Syntax.pretty_term ctxt map)]] @
  4.1370 -          List.map (pretty_set sets) (0 upto length sets - 1) @
  4.1371 -          [Pretty.block [Pretty.str (bdN ^ ":"), Pretty.brk 1,
  4.1372 -            Pretty.quote (Syntax.pretty_term ctxt bd)]]);
  4.1373 -  in
  4.1374 -    Pretty.big_list "BNFs:" (map pretty_bnf (Symtab.dest (Data.get (Context.Proof ctxt))))
  4.1375 -    |> Pretty.writeln
  4.1376 -  end;
  4.1377 -
  4.1378 -val _ =
  4.1379 -  Outer_Syntax.improper_command @{command_spec "print_bnfs"}
  4.1380 -    "print all bounded natural functors"
  4.1381 -    (Scan.succeed (Toplevel.keep (print_bnfs o Toplevel.context_of)));
  4.1382 -
  4.1383 -val _ =
  4.1384 -  Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
  4.1385 -    "register a type as a bounded natural functor"
  4.1386 -    (parse_opt_binding_colon -- Parse.typ --|
  4.1387 -       (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
  4.1388 -       (Scan.option ((Parse.reserved "sets" -- @{keyword ":"}) |--
  4.1389 -         Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) >> the_default []) --|
  4.1390 -       (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
  4.1391 -       (Scan.option ((Parse.reserved "wits" -- @{keyword ":"}) |--
  4.1392 -         Scan.repeat1 (Scan.unless (Parse.reserved "rel") Parse.term)) >> the_default []) --
  4.1393 -       Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term)
  4.1394 -       >> bnf_cmd);
  4.1395 -
  4.1396 -end;
     5.1 --- a/src/HOL/Tools/BNF/Tools/bnf_def_tactics.ML	Mon Jan 20 18:24:56 2014 +0100
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,284 +0,0 @@
     5.4 -(*  Title:      HOL/BNF/Tools/bnf_def_tactics.ML
     5.5 -    Author:     Dmitriy Traytel, TU Muenchen
     5.6 -    Author:     Jasmin Blanchette, TU Muenchen
     5.7 -    Copyright   2012
     5.8 -
     5.9 -Tactics for definition of bounded natural functors.
    5.10 -*)
    5.11 -
    5.12 -signature BNF_DEF_TACTICS =
    5.13 -sig
    5.14 -  val mk_collect_set_map_tac: thm list -> tactic
    5.15 -  val mk_map_id: thm -> thm
    5.16 -  val mk_map_comp: thm -> thm
    5.17 -  val mk_map_cong_tac: Proof.context -> thm -> tactic
    5.18 -  val mk_in_mono_tac: int -> tactic
    5.19 -  val mk_set_map: thm -> thm
    5.20 -
    5.21 -  val mk_rel_Grp_tac: thm list -> thm -> thm -> thm -> thm -> thm list ->
    5.22 -    {prems: thm list, context: Proof.context} -> tactic
    5.23 -  val mk_rel_eq_tac: int -> thm -> thm -> thm -> tactic
    5.24 -  val mk_rel_OO_le_tac: thm list -> thm -> thm -> thm -> thm list ->
    5.25 -    {prems: thm list, context: Proof.context} -> tactic
    5.26 -  val mk_rel_conversep_tac: thm -> thm -> tactic
    5.27 -  val mk_rel_conversep_le_tac: thm list -> thm -> thm -> thm -> thm list ->
    5.28 -    {prems: thm list, context: Proof.context} -> tactic
    5.29 -  val mk_rel_mono_tac: thm list -> thm -> tactic
    5.30 -  val mk_rel_mono_strong_tac: thm -> thm list -> {prems: 'a, context: Proof.context} -> tactic
    5.31 -
    5.32 -  val mk_map_transfer_tac: thm -> thm -> thm list -> thm -> thm ->
    5.33 -    {prems: thm list, context: Proof.context} -> tactic
    5.34 -
    5.35 -  val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
    5.36 -    thm -> {prems: thm list, context: Proof.context} -> tactic
    5.37 -
    5.38 -  val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
    5.39 -    tactic
    5.40 -end;
    5.41 -
    5.42 -structure BNF_Def_Tactics : BNF_DEF_TACTICS =
    5.43 -struct
    5.44 -
    5.45 -open BNF_Util
    5.46 -open BNF_Tactics
    5.47 -
    5.48 -val ord_eq_le_trans = @{thm ord_eq_le_trans};
    5.49 -val ord_le_eq_trans = @{thm ord_le_eq_trans};
    5.50 -val conversep_shift = @{thm conversep_le_swap} RS iffD1;
    5.51 -
    5.52 -fun mk_map_id id = mk_trans (fun_cong OF [id]) @{thm id_apply};
    5.53 -fun mk_map_comp comp = @{thm o_eq_dest_lhs} OF [mk_sym comp];
    5.54 -fun mk_map_cong_tac ctxt cong0 =
    5.55 -  (hyp_subst_tac ctxt THEN' rtac cong0 THEN'
    5.56 -   REPEAT_DETERM o (dtac meta_spec THEN' etac meta_mp THEN' atac)) 1;
    5.57 -fun mk_set_map set_map0 = set_map0 RS @{thm comp_eq_dest};
    5.58 -fun mk_in_mono_tac n = if n = 0 then rtac subset_UNIV 1
    5.59 -  else (rtac subsetI THEN'
    5.60 -  rtac CollectI) 1 THEN
    5.61 -  REPEAT_DETERM (eresolve_tac [CollectE, conjE] 1) THEN
    5.62 -  REPEAT_DETERM_N (n - 1)
    5.63 -    ((rtac conjI THEN' etac subset_trans THEN' atac) 1) THEN
    5.64 -  (etac subset_trans THEN' atac) 1;
    5.65 -
    5.66 -fun mk_collect_set_map_tac set_map0s =
    5.67 -  (rtac (@{thm collect_o} RS trans) THEN' rtac @{thm arg_cong[of _ _ collect]} THEN'
    5.68 -  EVERY' (map (fn set_map0 =>
    5.69 -    rtac (mk_trans @{thm image_insert} @{thm arg_cong2[of _ _ _ _ insert]}) THEN'
    5.70 -    rtac set_map0) set_map0s) THEN'
    5.71 -  rtac @{thm image_empty}) 1;
    5.72 -
    5.73 -fun mk_rel_Grp_tac rel_OO_Grps map_id0 map_cong0 map_id map_comp set_maps
    5.74 -  {context = ctxt, prems = _} =
    5.75 -  let
    5.76 -    val n = length set_maps;
    5.77 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac else rtac (hd rel_OO_Grps RS trans);
    5.78 -  in
    5.79 -    if null set_maps then
    5.80 -      unfold_thms_tac ctxt ((map_id0 RS @{thm Grp_UNIV_id}) :: rel_OO_Grps) THEN
    5.81 -      rtac @{thm Grp_UNIV_idI[OF refl]} 1
    5.82 -    else
    5.83 -      EVERY' [rel_OO_Grps_tac, rtac @{thm antisym}, rtac @{thm predicate2I},
    5.84 -        REPEAT_DETERM o
    5.85 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
    5.86 -        hyp_subst_tac ctxt, rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
    5.87 -        REPEAT_DETERM_N n o EVERY' [rtac @{thm Collect_split_Grp_eqD}, etac @{thm set_mp}, atac],
    5.88 -        rtac CollectI,
    5.89 -        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
    5.90 -          rtac @{thm image_subsetI}, rtac @{thm Collect_split_Grp_inD}, etac @{thm set_mp}, atac])
    5.91 -        set_maps,
    5.92 -        rtac @{thm predicate2I}, REPEAT_DETERM o eresolve_tac [@{thm GrpE}, exE, conjE],
    5.93 -        hyp_subst_tac ctxt,
    5.94 -        rtac @{thm relcomppI}, rtac @{thm conversepI},
    5.95 -        EVERY' (map2 (fn convol => fn map_id0 =>
    5.96 -          EVERY' [rtac @{thm GrpI}, rtac (box_equals OF [map_cong0, map_comp RS sym, map_id0]),
    5.97 -            REPEAT_DETERM_N n o rtac (convol RS fun_cong),
    5.98 -            REPEAT_DETERM o eresolve_tac [CollectE, conjE],
    5.99 -            rtac CollectI,
   5.100 -            CONJ_WRAP' (fn thm =>
   5.101 -              EVERY' [rtac ord_eq_le_trans, rtac thm, rtac @{thm image_subsetI},
   5.102 -                rtac @{thm convol_mem_GrpI}, etac set_mp, atac])
   5.103 -            set_maps])
   5.104 -          @{thms fst_convol snd_convol} [map_id, refl])] 1
   5.105 -  end;
   5.106 -
   5.107 -fun mk_rel_eq_tac n rel_Grp rel_cong map_id0 =
   5.108 -  (EVERY' (rtac (rel_cong RS trans) :: replicate n (rtac @{thm eq_alt})) THEN'
   5.109 -  rtac (rel_Grp RSN (2, @{thm box_equals[OF _ sym sym[OF eq_alt]]})) THEN'
   5.110 -  (if n = 0 then rtac refl
   5.111 -  else EVERY' [rtac @{thm arg_cong2[of _ _ _ _ "Grp"]},
   5.112 -    rtac @{thm equalityI}, rtac subset_UNIV, rtac subsetI, rtac CollectI,
   5.113 -    CONJ_WRAP' (K (rtac subset_UNIV)) (1 upto n), rtac map_id0])) 1;
   5.114 -
   5.115 -fun mk_rel_mono_tac rel_OO_Grps in_mono =
   5.116 -  let
   5.117 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
   5.118 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
   5.119 -        rtac (hd rel_OO_Grps RS sym RSN (2, ord_le_eq_trans));
   5.120 -  in
   5.121 -    EVERY' [rel_OO_Grps_tac, rtac @{thm relcompp_mono}, rtac @{thm iffD2[OF conversep_mono]},
   5.122 -      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono},
   5.123 -      rtac @{thm Grp_mono}, rtac in_mono, REPEAT_DETERM o etac @{thm Collect_split_mono}] 1
   5.124 -  end;
   5.125 -
   5.126 -fun mk_rel_conversep_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
   5.127 -  {context = ctxt, prems = _} =
   5.128 -  let
   5.129 -    val n = length set_maps;
   5.130 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
   5.131 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
   5.132 -        rtac (hd rel_OO_Grps RS sym RS @{thm arg_cong[of _ _ conversep]} RSN (2, ord_le_eq_trans));
   5.133 -  in
   5.134 -    if null set_maps then rtac (rel_eq RS @{thm leq_conversepI}) 1
   5.135 -    else
   5.136 -      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
   5.137 -        REPEAT_DETERM o
   5.138 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
   5.139 -        hyp_subst_tac ctxt, rtac @{thm conversepI}, rtac @{thm relcomppI}, rtac @{thm conversepI},
   5.140 -        EVERY' (map (fn thm => EVERY' [rtac @{thm GrpI}, rtac sym, rtac trans,
   5.141 -          rtac map_cong0, REPEAT_DETERM_N n o rtac thm,
   5.142 -          rtac (map_comp RS sym), rtac CollectI,
   5.143 -          CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
   5.144 -            etac @{thm flip_pred}]) set_maps]) [@{thm snd_fst_flip}, @{thm fst_snd_flip}])] 1
   5.145 -  end;
   5.146 -
   5.147 -fun mk_rel_conversep_tac le_conversep rel_mono =
   5.148 -  EVERY' [rtac @{thm antisym}, rtac le_conversep, rtac @{thm xt1(6)}, rtac conversep_shift,
   5.149 -    rtac le_conversep, rtac @{thm iffD2[OF conversep_mono]}, rtac rel_mono,
   5.150 -    REPEAT_DETERM o rtac @{thm eq_refl[OF sym[OF conversep_conversep]]}] 1;
   5.151 -
   5.152 -fun mk_rel_OO_le_tac rel_OO_Grps rel_eq map_cong0 map_comp set_maps
   5.153 -  {context = ctxt, prems = _} =
   5.154 -  let
   5.155 -    val n = length set_maps;
   5.156 -    fun in_tac nthO_in = rtac CollectI THEN'
   5.157 -        CONJ_WRAP' (fn thm => EVERY' [rtac (thm RS ord_eq_le_trans),
   5.158 -          rtac @{thm image_subsetI}, rtac nthO_in, etac set_mp, atac]) set_maps;
   5.159 -    val rel_OO_Grps_tac = if null rel_OO_Grps then K all_tac
   5.160 -      else rtac (hd rel_OO_Grps RS ord_eq_le_trans) THEN'
   5.161 -        rtac (@{thm arg_cong2[of _ _ _ _ "op OO"]} OF (replicate 2 (hd rel_OO_Grps RS sym)) RSN
   5.162 -          (2, ord_le_eq_trans));
   5.163 -  in
   5.164 -    if null set_maps then rtac (rel_eq RS @{thm leq_OOI}) 1
   5.165 -    else
   5.166 -      EVERY' [rel_OO_Grps_tac, rtac @{thm predicate2I},
   5.167 -        REPEAT_DETERM o
   5.168 -          eresolve_tac [CollectE, exE, conjE, @{thm GrpE}, @{thm relcomppE}, @{thm conversepE}],
   5.169 -        hyp_subst_tac ctxt,
   5.170 -        rtac @{thm relcomppI}, rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
   5.171 -        rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
   5.172 -        REPEAT_DETERM_N n o rtac @{thm fst_fstOp},
   5.173 -        in_tac @{thm fstOp_in},
   5.174 -        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac map_cong0,
   5.175 -        REPEAT_DETERM_N n o EVERY' [rtac trans, rtac o_apply, 
   5.176 -          rtac ballE, rtac subst,
   5.177 -          rtac @{thm csquare_def}, rtac @{thm csquare_fstOp_sndOp}, atac, etac notE,
   5.178 -          etac set_mp, atac],
   5.179 -        in_tac @{thm fstOp_in},
   5.180 -        rtac @{thm relcomppI}, rtac @{thm conversepI}, rtac @{thm GrpI},
   5.181 -        rtac trans, rtac map_comp, rtac map_cong0,
   5.182 -        REPEAT_DETERM_N n o rtac o_apply,
   5.183 -        in_tac @{thm sndOp_in},
   5.184 -        rtac @{thm GrpI}, rtac trans, rtac map_comp, rtac sym, rtac map_cong0,
   5.185 -        REPEAT_DETERM_N n o rtac @{thm snd_sndOp},
   5.186 -        in_tac @{thm sndOp_in}] 1
   5.187 -  end;
   5.188 -
   5.189 -fun mk_rel_mono_strong_tac in_rel set_maps {context = ctxt, prems = _} =
   5.190 -  if null set_maps then atac 1
   5.191 -  else
   5.192 -    unfold_tac ctxt [in_rel] THEN
   5.193 -    REPEAT_DETERM (eresolve_tac [exE, CollectE, conjE] 1) THEN
   5.194 -    hyp_subst_tac ctxt 1 THEN
   5.195 -    unfold_tac ctxt set_maps THEN
   5.196 -    EVERY' [rtac exI, rtac @{thm conjI[OF CollectI conjI[OF refl refl]]},
   5.197 -      CONJ_WRAP' (K (etac @{thm Collect_split_mono_strong} THEN' atac)) set_maps] 1;
   5.198 -
   5.199 -fun mk_map_transfer_tac rel_mono in_rel set_maps map_cong0 map_comp
   5.200 -  {context = ctxt, prems = _} =
   5.201 -  let
   5.202 -    val n = length set_maps;
   5.203 -    val in_tac = if n = 0 then rtac UNIV_I else
   5.204 -      rtac CollectI THEN' CONJ_WRAP' (fn thm =>
   5.205 -        etac (thm RS
   5.206 -          @{thm ord_eq_le_trans[OF _ subset_trans[OF image_mono convol_image_vimage2p]]}))
   5.207 -      set_maps;
   5.208 -  in
   5.209 -    REPEAT_DETERM_N n (HEADGOAL (rtac @{thm fun_relI})) THEN
   5.210 -    unfold_thms_tac ctxt @{thms fun_rel_iff_leq_vimage2p} THEN
   5.211 -    HEADGOAL (EVERY' [rtac @{thm order_trans}, rtac rel_mono, REPEAT_DETERM_N n o atac,
   5.212 -      rtac @{thm predicate2I}, dtac (in_rel RS iffD1),
   5.213 -      REPEAT_DETERM o eresolve_tac [exE, CollectE, conjE], hyp_subst_tac ctxt,
   5.214 -      rtac @{thm vimage2pI}, rtac (in_rel RS iffD2), rtac exI, rtac conjI, in_tac,
   5.215 -      rtac conjI,
   5.216 -      EVERY' (map (fn convol =>
   5.217 -        rtac (box_equals OF [map_cong0, map_comp RS sym, map_comp RS sym]) THEN'
   5.218 -        REPEAT_DETERM_N n o rtac (convol RS fun_cong)) @{thms fst_convol snd_convol})])
   5.219 -  end;
   5.220 -
   5.221 -fun mk_in_bd_tac live surj_imp_ordLeq_inst map_comp map_id map_cong0 set_maps set_bds
   5.222 -  bd_card_order bd_Card_order bd_Cinfinite bd_Cnotzero {context = ctxt, prems = _} =
   5.223 -  if live = 0 then
   5.224 -    rtac @{thm ordLeq_transitive[OF ordLeq_csum2[OF card_of_Card_order]
   5.225 -      ordLeq_cexp2[OF ordLeq_refl[OF Card_order_ctwo] Card_order_csum]]} 1
   5.226 -  else
   5.227 -    let
   5.228 -      val bd'_Cinfinite = bd_Cinfinite RS @{thm Cinfinite_csum1};
   5.229 -      val inserts =
   5.230 -        map (fn set_bd => 
   5.231 -          iffD2 OF [@{thm card_of_ordLeq}, @{thm ordLeq_ordIso_trans} OF
   5.232 -            [set_bd, bd_Card_order RS @{thm card_of_Field_ordIso} RS @{thm ordIso_symmetric}]])
   5.233 -        set_bds;        
   5.234 -    in
   5.235 -      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac @{thm cprod_cinfinite_bound},
   5.236 -        rtac (ctrans OF @{thms ordLeq_csum2 ordLeq_cexp2}), rtac @{thm card_of_Card_order},
   5.237 -        rtac @{thm ordLeq_csum2}, rtac @{thm Card_order_ctwo}, rtac @{thm Card_order_csum},
   5.238 -        rtac @{thm ordIso_ordLeq_trans}, rtac @{thm cexp_cong1},
   5.239 -        if live = 1 then rtac @{thm ordIso_refl[OF Card_order_csum]}
   5.240 -        else
   5.241 -          REPEAT_DETERM_N (live - 2) o rtac @{thm ordIso_transitive[OF csum_cong2]} THEN'
   5.242 -          REPEAT_DETERM_N (live - 1) o rtac @{thm csum_csum},
   5.243 -        rtac bd_Card_order, rtac (@{thm cexp_mono2_Cnotzero} RS ctrans), rtac @{thm ordLeq_csum1},
   5.244 -        rtac bd_Card_order, rtac @{thm Card_order_csum}, rtac bd_Cnotzero,
   5.245 -        rtac @{thm csum_Cfinite_cexp_Cinfinite},
   5.246 -        rtac (if live = 1 then @{thm card_of_Card_order} else @{thm Card_order_csum}),
   5.247 -        CONJ_WRAP_GEN' (rtac @{thm Cfinite_csum}) (K (rtac @{thm Cfinite_cone})) set_maps,
   5.248 -        rtac bd'_Cinfinite, rtac @{thm card_of_Card_order},
   5.249 -        rtac @{thm Card_order_cexp}, rtac @{thm Cinfinite_cexp}, rtac @{thm ordLeq_csum2},
   5.250 -        rtac @{thm Card_order_ctwo}, rtac bd'_Cinfinite,
   5.251 -        rtac (Drule.rotate_prems 1 (@{thm cprod_mono2} RSN (2, ctrans))),
   5.252 -        REPEAT_DETERM_N (live - 1) o
   5.253 -          (rtac (bd_Cinfinite RS @{thm cprod_cexp_csum_cexp_Cinfinite} RSN (2, ctrans)) THEN'
   5.254 -           rtac @{thm ordLeq_ordIso_trans[OF cprod_mono2 ordIso_symmetric[OF cprod_cexp]]}),
   5.255 -        rtac @{thm ordLeq_refl[OF Card_order_cexp]}] 1 THEN
   5.256 -      unfold_thms_tac ctxt [bd_card_order RS @{thm card_order_csum_cone_cexp_def}] THEN
   5.257 -      unfold_thms_tac ctxt @{thms cprod_def Field_card_of} THEN
   5.258 -      EVERY' [rtac (Drule.rotate_prems 1 ctrans), rtac surj_imp_ordLeq_inst, rtac subsetI,
   5.259 -        Method.insert_tac inserts, REPEAT_DETERM o dtac meta_spec,
   5.260 -        REPEAT_DETERM o eresolve_tac [exE, Tactic.make_elim conjunct1], etac CollectE,
   5.261 -        if live = 1 then K all_tac
   5.262 -        else REPEAT_DETERM_N (live - 2) o (etac conjE THEN' rotate_tac ~1) THEN' etac conjE,
   5.263 -        rtac (Drule.rotate_prems 1 @{thm image_eqI}), rtac @{thm SigmaI}, rtac @{thm UNIV_I},
   5.264 -        CONJ_WRAP_GEN' (rtac @{thm SigmaI})
   5.265 -          (K (etac @{thm If_the_inv_into_in_Func} THEN' atac)) set_maps,
   5.266 -        rtac sym,
   5.267 -        rtac (Drule.rotate_prems 1
   5.268 -           ((box_equals OF [map_cong0 OF replicate live @{thm If_the_inv_into_f_f},
   5.269 -             map_comp RS sym, map_id]) RSN (2, trans))),
   5.270 -        REPEAT_DETERM_N (2 * live) o atac,
   5.271 -        REPEAT_DETERM_N live o rtac (@{thm prod.cases} RS trans),
   5.272 -        rtac refl,
   5.273 -        rtac @{thm surj_imp_ordLeq}, rtac subsetI, rtac (Drule.rotate_prems 1 @{thm image_eqI}),
   5.274 -        REPEAT_DETERM o eresolve_tac [CollectE, conjE], rtac CollectI,
   5.275 -        CONJ_WRAP' (fn thm =>
   5.276 -          rtac (thm RS ord_eq_le_trans) THEN' etac @{thm subset_trans[OF image_mono Un_upper1]})
   5.277 -        set_maps,
   5.278 -        rtac sym,
   5.279 -        rtac (box_equals OF [map_cong0 OF replicate live @{thm fun_cong[OF sum_case_o_inj(1)]},
   5.280 -           map_comp RS sym, map_id])] 1
   5.281 -  end;
   5.282 -
   5.283 -fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
   5.284 -  unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
   5.285 -    dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
   5.286 -
   5.287 -end;
     6.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar.ML	Mon Jan 20 18:24:56 2014 +0100
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,1523 +0,0 @@
     6.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar.ML
     6.5 -    Author:     Jasmin Blanchette, TU Muenchen
     6.6 -    Copyright   2012, 2013
     6.7 -
     6.8 -Sugared datatype and codatatype constructions.
     6.9 -*)
    6.10 -
    6.11 -signature BNF_FP_DEF_SUGAR =
    6.12 -sig
    6.13 -  type fp_sugar =
    6.14 -    {T: typ,
    6.15 -     fp: BNF_FP_Util.fp_kind,
    6.16 -     index: int,
    6.17 -     pre_bnfs: BNF_Def.bnf list,
    6.18 -     nested_bnfs: BNF_Def.bnf list,
    6.19 -     nesting_bnfs: BNF_Def.bnf list,
    6.20 -     fp_res: BNF_FP_Util.fp_result,
    6.21 -     ctr_defss: thm list list,
    6.22 -     ctr_sugars: Ctr_Sugar.ctr_sugar list,
    6.23 -     co_iterss: term list list,
    6.24 -     mapss: thm list list,
    6.25 -     co_inducts: thm list,
    6.26 -     co_iter_thmsss: thm list list list,
    6.27 -     disc_co_itersss: thm list list list,
    6.28 -     sel_co_iterssss: thm list list list list};
    6.29 -
    6.30 -  val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
    6.31 -  val eq_fp_sugar: fp_sugar * fp_sugar -> bool
    6.32 -  val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
    6.33 -  val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
    6.34 -  val fp_sugar_of: Proof.context -> string -> fp_sugar option
    6.35 -  val fp_sugars_of: Proof.context -> fp_sugar list
    6.36 -
    6.37 -  val co_induct_of: 'a list -> 'a
    6.38 -  val strong_co_induct_of: 'a list -> 'a
    6.39 -
    6.40 -  val tvar_subst: theory -> typ list -> typ list -> ((string * int) * typ) list
    6.41 -  val exists_subtype_in: typ list -> typ -> bool
    6.42 -  val flat_rec_arg_args: 'a list list -> 'a list
    6.43 -  val flat_corec_preds_predsss_gettersss: 'a list -> 'a list list list -> 'a list list list ->
    6.44 -    'a list
    6.45 -  val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
    6.46 -  val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
    6.47 -
    6.48 -  type lfp_sugar_thms =
    6.49 -    (thm list * thm * Args.src list)
    6.50 -    * (thm list list * thm list list * Args.src list)
    6.51 -
    6.52 -  val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
    6.53 -  val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
    6.54 -
    6.55 -  type gfp_sugar_thms =
    6.56 -    ((thm list * thm) list * Args.src list)
    6.57 -    * (thm list list * thm list list * Args.src list)
    6.58 -    * (thm list list * thm list list * Args.src list)
    6.59 -    * (thm list list * thm list list * Args.src list)
    6.60 -    * (thm list list list * thm list list list * Args.src list)
    6.61 -
    6.62 -  val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
    6.63 -  val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
    6.64 -
    6.65 -  val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
    6.66 -    int list -> int list list -> term list list -> Proof.context ->
    6.67 -    (term list list
    6.68 -     * (typ list list * typ list list list list * term list list
    6.69 -        * term list list list list) list option
    6.70 -     * (string * term list * term list list
    6.71 -        * ((term list list * term list list list) * (typ list * typ list list)) list) option)
    6.72 -    * Proof.context
    6.73 -  val mk_iter_fun_arg_types: typ list list list -> int list -> int list list -> term ->
    6.74 -    typ list list list list
    6.75 -  val mk_coiter_fun_arg_types: typ list list list -> typ list -> int list -> term ->
    6.76 -    typ list list
    6.77 -    * (typ list list list list * typ list list list * typ list list list list * typ list)
    6.78 -  val define_iters: string list ->
    6.79 -    (typ list list * typ list list list list * term list list * term list list list list) list ->
    6.80 -    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
    6.81 -    (term list * thm list) * Proof.context
    6.82 -  val define_coiters: string list -> string * term list * term list list
    6.83 -    * ((term list list * term list list list) * (typ list * typ list list)) list ->
    6.84 -    (string -> binding) -> typ list -> typ list -> term list -> Proof.context ->
    6.85 -    (term list * thm list) * Proof.context
    6.86 -  val derive_induct_iters_thms_for_types: BNF_Def.bnf list ->
    6.87 -    (typ list list * typ list list list list * term list list * term list list list list) list ->
    6.88 -    thm -> thm list list -> BNF_Def.bnf list -> BNF_Def.bnf list -> typ list -> typ list ->
    6.89 -    typ list -> typ list list list -> term list list -> thm list list -> term list list ->
    6.90 -    thm list list -> local_theory -> lfp_sugar_thms
    6.91 -  val derive_coinduct_coiters_thms_for_types: BNF_Def.bnf list ->
    6.92 -    string * term list * term list list * ((term list list * term list list list)
    6.93 -      * (typ list * typ list list)) list ->
    6.94 -    thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
    6.95 -    typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
    6.96 -    Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
    6.97 -    local_theory -> gfp_sugar_thms
    6.98 -  val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
    6.99 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   6.100 -      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
   6.101 -    (bool * (bool * bool)) * (((((binding * (typ * sort)) list * binding) * (binding * binding))
   6.102 -      * mixfix) * ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
   6.103 -        mixfix) list) list ->
   6.104 -    local_theory -> local_theory
   6.105 -  val parse_co_datatype_cmd: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   6.106 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   6.107 -      BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
   6.108 -    (local_theory -> local_theory) parser
   6.109 -end;
   6.110 -
   6.111 -structure BNF_FP_Def_Sugar : BNF_FP_DEF_SUGAR =
   6.112 -struct
   6.113 -
   6.114 -open Ctr_Sugar
   6.115 -open BNF_Util
   6.116 -open BNF_Comp
   6.117 -open BNF_Def
   6.118 -open BNF_FP_Util
   6.119 -open BNF_FP_Def_Sugar_Tactics
   6.120 -
   6.121 -val EqN = "Eq_";
   6.122 -
   6.123 -type fp_sugar =
   6.124 -  {T: typ,
   6.125 -   fp: fp_kind,
   6.126 -   index: int,
   6.127 -   pre_bnfs: bnf list,
   6.128 -   nested_bnfs: bnf list,
   6.129 -   nesting_bnfs: bnf list,
   6.130 -   fp_res: fp_result,
   6.131 -   ctr_defss: thm list list,
   6.132 -   ctr_sugars: ctr_sugar list,
   6.133 -   co_iterss: term list list,
   6.134 -   mapss: thm list list,
   6.135 -   co_inducts: thm list,
   6.136 -   co_iter_thmsss: thm list list list,
   6.137 -   disc_co_itersss: thm list list list,
   6.138 -   sel_co_iterssss: thm list list list list};
   6.139 -
   6.140 -fun of_fp_sugar f (fp_sugar as ({index, ...}: fp_sugar)) = nth (f fp_sugar) index;
   6.141 -
   6.142 -fun eq_fp_sugar ({T = T1, fp = fp1, index = index1, fp_res = fp_res1, ...} : fp_sugar,
   6.143 -    {T = T2, fp = fp2, index = index2, fp_res = fp_res2, ...} : fp_sugar) =
   6.144 -  T1 = T2 andalso fp1 = fp2 andalso index1 = index2 andalso eq_fp_result (fp_res1, fp_res2);
   6.145 -
   6.146 -fun morph_fp_sugar phi ({T, fp, index, pre_bnfs, nested_bnfs, nesting_bnfs, fp_res, ctr_defss,
   6.147 -    ctr_sugars, co_iterss, mapss, co_inducts, co_iter_thmsss, disc_co_itersss, sel_co_iterssss}
   6.148 -    : fp_sugar) =
   6.149 -  {T = Morphism.typ phi T, fp = fp, index = index, pre_bnfs = map (morph_bnf phi) pre_bnfs,
   6.150 -    nested_bnfs = map (morph_bnf phi) nested_bnfs, nesting_bnfs = map (morph_bnf phi) nesting_bnfs,
   6.151 -   fp_res = morph_fp_result phi fp_res,
   6.152 -   ctr_defss = map (map (Morphism.thm phi)) ctr_defss,
   6.153 -   ctr_sugars = map (morph_ctr_sugar phi) ctr_sugars,
   6.154 -   co_iterss = map (map (Morphism.term phi)) co_iterss,
   6.155 -   mapss = map (map (Morphism.thm phi)) mapss,
   6.156 -   co_inducts = map (Morphism.thm phi) co_inducts,
   6.157 -   co_iter_thmsss = map (map (map (Morphism.thm phi))) co_iter_thmsss,
   6.158 -   disc_co_itersss = map (map (map (Morphism.thm phi))) disc_co_itersss,
   6.159 -   sel_co_iterssss = map (map (map (map (Morphism.thm phi)))) sel_co_iterssss};
   6.160 -
   6.161 -val transfer_fp_sugar =
   6.162 -  morph_fp_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
   6.163 -
   6.164 -structure Data = Generic_Data
   6.165 -(
   6.166 -  type T = fp_sugar Symtab.table;
   6.167 -  val empty = Symtab.empty;
   6.168 -  val extend = I;
   6.169 -  val merge = Symtab.merge eq_fp_sugar;
   6.170 -);
   6.171 -
   6.172 -fun fp_sugar_of ctxt =
   6.173 -  Symtab.lookup (Data.get (Context.Proof ctxt))
   6.174 -  #> Option.map (transfer_fp_sugar ctxt);
   6.175 -
   6.176 -fun fp_sugars_of ctxt =
   6.177 -  Symtab.fold (cons o transfer_fp_sugar ctxt o snd) (Data.get (Context.Proof ctxt)) [];
   6.178 -
   6.179 -fun co_induct_of (i :: _) = i;
   6.180 -fun strong_co_induct_of [_, s] = s;
   6.181 -
   6.182 -(* TODO: register "sum" and "prod" as datatypes to enable N2M reduction for them *)
   6.183 -
   6.184 -fun register_fp_sugar key fp_sugar =
   6.185 -  Local_Theory.declaration {syntax = false, pervasive = true}
   6.186 -    (fn phi => Data.map (Symtab.default (key, morph_fp_sugar phi fp_sugar)));
   6.187 -
   6.188 -fun register_fp_sugars fp pre_bnfs nested_bnfs nesting_bnfs (fp_res as {Ts, ...}) ctr_defss
   6.189 -    ctr_sugars co_iterss mapss co_inducts co_iter_thmsss disc_co_itersss sel_co_iterssss lthy =
   6.190 -  (0, lthy)
   6.191 -  |> fold (fn T as Type (s, _) => fn (kk, lthy) => (kk + 1,
   6.192 -    register_fp_sugar s {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs,
   6.193 -        nested_bnfs = nested_bnfs, nesting_bnfs = nesting_bnfs, fp_res = fp_res,
   6.194 -        ctr_defss = ctr_defss, ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss,
   6.195 -        co_inducts = co_inducts, co_iter_thmsss = co_iter_thmsss, disc_co_itersss = disc_co_itersss,
   6.196 -        sel_co_iterssss = sel_co_iterssss}
   6.197 -      lthy)) Ts
   6.198 -  |> snd;
   6.199 -
   6.200 -(* This function could produce clashes in contrived examples (e.g., "x.A", "x.x_A", "y.A"). *)
   6.201 -fun quasi_unambiguous_case_names names =
   6.202 -  let
   6.203 -    val ps = map (`Long_Name.base_name) names;
   6.204 -    val dups = Library.duplicates (op =) (map fst ps);
   6.205 -    fun underscore s =
   6.206 -      let val ss = space_explode Long_Name.separator s in
   6.207 -        space_implode "_" (drop (length ss - 2) ss)
   6.208 -      end;
   6.209 -  in
   6.210 -    map (fn (base, full) => if member (op =) dups base then underscore full else base) ps
   6.211 -  end;
   6.212 -
   6.213 -val id_def = @{thm id_def};
   6.214 -val mp_conj = @{thm mp_conj};
   6.215 -
   6.216 -val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   6.217 -val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
   6.218 -val simp_attrs = @{attributes [simp]};
   6.219 -
   6.220 -fun tvar_subst thy Ts Us =
   6.221 -  Vartab.fold (cons o apsnd snd) (fold (Sign.typ_match thy) (Ts ~~ Us) Vartab.empty) [];
   6.222 -
   6.223 -val exists_subtype_in = Term.exists_subtype o member (op =);
   6.224 -
   6.225 -val lists_bmoc = fold (fn xs => fn t => Term.list_comb (t, xs));
   6.226 -
   6.227 -fun flat_rec_arg_args xss =
   6.228 -  (* FIXME (once the old datatype package is phased out): The first line below gives the preferred
   6.229 -     order. The second line is for compatibility with the old datatype package. *)
   6.230 -(*
   6.231 -  flat xss
   6.232 -*)
   6.233 -  map hd xss @ maps tl xss;
   6.234 -
   6.235 -fun flat_corec_predss_getterss qss fss = maps (op @) (qss ~~ fss);
   6.236 -
   6.237 -fun flat_corec_preds_predsss_gettersss [] [qss] [fss] = flat_corec_predss_getterss qss fss
   6.238 -  | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
   6.239 -    p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
   6.240 -
   6.241 -fun mk_tupled_fun x f xs =
   6.242 -  if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
   6.243 -
   6.244 -fun mk_uncurried2_fun f xss =
   6.245 -  mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
   6.246 -
   6.247 -fun mk_flip (x, Type (_, [T1, Type (_, [T2, T3])])) =
   6.248 -  Abs ("x", T1, Abs ("y", T2, Var (x, T2 --> T1 --> T3) $ Bound 0 $ Bound 1));
   6.249 -
   6.250 -fun flip_rels lthy n thm =
   6.251 -  let
   6.252 -    val Rs = Term.add_vars (prop_of thm) [];
   6.253 -    val Rs' = rev (drop (length Rs - n) Rs);
   6.254 -    val cRs = map (fn f => (certify lthy (Var f), certify lthy (mk_flip f))) Rs';
   6.255 -  in
   6.256 -    Drule.cterm_instantiate cRs thm
   6.257 -  end;
   6.258 -
   6.259 -fun mk_ctor_or_dtor get_T Ts t =
   6.260 -  let val Type (_, Ts0) = get_T (fastype_of t) in
   6.261 -    Term.subst_atomic_types (Ts0 ~~ Ts) t
   6.262 -  end;
   6.263 -
   6.264 -val mk_ctor = mk_ctor_or_dtor range_type;
   6.265 -val mk_dtor = mk_ctor_or_dtor domain_type;
   6.266 -
   6.267 -fun mk_co_iter thy fp fpT Cs t =
   6.268 -  let
   6.269 -    val (f_Cs, Type (_, [prebody, body])) = strip_fun_type (fastype_of t);
   6.270 -    val fpT0 = fp_case fp prebody body;
   6.271 -    val Cs0 = distinct (op =) (map (fp_case fp body_type domain_type) f_Cs);
   6.272 -    val rho = tvar_subst thy (fpT0 :: Cs0) (fpT :: Cs);
   6.273 -  in
   6.274 -    Term.subst_TVars rho t
   6.275 -  end;
   6.276 -
   6.277 -fun mk_co_iters thy fp fpTs Cs ts0 =
   6.278 -  let
   6.279 -    val nn = length fpTs;
   6.280 -    val (fpTs0, Cs0) =
   6.281 -      map ((fp = Greatest_FP ? swap) o dest_funT o snd o strip_typeN nn o fastype_of) ts0
   6.282 -      |> split_list;
   6.283 -    val rho = tvar_subst thy (fpTs0 @ Cs0) (fpTs @ Cs);
   6.284 -  in
   6.285 -    map (Term.subst_TVars rho) ts0
   6.286 -  end;
   6.287 -
   6.288 -val mk_fp_iter_fun_types = binder_fun_types o fastype_of;
   6.289 -
   6.290 -fun unzip_recT (Type (@{type_name prod}, _)) T = [T]
   6.291 -  | unzip_recT _ (Type (@{type_name prod}, Ts)) = Ts
   6.292 -  | unzip_recT _ T = [T];
   6.293 -
   6.294 -fun unzip_corecT (Type (@{type_name sum}, _)) T = [T]
   6.295 -  | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
   6.296 -  | unzip_corecT _ T = [T];
   6.297 -
   6.298 -fun liveness_of_fp_bnf n bnf =
   6.299 -  (case T_of_bnf bnf of
   6.300 -    Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
   6.301 -  | _ => replicate n false);
   6.302 -
   6.303 -fun cannot_merge_types () = error "Mutually recursive types must have the same type parameters";
   6.304 -
   6.305 -fun merge_type_arg T T' = if T = T' then T else cannot_merge_types ();
   6.306 -
   6.307 -fun merge_type_args (As, As') =
   6.308 -  if length As = length As' then map2 merge_type_arg As As' else cannot_merge_types ();
   6.309 -
   6.310 -fun reassoc_conjs thm =
   6.311 -  reassoc_conjs (thm RS @{thm conj_assoc[THEN iffD1]})
   6.312 -  handle THM _ => thm;
   6.313 -
   6.314 -fun type_args_named_constrained_of ((((ncAs, _), _), _), _) = ncAs;
   6.315 -fun type_binding_of ((((_, b), _), _), _) = b;
   6.316 -fun map_binding_of (((_, (b, _)), _), _) = b;
   6.317 -fun rel_binding_of (((_, (_, b)), _), _) = b;
   6.318 -fun mixfix_of ((_, mx), _) = mx;
   6.319 -fun ctr_specs_of (_, ctr_specs) = ctr_specs;
   6.320 -
   6.321 -fun disc_of ((((disc, _), _), _), _) = disc;
   6.322 -fun ctr_of ((((_, ctr), _), _), _) = ctr;
   6.323 -fun args_of (((_, args), _), _) = args;
   6.324 -fun defaults_of ((_, ds), _) = ds;
   6.325 -fun ctr_mixfix_of (_, mx) = mx;
   6.326 -
   6.327 -fun add_nesty_bnf_names Us =
   6.328 -  let
   6.329 -    fun add (Type (s, Ts)) ss =
   6.330 -        let val (needs, ss') = fold_map add Ts ss in
   6.331 -          if exists I needs then (true, insert (op =) s ss') else (false, ss')
   6.332 -        end
   6.333 -      | add T ss = (member (op =) Us T, ss);
   6.334 -  in snd oo add end;
   6.335 -
   6.336 -fun nesty_bnfs ctxt ctr_Tsss Us =
   6.337 -  map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
   6.338 -
   6.339 -fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
   6.340 -
   6.341 -type lfp_sugar_thms =
   6.342 -  (thm list * thm * Args.src list)
   6.343 -  * (thm list list * thm list list * Args.src list)
   6.344 -
   6.345 -fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
   6.346 -  ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
   6.347 -   (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
   6.348 -
   6.349 -val transfer_lfp_sugar_thms =
   6.350 -  morph_lfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
   6.351 -
   6.352 -type gfp_sugar_thms =
   6.353 -  ((thm list * thm) list * Args.src list)
   6.354 -  * (thm list list * thm list list * Args.src list)
   6.355 -  * (thm list list * thm list list * Args.src list)
   6.356 -  * (thm list list * thm list list * Args.src list)
   6.357 -  * (thm list list list * thm list list list * Args.src list);
   6.358 -
   6.359 -fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
   6.360 -    (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
   6.361 -    (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
   6.362 -    (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
   6.363 -  ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
   6.364 -    coinduct_attrs),
   6.365 -   (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
   6.366 -   (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
   6.367 -    disc_iter_attrs),
   6.368 -   (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
   6.369 -    disc_iter_iff_attrs),
   6.370 -   (map (map (map (Morphism.thm phi))) sel_unfoldsss,
   6.371 -    map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
   6.372 -
   6.373 -val transfer_gfp_sugar_thms =
   6.374 -  morph_gfp_sugar_thms o Morphism.transfer_morphism o Proof_Context.theory_of;
   6.375 -
   6.376 -fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
   6.377 -
   6.378 -fun mk_iter_fun_arg_types ctr_Tsss ns mss =
   6.379 -  mk_fp_iter_fun_types
   6.380 -  #> map3 mk_iter_fun_arg_types0 ns mss
   6.381 -  #> map2 (map2 (map2 unzip_recT)) ctr_Tsss;
   6.382 -
   6.383 -fun mk_iters_args_types ctr_Tsss Cs ns mss ctor_iter_fun_Tss lthy =
   6.384 -  let
   6.385 -    val Css = map2 replicate ns Cs;
   6.386 -    val y_Tsss = map3 mk_iter_fun_arg_types0 ns mss (map un_fold_of ctor_iter_fun_Tss);
   6.387 -    val g_Tss = map2 (fn C => map (fn y_Ts => y_Ts ---> C)) Cs y_Tsss;
   6.388 -
   6.389 -    val ((gss, ysss), lthy) =
   6.390 -      lthy
   6.391 -      |> mk_Freess "f" g_Tss
   6.392 -      ||>> mk_Freesss "x" y_Tsss;
   6.393 -
   6.394 -    val y_Tssss = map (map (map single)) y_Tsss;
   6.395 -    val yssss = map (map (map single)) ysss;
   6.396 -
   6.397 -    val z_Tssss =
   6.398 -      map4 (fn n => fn ms => fn ctr_Tss => fn ctor_iter_fun_Ts =>
   6.399 -          map3 (fn m => fn ctr_Ts => fn ctor_iter_fun_T =>
   6.400 -              map2 unzip_recT ctr_Ts (dest_tupleT m ctor_iter_fun_T))
   6.401 -            ms ctr_Tss (dest_sumTN_balanced n (domain_type (co_rec_of ctor_iter_fun_Ts))))
   6.402 -        ns mss ctr_Tsss ctor_iter_fun_Tss;
   6.403 -
   6.404 -    val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
   6.405 -    val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
   6.406 -
   6.407 -    val hss = map2 (map2 retype_free) h_Tss gss;
   6.408 -    val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
   6.409 -    val (zssss_tl, lthy) =
   6.410 -      lthy
   6.411 -      |> mk_Freessss "y" (map (map (map tl)) z_Tssss);
   6.412 -    val zssss = map2 (map2 (map2 cons)) zssss_hd zssss_tl;
   6.413 -  in
   6.414 -    ([(g_Tss, y_Tssss, gss, yssss), (h_Tss, z_Tssss, hss, zssss)], lthy)
   6.415 -  end;
   6.416 -
   6.417 -fun mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts =
   6.418 -  let
   6.419 -    (*avoid "'a itself" arguments in coiterators*)
   6.420 -    fun repair_arity [[]] = [[@{typ unit}]]
   6.421 -      | repair_arity Tss = Tss;
   6.422 -
   6.423 -    val ctr_Tsss' = map repair_arity ctr_Tsss;
   6.424 -    val f_sum_prod_Ts = map range_type fun_Ts;
   6.425 -    val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
   6.426 -    val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
   6.427 -    val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
   6.428 -      Cs ctr_Tsss' f_Tsss;
   6.429 -    val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
   6.430 -  in
   6.431 -    (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts)
   6.432 -  end;
   6.433 -
   6.434 -fun mk_coiter_p_pred_types Cs ns = map2 (fn n => replicate (Int.max (0, n - 1)) o mk_pred1T) ns Cs;
   6.435 -
   6.436 -fun mk_coiter_fun_arg_types ctr_Tsss Cs ns dtor_coiter =
   6.437 -  (mk_coiter_p_pred_types Cs ns,
   6.438 -   mk_fp_iter_fun_types dtor_coiter |> mk_coiter_fun_arg_types0 ctr_Tsss Cs ns);
   6.439 -
   6.440 -fun mk_coiters_args_types ctr_Tsss Cs ns dtor_coiter_fun_Tss lthy =
   6.441 -  let
   6.442 -    val p_Tss = mk_coiter_p_pred_types Cs ns;
   6.443 -
   6.444 -    fun mk_types get_Ts =
   6.445 -      let
   6.446 -        val fun_Ts = map get_Ts dtor_coiter_fun_Tss;
   6.447 -        val (q_Tssss, f_Tsss, f_Tssss, f_sum_prod_Ts) = mk_coiter_fun_arg_types0 ctr_Tsss Cs ns fun_Ts;
   6.448 -        val pf_Tss = map3 flat_corec_preds_predsss_gettersss p_Tss q_Tssss f_Tssss;
   6.449 -      in
   6.450 -        (q_Tssss, f_Tsss, f_Tssss, (f_sum_prod_Ts, pf_Tss))
   6.451 -      end;
   6.452 -
   6.453 -    val (r_Tssss, g_Tsss, g_Tssss, unfold_types) = mk_types un_fold_of;
   6.454 -    val (s_Tssss, h_Tsss, h_Tssss, corec_types) = mk_types co_rec_of;
   6.455 -
   6.456 -    val ((((Free (z, _), cs), pss), gssss), lthy) =
   6.457 -      lthy
   6.458 -      |> yield_singleton (mk_Frees "z") dummyT
   6.459 -      ||>> mk_Frees "a" Cs
   6.460 -      ||>> mk_Freess "p" p_Tss
   6.461 -      ||>> mk_Freessss "g" g_Tssss;
   6.462 -    val rssss = map (map (map (fn [] => []))) r_Tssss;
   6.463 -
   6.464 -    val hssss_hd = map2 (map2 (map2 (fn T :: _ => fn [g] => retype_free T g))) h_Tssss gssss;
   6.465 -    val ((sssss, hssss_tl), lthy) =
   6.466 -      lthy
   6.467 -      |> mk_Freessss "q" s_Tssss
   6.468 -      ||>> mk_Freessss "h" (map (map (map tl)) h_Tssss);
   6.469 -    val hssss = map2 (map2 (map2 cons)) hssss_hd hssss_tl;
   6.470 -
   6.471 -    val cpss = map2 (map o rapp) cs pss;
   6.472 -
   6.473 -    fun build_sum_inj mk_inj = build_map lthy (uncurry mk_inj o dest_sumT o snd);
   6.474 -
   6.475 -    fun build_dtor_coiter_arg _ [] [cf] = cf
   6.476 -      | build_dtor_coiter_arg T [cq] [cf, cf'] =
   6.477 -        mk_If cq (build_sum_inj Inl_const (fastype_of cf, T) $ cf)
   6.478 -          (build_sum_inj Inr_const (fastype_of cf', T) $ cf');
   6.479 -
   6.480 -    fun mk_args qssss fssss f_Tsss =
   6.481 -      let
   6.482 -        val pfss = map3 flat_corec_preds_predsss_gettersss pss qssss fssss;
   6.483 -        val cqssss = map2 (map o map o map o rapp) cs qssss;
   6.484 -        val cfssss = map2 (map o map o map o rapp) cs fssss;
   6.485 -        val cqfsss = map3 (map3 (map3 build_dtor_coiter_arg)) f_Tsss cqssss cfssss;
   6.486 -      in (pfss, cqfsss) end;
   6.487 -
   6.488 -    val unfold_args = mk_args rssss gssss g_Tsss;
   6.489 -    val corec_args = mk_args sssss hssss h_Tsss;
   6.490 -  in
   6.491 -    ((z, cs, cpss, [(unfold_args, unfold_types), (corec_args, corec_types)]), lthy)
   6.492 -  end;
   6.493 -
   6.494 -fun mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy =
   6.495 -  let
   6.496 -    val thy = Proof_Context.theory_of lthy;
   6.497 -
   6.498 -    val (xtor_co_iter_fun_Tss, xtor_co_iterss) =
   6.499 -      map (mk_co_iters thy fp fpTs Cs #> `(mk_fp_iter_fun_types o hd)) (transpose xtor_co_iterss0)
   6.500 -      |> apsnd transpose o apfst transpose o split_list;
   6.501 -
   6.502 -    val ((iters_args_types, coiters_args_types), lthy') =
   6.503 -      if fp = Least_FP then
   6.504 -        mk_iters_args_types ctr_Tsss Cs ns mss xtor_co_iter_fun_Tss lthy |>> (rpair NONE o SOME)
   6.505 -      else
   6.506 -        mk_coiters_args_types ctr_Tsss Cs ns xtor_co_iter_fun_Tss lthy |>> (pair NONE o SOME)
   6.507 -  in
   6.508 -    ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy')
   6.509 -  end;
   6.510 -
   6.511 -fun mk_preds_getterss_join c cps sum_prod_T cqfss =
   6.512 -  let val n = length cqfss in
   6.513 -    Term.lambda c (mk_IfN sum_prod_T cps
   6.514 -      (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)))
   6.515 -  end;
   6.516 -
   6.517 -fun define_co_iters fp fpT Cs binding_specs lthy0 =
   6.518 -  let
   6.519 -    val thy = Proof_Context.theory_of lthy0;
   6.520 -
   6.521 -    val maybe_conceal_def_binding = Thm.def_binding
   6.522 -      #> Config.get lthy0 bnf_note_all = false ? Binding.conceal;
   6.523 -
   6.524 -    val ((csts, defs), (lthy', lthy)) = lthy0
   6.525 -      |> apfst split_list o fold_map (fn (b, rhs) =>
   6.526 -        Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs))
   6.527 -        #>> apsnd snd) binding_specs
   6.528 -      ||> `Local_Theory.restore;
   6.529 -
   6.530 -    val phi = Proof_Context.export_morphism lthy lthy';
   6.531 -
   6.532 -    val csts' = map (mk_co_iter thy fp fpT Cs o Morphism.term phi) csts;
   6.533 -    val defs' = map (Morphism.thm phi) defs;
   6.534 -  in
   6.535 -    ((csts', defs'), lthy')
   6.536 -  end;
   6.537 -
   6.538 -fun define_iters iterNs iter_args_typess' mk_binding fpTs Cs ctor_iters lthy =
   6.539 -  let
   6.540 -    val nn = length fpTs;
   6.541 -
   6.542 -    val fpT_to_C as Type (_, [fpT, _]) = snd (strip_typeN nn (fastype_of (hd ctor_iters)));
   6.543 -
   6.544 -    fun generate_iter pre (_, _, fss, xssss) ctor_iter =
   6.545 -      (mk_binding pre,
   6.546 -       fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_iter,
   6.547 -         map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss)));
   6.548 -  in
   6.549 -    define_co_iters Least_FP fpT Cs (map3 generate_iter iterNs iter_args_typess' ctor_iters) lthy
   6.550 -  end;
   6.551 -
   6.552 -fun define_coiters coiterNs (_, cs, cpss, coiter_args_typess') mk_binding fpTs Cs dtor_coiters
   6.553 -    lthy =
   6.554 -  let
   6.555 -    val nn = length fpTs;
   6.556 -
   6.557 -    val C_to_fpT as Type (_, [_, fpT]) = snd (strip_typeN nn (fastype_of (hd dtor_coiters)));
   6.558 -
   6.559 -    fun generate_coiter pre ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
   6.560 -      (mk_binding pre,
   6.561 -       fold_rev (fold_rev Term.lambda) pfss (Term.list_comb (dtor_coiter,
   6.562 -         map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss)));
   6.563 -  in
   6.564 -    define_co_iters Greatest_FP fpT Cs
   6.565 -      (map3 generate_coiter coiterNs coiter_args_typess' dtor_coiters) lthy
   6.566 -  end;
   6.567 -
   6.568 -fun derive_induct_iters_thms_for_types pre_bnfs [fold_args_types, rec_args_types] ctor_induct
   6.569 -    ctor_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss iter_defss
   6.570 -    lthy =
   6.571 -  let
   6.572 -    val iterss' = transpose iterss;
   6.573 -    val iter_defss' = transpose iter_defss;
   6.574 -
   6.575 -    val [folds, recs] = iterss';
   6.576 -    val [fold_defs, rec_defs] = iter_defss';
   6.577 -
   6.578 -    val ctr_Tsss = map (map (binder_types o fastype_of)) ctrss;
   6.579 -
   6.580 -    val nn = length pre_bnfs;
   6.581 -    val ns = map length ctr_Tsss;
   6.582 -    val mss = map (map length) ctr_Tsss;
   6.583 -
   6.584 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
   6.585 -    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
   6.586 -    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
   6.587 -    val nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs;
   6.588 -    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
   6.589 -
   6.590 -    val fp_b_names = map base_name_of_typ fpTs;
   6.591 -
   6.592 -    val ((((ps, ps'), xsss), us'), names_lthy) =
   6.593 -      lthy
   6.594 -      |> mk_Frees' "P" (map mk_pred1T fpTs)
   6.595 -      ||>> mk_Freesss "x" ctr_Tsss
   6.596 -      ||>> Variable.variant_fixes fp_b_names;
   6.597 -
   6.598 -    val us = map2 (curry Free) us' fpTs;
   6.599 -
   6.600 -    fun mk_sets_nested bnf =
   6.601 -      let
   6.602 -        val Type (T_name, Us) = T_of_bnf bnf;
   6.603 -        val lives = lives_of_bnf bnf;
   6.604 -        val sets = sets_of_bnf bnf;
   6.605 -        fun mk_set U =
   6.606 -          (case find_index (curry (op =) U) lives of
   6.607 -            ~1 => Term.dummy
   6.608 -          | i => nth sets i);
   6.609 -      in
   6.610 -        (T_name, map mk_set Us)
   6.611 -      end;
   6.612 -
   6.613 -    val setss_nested = map mk_sets_nested nested_bnfs;
   6.614 -
   6.615 -    val (induct_thms, induct_thm) =
   6.616 -      let
   6.617 -        fun mk_set Ts t =
   6.618 -          let val Type (_, Ts0) = domain_type (fastype_of t) in
   6.619 -            Term.subst_atomic_types (Ts0 ~~ Ts) t
   6.620 -          end;
   6.621 -
   6.622 -        fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
   6.623 -            [([], (find_index (curry (op =) X) Xs + 1, x))]
   6.624 -          | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
   6.625 -            (case AList.lookup (op =) setss_nested T_name of
   6.626 -              NONE => []
   6.627 -            | SOME raw_sets0 =>
   6.628 -              let
   6.629 -                val (Xs_Ts, (Ts, raw_sets)) =
   6.630 -                  filter (exists_subtype_in Xs o fst) (Xs_Ts0 ~~ (Ts0 ~~ raw_sets0))
   6.631 -                  |> split_list ||> split_list;
   6.632 -                val sets = map (mk_set Ts0) raw_sets;
   6.633 -                val (ys, names_lthy') = names_lthy |> mk_Frees s Ts;
   6.634 -                val xysets = map (pair x) (ys ~~ sets);
   6.635 -                val ppremss = map2 (mk_raw_prem_prems names_lthy') ys Xs_Ts;
   6.636 -              in
   6.637 -                flat (map2 (map o apfst o cons) xysets ppremss)
   6.638 -              end)
   6.639 -          | mk_raw_prem_prems _ _ _ = [];
   6.640 -
   6.641 -        fun close_prem_prem xs t =
   6.642 -          fold_rev Logic.all (map Free (drop (nn + length xs)
   6.643 -            (rev (Term.add_frees t (map dest_Free xs @ ps'))))) t;
   6.644 -
   6.645 -        fun mk_prem_prem xs (xysets, (j, x)) =
   6.646 -          close_prem_prem xs (Logic.list_implies (map (fn (x', (y, set)) =>
   6.647 -              HOLogic.mk_Trueprop (HOLogic.mk_mem (y, set $ x'))) xysets,
   6.648 -            HOLogic.mk_Trueprop (nth ps (j - 1) $ x)));
   6.649 -
   6.650 -        fun mk_raw_prem phi ctr ctr_Ts ctrXs_Ts =
   6.651 -          let
   6.652 -            val (xs, names_lthy') = names_lthy |> mk_Frees "x" ctr_Ts;
   6.653 -            val pprems = flat (map2 (mk_raw_prem_prems names_lthy') xs ctrXs_Ts);
   6.654 -          in (xs, pprems, HOLogic.mk_Trueprop (phi $ Term.list_comb (ctr, xs))) end;
   6.655 -
   6.656 -        fun mk_prem (xs, raw_pprems, concl) =
   6.657 -          fold_rev Logic.all xs (Logic.list_implies (map (mk_prem_prem xs) raw_pprems, concl));
   6.658 -
   6.659 -        val raw_premss = map4 (map3 o mk_raw_prem) ps ctrss ctr_Tsss ctrXs_Tsss;
   6.660 -
   6.661 -        val goal =
   6.662 -          Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
   6.663 -            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
   6.664 -
   6.665 -        val kksss = map (map (map (fst o snd) o #2)) raw_premss;
   6.666 -
   6.667 -        val ctor_induct' = ctor_induct OF (map mk_sumEN_tupled_balanced mss);
   6.668 -
   6.669 -        val thm =
   6.670 -          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
   6.671 -            mk_induct_tac ctxt nn ns mss kksss (flat ctr_defss) ctor_induct' nested_set_maps
   6.672 -              pre_set_defss)
   6.673 -          |> singleton (Proof_Context.export names_lthy lthy)
   6.674 -          |> Thm.close_derivation;
   6.675 -      in
   6.676 -        `(conj_dests nn) thm
   6.677 -      end;
   6.678 -
   6.679 -    val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss);
   6.680 -    val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases));
   6.681 -
   6.682 -    val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss;
   6.683 -
   6.684 -    fun mk_iter_thmss (_, x_Tssss, fss, _) iters iter_defs ctor_iter_thms =
   6.685 -      let
   6.686 -        val fiters = map (lists_bmoc fss) iters;
   6.687 -
   6.688 -        fun mk_goal fss fiter xctr f xs fxs =
   6.689 -          fold_rev (fold_rev Logic.all) (xs :: fss)
   6.690 -            (mk_Trueprop_eq (fiter $ xctr, Term.list_comb (f, fxs)));
   6.691 -
   6.692 -        fun maybe_tick (T, U) u f =
   6.693 -          if try (fst o HOLogic.dest_prodT) U = SOME T then
   6.694 -            Term.lambda u (HOLogic.mk_prod (u, f $ u))
   6.695 -          else
   6.696 -            f;
   6.697 -
   6.698 -        fun build_iter (x as Free (_, T)) U =
   6.699 -          if T = U then
   6.700 -            x
   6.701 -          else
   6.702 -            build_map lthy (indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs
   6.703 -              (fn kk => fn TU => maybe_tick TU (nth us kk) (nth fiters kk))) (T, U) $ x;
   6.704 -
   6.705 -        val fxsss = map2 (map2 (flat_rec_arg_args oo map2 (map o build_iter))) xsss x_Tssss;
   6.706 -
   6.707 -        val goalss = map5 (map4 o mk_goal fss) fiters xctrss fss xsss fxsss;
   6.708 -
   6.709 -        val tacss =
   6.710 -          map2 (map o mk_iter_tac pre_map_defs (nested_map_idents @ nesting_map_idents) iter_defs)
   6.711 -            ctor_iter_thms ctr_defss;
   6.712 -
   6.713 -        fun prove goal tac =
   6.714 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
   6.715 -          |> Thm.close_derivation;
   6.716 -      in
   6.717 -        map2 (map2 prove) goalss tacss
   6.718 -      end;
   6.719 -
   6.720 -    val fold_thmss = mk_iter_thmss fold_args_types folds fold_defs (map un_fold_of ctor_iter_thmss);
   6.721 -    val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
   6.722 -  in
   6.723 -    ((induct_thms, induct_thm, [induct_case_names_attr]),
   6.724 -     (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
   6.725 -  end;
   6.726 -
   6.727 -fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
   6.728 -      coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
   6.729 -    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
   6.730 -    mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
   6.731 -  let
   6.732 -    fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
   6.733 -      iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
   6.734 -
   6.735 -    val ctor_dtor_coiter_thmss =
   6.736 -      map3 (map oo mk_ctor_dtor_coiter_thm) dtor_injects dtor_ctors dtor_coiter_thmss;
   6.737 -
   6.738 -    val coiterss' = transpose coiterss;
   6.739 -    val coiter_defss' = transpose coiter_defss;
   6.740 -
   6.741 -    val [unfold_defs, corec_defs] = coiter_defss';
   6.742 -
   6.743 -    val nn = length pre_bnfs;
   6.744 -
   6.745 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
   6.746 -    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
   6.747 -    val nesting_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nesting_bnfs;
   6.748 -    val nesting_rel_eqs = map rel_eq_of_bnf nesting_bnfs;
   6.749 -
   6.750 -    val fp_b_names = map base_name_of_typ fpTs;
   6.751 -
   6.752 -    val ctrss = map #ctrs ctr_sugars;
   6.753 -    val discss = map #discs ctr_sugars;
   6.754 -    val selsss = map #selss ctr_sugars;
   6.755 -    val exhausts = map #exhaust ctr_sugars;
   6.756 -    val disc_thmsss = map #disc_thmss ctr_sugars;
   6.757 -    val discIss = map #discIs ctr_sugars;
   6.758 -    val sel_thmsss = map #sel_thmss ctr_sugars;
   6.759 -
   6.760 -    val (((rs, us'), vs'), names_lthy) =
   6.761 -      lthy
   6.762 -      |> mk_Frees "R" (map (fn T => mk_pred2T T T) fpTs)
   6.763 -      ||>> Variable.variant_fixes fp_b_names
   6.764 -      ||>> Variable.variant_fixes (map (suffix "'") fp_b_names);
   6.765 -
   6.766 -    val us = map2 (curry Free) us' fpTs;
   6.767 -    val udiscss = map2 (map o rapp) us discss;
   6.768 -    val uselsss = map2 (map o map o rapp) us selsss;
   6.769 -
   6.770 -    val vs = map2 (curry Free) vs' fpTs;
   6.771 -    val vdiscss = map2 (map o rapp) vs discss;
   6.772 -    val vselsss = map2 (map o map o rapp) vs selsss;
   6.773 -
   6.774 -    val coinduct_thms_pairs =
   6.775 -      let
   6.776 -        val uvrs = map3 (fn r => fn u => fn v => r $ u $ v) rs us vs;
   6.777 -        val uv_eqs = map2 (curry HOLogic.mk_eq) us vs;
   6.778 -        val strong_rs =
   6.779 -          map4 (fn u => fn v => fn uvr => fn uv_eq =>
   6.780 -            fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
   6.781 -
   6.782 -        fun build_the_rel rs' T Xs_T =
   6.783 -          build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
   6.784 -          |> Term.subst_atomic_types (Xs ~~ fpTs);
   6.785 -
   6.786 -        fun build_rel_app rs' usel vsel Xs_T =
   6.787 -          fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
   6.788 -
   6.789 -        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
   6.790 -          (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
   6.791 -          (if null usels then
   6.792 -             []
   6.793 -           else
   6.794 -             [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
   6.795 -                Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
   6.796 -
   6.797 -        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
   6.798 -          Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
   6.799 -            (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
   6.800 -          handle List.Empty => @{term True};
   6.801 -
   6.802 -        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
   6.803 -          fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
   6.804 -            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
   6.805 -
   6.806 -        val concl =
   6.807 -          HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
   6.808 -            (map3 (fn uvr => fn u => fn v => HOLogic.mk_imp (uvr, HOLogic.mk_eq (u, v)))
   6.809 -               uvrs us vs));
   6.810 -
   6.811 -        fun mk_goal rs' =
   6.812 -          Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
   6.813 -            ctrXs_Tsss, concl);
   6.814 -
   6.815 -        val goals = map mk_goal [rs, strong_rs];
   6.816 -
   6.817 -        fun prove dtor_coinduct' goal =
   6.818 -          Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
   6.819 -            mk_coinduct_tac ctxt nesting_rel_eqs nn ns dtor_coinduct' pre_rel_defs dtor_ctors
   6.820 -              exhausts ctr_defss disc_thmsss sel_thmsss)
   6.821 -          |> singleton (Proof_Context.export names_lthy lthy)
   6.822 -          |> Thm.close_derivation;
   6.823 -
   6.824 -        fun postproc nn thm =
   6.825 -          Thm.permute_prems 0 nn
   6.826 -            (if nn = 1 then thm RS mp else funpow nn (fn thm => reassoc_conjs (thm RS mp_conj)) thm)
   6.827 -          |> Drule.zero_var_indexes
   6.828 -          |> `(conj_dests nn);
   6.829 -
   6.830 -        val rel_eqs = map rel_eq_of_bnf pre_bnfs;
   6.831 -        val rel_monos = map rel_mono_of_bnf pre_bnfs;
   6.832 -        val dtor_coinducts =
   6.833 -          [dtor_coinduct, mk_strong_coinduct_thm dtor_coinduct rel_eqs rel_monos lthy];
   6.834 -      in
   6.835 -        map2 (postproc nn oo prove) dtor_coinducts goals
   6.836 -      end;
   6.837 -
   6.838 -    fun mk_coinduct_concls ms discs ctrs =
   6.839 -      let
   6.840 -        fun mk_disc_concl disc = [name_of_disc disc];
   6.841 -        fun mk_ctr_concl 0 _ = []
   6.842 -          | mk_ctr_concl _ ctor = [name_of_ctr ctor];
   6.843 -        val disc_concls = map mk_disc_concl (fst (split_last discs)) @ [[]];
   6.844 -        val ctr_concls = map2 mk_ctr_concl ms ctrs;
   6.845 -      in
   6.846 -        flat (map2 append disc_concls ctr_concls)
   6.847 -      end;
   6.848 -
   6.849 -    val coinduct_cases = quasi_unambiguous_case_names (map (prefix EqN) fp_b_names);
   6.850 -    val coinduct_conclss =
   6.851 -      map3 (quasi_unambiguous_case_names ooo mk_coinduct_concls) mss discss ctrss;
   6.852 -
   6.853 -    fun mk_maybe_not pos = not pos ? HOLogic.mk_not;
   6.854 -
   6.855 -    val fcoiterss' as [gunfolds, hcorecs] =
   6.856 -      map2 (fn (pfss, _) => map (lists_bmoc pfss)) (map fst coiters_args_types) coiterss';
   6.857 -
   6.858 -    val (unfold_thmss, corec_thmss) =
   6.859 -      let
   6.860 -        fun mk_goal pfss c cps fcoiter n k ctr m cfs' =
   6.861 -          fold_rev (fold_rev Logic.all) ([c] :: pfss)
   6.862 -            (Logic.list_implies (seq_conds (HOLogic.mk_Trueprop oo mk_maybe_not) n k cps,
   6.863 -               mk_Trueprop_eq (fcoiter $ c, Term.list_comb (ctr, take m cfs'))));
   6.864 -
   6.865 -        fun mk_U maybe_mk_sumT =
   6.866 -          typ_subst_nonatomic (map2 (fn C => fn fpT => (maybe_mk_sumT fpT C, fpT)) Cs fpTs);
   6.867 -
   6.868 -        fun tack z_name (c, u) f =
   6.869 -          let val z = Free (z_name, mk_sumT (fastype_of u, fastype_of c)) in
   6.870 -            Term.lambda z (mk_sum_case (Term.lambda u u, Term.lambda c (f $ c)) $ z)
   6.871 -          end;
   6.872 -
   6.873 -        fun build_coiter fcoiters maybe_mk_sumT maybe_tack cqf =
   6.874 -          let val T = fastype_of cqf in
   6.875 -            if exists_subtype_in Cs T then
   6.876 -              let val U = mk_U maybe_mk_sumT T in
   6.877 -                build_map lthy (indexify snd fpTs (fn kk => fn _ =>
   6.878 -                  maybe_tack (nth cs kk, nth us kk) (nth fcoiters kk))) (T, U) $ cqf
   6.879 -              end
   6.880 -            else
   6.881 -              cqf
   6.882 -          end;
   6.883 -
   6.884 -        val crgsss' = map (map (map (build_coiter (un_fold_of fcoiterss') (K I) (K I)))) crgsss;
   6.885 -        val cshsss' = map (map (map (build_coiter (co_rec_of fcoiterss') (curry mk_sumT) (tack z))))
   6.886 -          cshsss;
   6.887 -
   6.888 -        val unfold_goalss = map8 (map4 oooo mk_goal pgss) cs cpss gunfolds ns kss ctrss mss crgsss';
   6.889 -        val corec_goalss = map8 (map4 oooo mk_goal phss) cs cpss hcorecs ns kss ctrss mss cshsss';
   6.890 -
   6.891 -        val unfold_tacss =
   6.892 -          map3 (map oo mk_coiter_tac unfold_defs nesting_map_idents)
   6.893 -            (map un_fold_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
   6.894 -        val corec_tacss =
   6.895 -          map3 (map oo mk_coiter_tac corec_defs nesting_map_idents)
   6.896 -            (map co_rec_of ctor_dtor_coiter_thmss) pre_map_defs ctr_defss;
   6.897 -
   6.898 -        fun prove goal tac =
   6.899 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
   6.900 -          |> Thm.close_derivation;
   6.901 -
   6.902 -        val unfold_thmss = map2 (map2 prove) unfold_goalss unfold_tacss;
   6.903 -        val corec_thmss =
   6.904 -          map2 (map2 prove) corec_goalss corec_tacss
   6.905 -          |> map (map (unfold_thms lthy @{thms sum_case_if}));
   6.906 -      in
   6.907 -        (unfold_thmss, corec_thmss)
   6.908 -      end;
   6.909 -
   6.910 -    val (disc_unfold_iff_thmss, disc_corec_iff_thmss) =
   6.911 -      let
   6.912 -        fun mk_goal c cps fcoiter n k disc =
   6.913 -          mk_Trueprop_eq (disc $ (fcoiter $ c),
   6.914 -            if n = 1 then @{const True}
   6.915 -            else Library.foldr1 HOLogic.mk_conj (seq_conds mk_maybe_not n k cps));
   6.916 -
   6.917 -        val unfold_goalss = map6 (map2 oooo mk_goal) cs cpss gunfolds ns kss discss;
   6.918 -        val corec_goalss = map6 (map2 oooo mk_goal) cs cpss hcorecs ns kss discss;
   6.919 -
   6.920 -        fun mk_case_split' cp = Drule.instantiate' [] [SOME (certify lthy cp)] @{thm case_split};
   6.921 -
   6.922 -        val case_splitss' = map (map mk_case_split') cpss;
   6.923 -
   6.924 -        val unfold_tacss =
   6.925 -          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' unfold_thmss disc_thmsss;
   6.926 -        val corec_tacss =
   6.927 -          map3 (map oo mk_disc_coiter_iff_tac) case_splitss' corec_thmss disc_thmsss;
   6.928 -
   6.929 -        fun prove goal tac =
   6.930 -          Goal.prove_sorry lthy [] [] goal (tac o #context)
   6.931 -          |> singleton export_args
   6.932 -          |> singleton (Proof_Context.export names_lthy lthy)
   6.933 -          |> Thm.close_derivation;
   6.934 -
   6.935 -        fun proves [_] [_] = []
   6.936 -          | proves goals tacs = map2 prove goals tacs;
   6.937 -      in
   6.938 -        (map2 proves unfold_goalss unfold_tacss, map2 proves corec_goalss corec_tacss)
   6.939 -      end;
   6.940 -
   6.941 -    fun mk_disc_coiter_thms coiters discIs = map (op RS) (coiters ~~ discIs);
   6.942 -
   6.943 -    val disc_unfold_thmss = map2 mk_disc_coiter_thms unfold_thmss discIss;
   6.944 -    val disc_corec_thmss = map2 mk_disc_coiter_thms corec_thmss discIss;
   6.945 -
   6.946 -    fun mk_sel_coiter_thm coiter_thm sel sel_thm =
   6.947 -      let
   6.948 -        val (domT, ranT) = dest_funT (fastype_of sel);
   6.949 -        val arg_cong' =
   6.950 -          Drule.instantiate' (map (SOME o certifyT lthy) [domT, ranT])
   6.951 -            [NONE, NONE, SOME (certify lthy sel)] arg_cong
   6.952 -          |> Thm.varifyT_global;
   6.953 -        val sel_thm' = sel_thm RSN (2, trans);
   6.954 -      in
   6.955 -        coiter_thm RS arg_cong' RS sel_thm'
   6.956 -      end;
   6.957 -
   6.958 -    fun mk_sel_coiter_thms coiter_thmss =
   6.959 -      map3 (map3 (map2 o mk_sel_coiter_thm)) coiter_thmss selsss sel_thmsss;
   6.960 -
   6.961 -    val sel_unfold_thmsss = mk_sel_coiter_thms unfold_thmss;
   6.962 -    val sel_corec_thmsss = mk_sel_coiter_thms corec_thmss;
   6.963 -
   6.964 -    val coinduct_consumes_attr = Attrib.internal (K (Rule_Cases.consumes nn));
   6.965 -    val coinduct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names coinduct_cases));
   6.966 -    val coinduct_case_concl_attrs =
   6.967 -      map2 (fn casex => fn concls =>
   6.968 -          Attrib.internal (K (Rule_Cases.case_conclusion (casex, concls))))
   6.969 -        coinduct_cases coinduct_conclss;
   6.970 -    val coinduct_case_attrs =
   6.971 -      coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
   6.972 -  in
   6.973 -    ((coinduct_thms_pairs, coinduct_case_attrs),
   6.974 -     (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
   6.975 -     (disc_unfold_thmss, disc_corec_thmss, []),
   6.976 -     (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
   6.977 -     (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
   6.978 -  end;
   6.979 -
   6.980 -fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp
   6.981 -    (wrap_opts as (no_discs_sels, (_, rep_compat)), specs) no_defs_lthy0 =
   6.982 -  let
   6.983 -    (* TODO: sanity checks on arguments *)
   6.984 -
   6.985 -    val _ = if fp = Greatest_FP andalso no_discs_sels then
   6.986 -        error "Cannot define codatatypes without discriminators and selectors"
   6.987 -      else
   6.988 -        ();
   6.989 -
   6.990 -    fun qualify mandatory fp_b_name =
   6.991 -      Binding.qualify mandatory fp_b_name o (rep_compat ? Binding.qualify false rep_compat_prefix);
   6.992 -
   6.993 -    val nn = length specs;
   6.994 -    val fp_bs = map type_binding_of specs;
   6.995 -    val fp_b_names = map Binding.name_of fp_bs;
   6.996 -    val fp_common_name = mk_common_name fp_b_names;
   6.997 -    val map_bs = map map_binding_of specs;
   6.998 -    val rel_bs = map rel_binding_of specs;
   6.999 -
  6.1000 -    fun prepare_type_arg (_, (ty, c)) =
  6.1001 -      let val TFree (s, _) = prepare_typ no_defs_lthy0 ty in
  6.1002 -        TFree (s, prepare_constraint no_defs_lthy0 c)
  6.1003 -      end;
  6.1004 -
  6.1005 -    val Ass0 = map (map prepare_type_arg o type_args_named_constrained_of) specs;
  6.1006 -    val unsorted_Ass0 = map (map (resort_tfree HOLogic.typeS)) Ass0;
  6.1007 -    val unsorted_As = Library.foldr1 merge_type_args unsorted_Ass0;
  6.1008 -    val num_As = length unsorted_As;
  6.1009 -    val set_bss = map (map fst o type_args_named_constrained_of) specs;
  6.1010 -
  6.1011 -    val (((Bs0, Cs), Xs), no_defs_lthy) =
  6.1012 -      no_defs_lthy0
  6.1013 -      |> fold (Variable.declare_typ o resort_tfree dummyS) unsorted_As
  6.1014 -      |> mk_TFrees num_As
  6.1015 -      ||>> mk_TFrees nn
  6.1016 -      ||>> variant_tfrees fp_b_names;
  6.1017 -
  6.1018 -    fun add_fake_type spec = Typedecl.basic_typedecl (type_binding_of spec, num_As, mixfix_of spec);
  6.1019 -
  6.1020 -    val (fake_T_names, fake_lthy) = fold_map add_fake_type specs no_defs_lthy0;
  6.1021 -
  6.1022 -    val qsoty = quote o Syntax.string_of_typ fake_lthy;
  6.1023 -
  6.1024 -    val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
  6.1025 -      | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
  6.1026 -          "datatype specification"));
  6.1027 -
  6.1028 -    val bad_args =
  6.1029 -      map (Logic.type_map (singleton (Variable.polymorphic no_defs_lthy0))) unsorted_As
  6.1030 -      |> filter_out Term.is_TVar;
  6.1031 -    val _ = null bad_args orelse
  6.1032 -      error ("Locally fixed type argument " ^ qsoty (hd bad_args) ^ " in " ^ co_prefix fp ^
  6.1033 -        "datatype specification");
  6.1034 -
  6.1035 -    val mixfixes = map mixfix_of specs;
  6.1036 -
  6.1037 -    val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
  6.1038 -      | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
  6.1039 -
  6.1040 -    val ctr_specss = map ctr_specs_of specs;
  6.1041 -
  6.1042 -    val disc_bindingss = map (map disc_of) ctr_specss;
  6.1043 -    val ctr_bindingss =
  6.1044 -      map2 (fn fp_b_name => map (qualify false fp_b_name o ctr_of)) fp_b_names ctr_specss;
  6.1045 -    val ctr_argsss = map (map args_of) ctr_specss;
  6.1046 -    val ctr_mixfixess = map (map ctr_mixfix_of) ctr_specss;
  6.1047 -
  6.1048 -    val sel_bindingsss = map (map (map fst)) ctr_argsss;
  6.1049 -    val fake_ctr_Tsss0 = map (map (map (prepare_typ fake_lthy o snd))) ctr_argsss;
  6.1050 -    val raw_sel_defaultsss = map (map defaults_of) ctr_specss;
  6.1051 -
  6.1052 -    val (As :: _) :: fake_ctr_Tsss =
  6.1053 -      burrow (burrow (Syntax.check_typs fake_lthy)) (Ass0 :: fake_ctr_Tsss0);
  6.1054 -    val As' = map dest_TFree As;
  6.1055 -
  6.1056 -    val rhs_As' = fold (fold (fold Term.add_tfreesT)) fake_ctr_Tsss [];
  6.1057 -    val _ = (case subtract (op =) As' rhs_As' of [] => ()
  6.1058 -      | extras => error ("Extra type variables on right-hand side: " ^
  6.1059 -          commas (map (qsoty o TFree) extras)));
  6.1060 -
  6.1061 -    val fake_Ts = map (fn s => Type (s, As)) fake_T_names;
  6.1062 -
  6.1063 -    fun eq_fpT_check (T as Type (s, Ts)) (T' as Type (s', Ts')) =
  6.1064 -        s = s' andalso (Ts = Ts' orelse
  6.1065 -          error ("Wrong type arguments in " ^ co_prefix fp ^ "recursive type " ^ qsoty T ^
  6.1066 -            " (expected " ^ qsoty T' ^ ")"))
  6.1067 -      | eq_fpT_check _ _ = false;
  6.1068 -
  6.1069 -    fun freeze_fp (T as Type (s, Ts)) =
  6.1070 -        (case find_index (eq_fpT_check T) fake_Ts of
  6.1071 -          ~1 => Type (s, map freeze_fp Ts)
  6.1072 -        | kk => nth Xs kk)
  6.1073 -      | freeze_fp T = T;
  6.1074 -
  6.1075 -    val unfreeze_fp = Term.typ_subst_atomic (Xs ~~ fake_Ts);
  6.1076 -
  6.1077 -    val ctrXs_Tsss = map (map (map freeze_fp)) fake_ctr_Tsss;
  6.1078 -    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  6.1079 -
  6.1080 -    val fp_eqs =
  6.1081 -      map dest_TFree Xs ~~ map (Term.typ_subst_atomic (As ~~ unsorted_As)) ctrXs_sum_prod_Ts;
  6.1082 -
  6.1083 -    val rhsXs_As' = fold (fold (fold Term.add_tfreesT)) ctrXs_Tsss [];
  6.1084 -    val _ = (case subtract (op =) rhsXs_As' As' of [] => ()
  6.1085 -      | extras => List.app (fn extra => warning ("Unused type variable on right-hand side of " ^
  6.1086 -          co_prefix fp ^ "datatype definition: " ^ qsoty (TFree extra))) extras);
  6.1087 -
  6.1088 -    val (pre_bnfs, (fp_res as {bnfs = fp_bnfs as any_fp_bnf :: _, ctors = ctors0, dtors = dtors0,
  6.1089 -           xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_ctors, ctor_dtors, ctor_injects,
  6.1090 -           dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms, xtor_co_iter_thmss, ...},
  6.1091 -           lthy)) =
  6.1092 -      fp_bnf (construct_fp mixfixes map_bs rel_bs set_bss) fp_bs (map dest_TFree unsorted_As) fp_eqs
  6.1093 -        no_defs_lthy0
  6.1094 -      handle BAD_DEAD (X, X_backdrop) =>
  6.1095 -        (case X_backdrop of
  6.1096 -          Type (bad_tc, _) =>
  6.1097 -          let
  6.1098 -            val fake_T = qsoty (unfreeze_fp X);
  6.1099 -            val fake_T_backdrop = qsoty (unfreeze_fp X_backdrop);
  6.1100 -            fun register_hint () =
  6.1101 -              "\nUse the " ^ quote (fst (fst @{command_spec "bnf"})) ^ " command to register " ^
  6.1102 -              quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \
  6.1103 -              \it";
  6.1104 -          in
  6.1105 -            if is_some (bnf_of no_defs_lthy bad_tc) orelse
  6.1106 -               is_some (fp_sugar_of no_defs_lthy bad_tc) then
  6.1107 -              error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
  6.1108 -                " in type expression " ^ fake_T_backdrop)
  6.1109 -            else if is_some (Datatype_Data.get_info (Proof_Context.theory_of no_defs_lthy)
  6.1110 -                bad_tc) then
  6.1111 -              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
  6.1112 -                " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^
  6.1113 -                fake_T_backdrop ^ register_hint ())
  6.1114 -            else
  6.1115 -              error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
  6.1116 -                " via type constructor " ^ quote bad_tc ^ " in type expression " ^ fake_T_backdrop ^
  6.1117 -                register_hint ())
  6.1118 -          end);
  6.1119 -
  6.1120 -    val time = time lthy;
  6.1121 -    val timer = time (Timer.startRealTimer ());
  6.1122 -
  6.1123 -    val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  6.1124 -    val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  6.1125 -
  6.1126 -    val pre_map_defs = map map_def_of_bnf pre_bnfs;
  6.1127 -    val pre_set_defss = map set_defs_of_bnf pre_bnfs;
  6.1128 -    val pre_rel_defs = map rel_def_of_bnf pre_bnfs;
  6.1129 -    val nesting_set_maps = maps set_map_of_bnf nesting_bnfs;
  6.1130 -    val nested_set_maps = maps set_map_of_bnf nested_bnfs;
  6.1131 -
  6.1132 -    val live = live_of_bnf any_fp_bnf;
  6.1133 -    val _ =
  6.1134 -      if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs) then
  6.1135 -        warning "Map function and relator names ignored"
  6.1136 -      else
  6.1137 -        ();
  6.1138 -
  6.1139 -    val Bs =
  6.1140 -      map3 (fn alive => fn A as TFree (_, S) => fn B => if alive then resort_tfree S B else A)
  6.1141 -        (liveness_of_fp_bnf num_As any_fp_bnf) As Bs0;
  6.1142 -
  6.1143 -    val B_ify = Term.typ_subst_atomic (As ~~ Bs);
  6.1144 -
  6.1145 -    val ctors = map (mk_ctor As) ctors0;
  6.1146 -    val dtors = map (mk_dtor As) dtors0;
  6.1147 -
  6.1148 -    val fpTs = map (domain_type o fastype_of) dtors;
  6.1149 -
  6.1150 -    fun massage_simple_notes base =
  6.1151 -      filter_out (null o #2)
  6.1152 -      #> map (fn (thmN, thms, attrs) =>
  6.1153 -        ((qualify true base (Binding.name thmN), attrs), [(thms, [])]));
  6.1154 -
  6.1155 -    val massage_multi_notes =
  6.1156 -      maps (fn (thmN, thmss, attrs) =>
  6.1157 -        map3 (fn fp_b_name => fn Type (T_name, _) => fn thms =>
  6.1158 -            ((qualify true fp_b_name (Binding.name thmN), attrs T_name), [(thms, [])]))
  6.1159 -          fp_b_names fpTs thmss)
  6.1160 -      #> filter_out (null o fst o hd o snd);
  6.1161 -
  6.1162 -    val ctr_Tsss = map (map (map (Term.typ_subst_atomic (Xs ~~ fpTs)))) ctrXs_Tsss;
  6.1163 -    val ns = map length ctr_Tsss;
  6.1164 -    val kss = map (fn n => 1 upto n) ns;
  6.1165 -    val mss = map (map length) ctr_Tsss;
  6.1166 -
  6.1167 -    val ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy') =
  6.1168 -      mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  6.1169 -
  6.1170 -    fun define_ctrs_dtrs_for_type (((((((((((((((((((((((fp_bnf, fp_b), fpT), ctor), dtor),
  6.1171 -            xtor_co_iters), ctor_dtor), dtor_ctor), ctor_inject), pre_map_def), pre_set_defs),
  6.1172 -          pre_rel_def), fp_map_thm), fp_set_thms), fp_rel_thm), n), ks), ms), ctr_bindings),
  6.1173 -        ctr_mixfixes), ctr_Tss), disc_bindings), sel_bindingss), raw_sel_defaultss) no_defs_lthy =
  6.1174 -      let
  6.1175 -        val fp_b_name = Binding.name_of fp_b;
  6.1176 -
  6.1177 -        val dtorT = domain_type (fastype_of ctor);
  6.1178 -        val ctr_prod_Ts = map HOLogic.mk_tupleT ctr_Tss;
  6.1179 -        val ctr_sum_prod_T = mk_sumTN_balanced ctr_prod_Ts;
  6.1180 -
  6.1181 -        val ((((w, xss), yss), u'), names_lthy) =
  6.1182 -          no_defs_lthy
  6.1183 -          |> yield_singleton (mk_Frees "w") dtorT
  6.1184 -          ||>> mk_Freess "x" ctr_Tss
  6.1185 -          ||>> mk_Freess "y" (map (map B_ify) ctr_Tss)
  6.1186 -          ||>> yield_singleton Variable.variant_fixes fp_b_name;
  6.1187 -
  6.1188 -        val u = Free (u', fpT);
  6.1189 -
  6.1190 -        val tuple_xs = map HOLogic.mk_tuple xss;
  6.1191 -        val tuple_ys = map HOLogic.mk_tuple yss;
  6.1192 -
  6.1193 -        val ctr_rhss =
  6.1194 -          map3 (fn k => fn xs => fn tuple_x => fold_rev Term.lambda xs (ctor $
  6.1195 -            mk_InN_balanced ctr_sum_prod_T n tuple_x k)) ks xss tuple_xs;
  6.1196 -
  6.1197 -        val maybe_conceal_def_binding = Thm.def_binding
  6.1198 -          #> Config.get no_defs_lthy bnf_note_all = false ? Binding.conceal;
  6.1199 -
  6.1200 -        val ((raw_ctrs, raw_ctr_defs), (lthy', lthy)) = no_defs_lthy
  6.1201 -          |> apfst split_list o fold_map3 (fn b => fn mx => fn rhs =>
  6.1202 -              Local_Theory.define ((b, mx), ((maybe_conceal_def_binding b, []), rhs)) #>> apsnd snd)
  6.1203 -            ctr_bindings ctr_mixfixes ctr_rhss
  6.1204 -          ||> `Local_Theory.restore;
  6.1205 -
  6.1206 -        val phi = Proof_Context.export_morphism lthy lthy';
  6.1207 -
  6.1208 -        val ctr_defs = map (Morphism.thm phi) raw_ctr_defs;
  6.1209 -        val ctr_defs' =
  6.1210 -          map2 (fn m => fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) ms ctr_defs;
  6.1211 -
  6.1212 -        val ctrs0 = map (Morphism.term phi) raw_ctrs;
  6.1213 -        val ctrs = map (mk_ctr As) ctrs0;
  6.1214 -
  6.1215 -        fun wrap_ctrs lthy =
  6.1216 -          let
  6.1217 -            fun exhaust_tac {context = ctxt, prems = _} =
  6.1218 -              let
  6.1219 -                val ctor_iff_dtor_thm =
  6.1220 -                  let
  6.1221 -                    val goal =
  6.1222 -                      fold_rev Logic.all [w, u]
  6.1223 -                        (mk_Trueprop_eq (HOLogic.mk_eq (u, ctor $ w), HOLogic.mk_eq (dtor $ u, w)));
  6.1224 -                  in
  6.1225 -                    Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
  6.1226 -                      mk_ctor_iff_dtor_tac ctxt (map (SOME o certifyT lthy) [dtorT, fpT])
  6.1227 -                        (certify lthy ctor) (certify lthy dtor) ctor_dtor dtor_ctor)
  6.1228 -                    |> Thm.close_derivation
  6.1229 -                    |> Morphism.thm phi
  6.1230 -                  end;
  6.1231 -
  6.1232 -                val sumEN_thm' =
  6.1233 -                  unfold_thms lthy @{thms unit_all_eq1}
  6.1234 -                    (Drule.instantiate' (map (SOME o certifyT lthy) ctr_prod_Ts) []
  6.1235 -                       (mk_sumEN_balanced n))
  6.1236 -                  |> Morphism.thm phi;
  6.1237 -              in
  6.1238 -                mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor_thm sumEN_thm'
  6.1239 -              end;
  6.1240 -
  6.1241 -            val inject_tacss =
  6.1242 -              map2 (fn 0 => K [] | _ => fn ctr_def => [fn {context = ctxt, ...} =>
  6.1243 -                mk_inject_tac ctxt ctr_def ctor_inject]) ms ctr_defs;
  6.1244 -
  6.1245 -            val half_distinct_tacss =
  6.1246 -              map (map (fn (def, def') => fn {context = ctxt, ...} =>
  6.1247 -                mk_half_distinct_tac ctxt ctor_inject [def, def'])) (mk_half_pairss (`I ctr_defs));
  6.1248 -
  6.1249 -            val tacss = [exhaust_tac] :: inject_tacss @ half_distinct_tacss;
  6.1250 -
  6.1251 -            val sel_defaultss = map (map (apsnd (prepare_term lthy))) raw_sel_defaultss
  6.1252 -          in
  6.1253 -            wrap_free_constructors tacss (((wrap_opts, ctrs0), standard_binding), (disc_bindings,
  6.1254 -              (sel_bindingss, sel_defaultss))) lthy
  6.1255 -          end;
  6.1256 -
  6.1257 -        fun derive_maps_sets_rels (ctr_sugar, lthy) =
  6.1258 -          if live = 0 then
  6.1259 -            ((([], [], [], []), ctr_sugar), lthy)
  6.1260 -          else
  6.1261 -            let
  6.1262 -              val rel_flip = rel_flip_of_bnf fp_bnf;
  6.1263 -              val nones = replicate live NONE;
  6.1264 -
  6.1265 -              val ctor_cong =
  6.1266 -                if fp = Least_FP then
  6.1267 -                  Drule.dummy_thm
  6.1268 -                else
  6.1269 -                  let val ctor' = mk_ctor Bs ctor in
  6.1270 -                    cterm_instantiate_pos [NONE, NONE, SOME (certify lthy ctor')] arg_cong
  6.1271 -                  end;
  6.1272 -
  6.1273 -              fun mk_cIn ify =
  6.1274 -                certify lthy o (fp = Greatest_FP ? curry (op $) (map_types ify ctor)) oo
  6.1275 -                mk_InN_balanced (ify ctr_sum_prod_T) n;
  6.1276 -
  6.1277 -              val cxIns = map2 (mk_cIn I) tuple_xs ks;
  6.1278 -              val cyIns = map2 (mk_cIn B_ify) tuple_ys ks;
  6.1279 -
  6.1280 -              fun mk_map_thm ctr_def' cxIn =
  6.1281 -                fold_thms lthy [ctr_def']
  6.1282 -                  (unfold_thms lthy (pre_map_def ::
  6.1283 -                       (if fp = Least_FP then [] else [ctor_dtor, dtor_ctor]) @ sum_prod_thms_map)
  6.1284 -                     (cterm_instantiate_pos (nones @ [SOME cxIn])
  6.1285 -                        (if fp = Least_FP then fp_map_thm else fp_map_thm RS ctor_cong)))
  6.1286 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
  6.1287 -
  6.1288 -              fun mk_set_thm fp_set_thm ctr_def' cxIn =
  6.1289 -                fold_thms lthy [ctr_def']
  6.1290 -                  (unfold_thms lthy (pre_set_defs @ nested_set_maps @ nesting_set_maps @
  6.1291 -                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_set)
  6.1292 -                     (cterm_instantiate_pos [SOME cxIn] fp_set_thm))
  6.1293 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
  6.1294 -
  6.1295 -              fun mk_set_thms fp_set_thm = map2 (mk_set_thm fp_set_thm) ctr_defs' cxIns;
  6.1296 -
  6.1297 -              val map_thms = map2 mk_map_thm ctr_defs' cxIns;
  6.1298 -              val set_thmss = map mk_set_thms fp_set_thms;
  6.1299 -
  6.1300 -              val rel_infos = (ctr_defs' ~~ cxIns, ctr_defs' ~~ cyIns);
  6.1301 -
  6.1302 -              fun mk_rel_thm postproc ctr_defs' cxIn cyIn =
  6.1303 -                fold_thms lthy ctr_defs'
  6.1304 -                  (unfold_thms lthy (@{thm Inl_Inr_False} :: pre_rel_def ::
  6.1305 -                       (if fp = Least_FP then [] else [dtor_ctor]) @ sum_prod_thms_rel)
  6.1306 -                     (cterm_instantiate_pos (nones @ [SOME cxIn, SOME cyIn]) fp_rel_thm))
  6.1307 -                |> postproc
  6.1308 -                |> singleton (Proof_Context.export names_lthy no_defs_lthy);
  6.1309 -
  6.1310 -              fun mk_rel_inject_thm ((ctr_def', cxIn), (_, cyIn)) =
  6.1311 -                mk_rel_thm (unfold_thms lthy @{thms eq_sym_Unity_conv}) [ctr_def'] cxIn cyIn;
  6.1312 -
  6.1313 -              val rel_inject_thms = map mk_rel_inject_thm (op ~~ rel_infos);
  6.1314 -
  6.1315 -              fun mk_half_rel_distinct_thm ((xctr_def', cxIn), (yctr_def', cyIn)) =
  6.1316 -                mk_rel_thm (fn thm => thm RS @{thm eq_False[THEN iffD1]}) [xctr_def', yctr_def']
  6.1317 -                  cxIn cyIn;
  6.1318 -
  6.1319 -              fun mk_other_half_rel_distinct_thm thm =
  6.1320 -                flip_rels lthy live thm
  6.1321 -                RS (rel_flip RS sym RS @{thm arg_cong[of _ _ Not]} RS iffD2);
  6.1322 -
  6.1323 -              val half_rel_distinct_thmss =
  6.1324 -                map (map mk_half_rel_distinct_thm) (mk_half_pairss rel_infos);
  6.1325 -              val other_half_rel_distinct_thmss =
  6.1326 -                map (map mk_other_half_rel_distinct_thm) half_rel_distinct_thmss;
  6.1327 -              val (rel_distinct_thms, _) =
  6.1328 -                join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
  6.1329 -
  6.1330 -              val anonymous_notes =
  6.1331 -                [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
  6.1332 -                  code_nitpicksimp_attrs),
  6.1333 -                 (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
  6.1334 -                    rel_inject_thms ms, code_nitpicksimp_attrs)]
  6.1335 -                |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
  6.1336 -
  6.1337 -              val notes =
  6.1338 -                [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
  6.1339 -                 (rel_distinctN, rel_distinct_thms, simp_attrs),
  6.1340 -                 (rel_injectN, rel_inject_thms, simp_attrs),
  6.1341 -                 (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
  6.1342 -                |> massage_simple_notes fp_b_name;
  6.1343 -            in
  6.1344 -              (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
  6.1345 -               lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
  6.1346 -            end;
  6.1347 -
  6.1348 -        fun mk_binding pre = qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b);
  6.1349 -
  6.1350 -        fun massage_res (((maps_sets_rels, ctr_sugar), co_iter_res), lthy) =
  6.1351 -          (((maps_sets_rels, (ctrs, xss, ctr_defs, ctr_sugar)), co_iter_res), lthy);
  6.1352 -      in
  6.1353 -        (wrap_ctrs
  6.1354 -         #> derive_maps_sets_rels
  6.1355 -         ##>>
  6.1356 -           (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  6.1357 -            else define_coiters [unfoldN, corecN] (the coiters_args_types))
  6.1358 -             mk_binding fpTs Cs xtor_co_iters
  6.1359 -         #> massage_res, lthy')
  6.1360 -      end;
  6.1361 -
  6.1362 -    fun wrap_types_etc (wrap_types_etcs, lthy) =
  6.1363 -      fold_map I wrap_types_etcs lthy
  6.1364 -      |>> apsnd split_list o apfst (apsnd split_list4 o apfst split_list4 o split_list)
  6.1365 -        o split_list;
  6.1366 -
  6.1367 -    fun mk_simp_thms ({injects, distincts, case_thms, ...} : ctr_sugar) un_folds co_recs
  6.1368 -        mapsx rel_injects rel_distincts setss =
  6.1369 -      injects @ distincts @ case_thms @ co_recs @ un_folds @ mapsx @ rel_injects @ rel_distincts
  6.1370 -      @ flat setss;
  6.1371 -
  6.1372 -    fun derive_note_induct_iters_thms_for_types
  6.1373 -        ((((mapss, rel_injects, rel_distincts, setss), (ctrss, _, ctr_defss, ctr_sugars)),
  6.1374 -          (iterss, iter_defss)), lthy) =
  6.1375 -      let
  6.1376 -        val ((induct_thms, induct_thm, induct_attrs), (fold_thmss, rec_thmss, iter_attrs)) =
  6.1377 -          derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  6.1378 -            xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss iterss
  6.1379 -            iter_defss lthy;
  6.1380 -
  6.1381 -        val induct_type_attr = Attrib.internal o K o Induct.induct_type;
  6.1382 -
  6.1383 -        val simp_thmss =
  6.1384 -          map7 mk_simp_thms ctr_sugars fold_thmss rec_thmss mapss rel_injects rel_distincts setss;
  6.1385 -
  6.1386 -        val common_notes =
  6.1387 -          (if nn > 1 then [(inductN, [induct_thm], induct_attrs)] else [])
  6.1388 -          |> massage_simple_notes fp_common_name;
  6.1389 -
  6.1390 -        val notes =
  6.1391 -          [(foldN, fold_thmss, K iter_attrs),
  6.1392 -           (inductN, map single induct_thms, fn T_name => induct_attrs @ [induct_type_attr T_name]),
  6.1393 -           (recN, rec_thmss, K iter_attrs),
  6.1394 -           (simpsN, simp_thmss, K [])]
  6.1395 -          |> massage_multi_notes;
  6.1396 -      in
  6.1397 -        lthy
  6.1398 -        |> Local_Theory.notes (common_notes @ notes) |> snd
  6.1399 -        |> register_fp_sugars Least_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss ctr_sugars
  6.1400 -          iterss mapss [induct_thm] (transpose [fold_thmss, rec_thmss]) [] []
  6.1401 -      end;
  6.1402 -
  6.1403 -    fun derive_note_coinduct_coiters_thms_for_types
  6.1404 -        ((((mapss, rel_injects, rel_distincts, setss), (_, _, ctr_defss, ctr_sugars)),
  6.1405 -          (coiterss, coiter_defss)), lthy) =
  6.1406 -      let
  6.1407 -        val (([(coinduct_thms, coinduct_thm), (strong_coinduct_thms, strong_coinduct_thm)],
  6.1408 -              coinduct_attrs),
  6.1409 -             (unfold_thmss, corec_thmss, coiter_attrs),
  6.1410 -             (disc_unfold_thmss, disc_corec_thmss, disc_coiter_attrs),
  6.1411 -             (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
  6.1412 -             (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
  6.1413 -          derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  6.1414 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
  6.1415 -            ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
  6.1416 -            lthy;
  6.1417 -
  6.1418 -        val sel_unfold_thmss = map flat sel_unfold_thmsss;
  6.1419 -        val sel_corec_thmss = map flat sel_corec_thmsss;
  6.1420 -
  6.1421 -        val coinduct_type_attr = Attrib.internal o K o Induct.coinduct_type;
  6.1422 -
  6.1423 -        val flat_coiter_thms = append oo append;
  6.1424 -
  6.1425 -        val simp_thmss =
  6.1426 -          map7 mk_simp_thms ctr_sugars
  6.1427 -            (map3 flat_coiter_thms disc_unfold_thmss disc_unfold_iff_thmss sel_unfold_thmss)
  6.1428 -            (map3 flat_coiter_thms disc_corec_thmss disc_corec_iff_thmss sel_corec_thmss)
  6.1429 -            mapss rel_injects rel_distincts setss;
  6.1430 -
  6.1431 -        val common_notes =
  6.1432 -          (if nn > 1 then
  6.1433 -             [(coinductN, [coinduct_thm], coinduct_attrs),
  6.1434 -              (strong_coinductN, [strong_coinduct_thm], coinduct_attrs)]
  6.1435 -           else
  6.1436 -             [])
  6.1437 -          |> massage_simple_notes fp_common_name;
  6.1438 -
  6.1439 -        val notes =
  6.1440 -          [(coinductN, map single coinduct_thms,
  6.1441 -            fn T_name => coinduct_attrs @ [coinduct_type_attr T_name]),
  6.1442 -           (corecN, corec_thmss, K coiter_attrs),
  6.1443 -           (disc_corecN, disc_corec_thmss, K disc_coiter_attrs),
  6.1444 -           (disc_corec_iffN, disc_corec_iff_thmss, K disc_coiter_iff_attrs),
  6.1445 -           (disc_unfoldN, disc_unfold_thmss, K disc_coiter_attrs),
  6.1446 -           (disc_unfold_iffN, disc_unfold_iff_thmss, K disc_coiter_iff_attrs),
  6.1447 -           (sel_corecN, sel_corec_thmss, K sel_coiter_attrs),
  6.1448 -           (sel_unfoldN, sel_unfold_thmss, K sel_coiter_attrs),
  6.1449 -           (simpsN, simp_thmss, K []),
  6.1450 -           (strong_coinductN, map single strong_coinduct_thms, K coinduct_attrs),
  6.1451 -           (unfoldN, unfold_thmss, K coiter_attrs)]
  6.1452 -          |> massage_multi_notes;
  6.1453 -
  6.1454 -        fun is_codatatype (Type (s, _)) =
  6.1455 -            (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
  6.1456 -          | is_codatatype _ = false;
  6.1457 -
  6.1458 -        val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
  6.1459 -
  6.1460 -        fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
  6.1461 -          Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
  6.1462 -            (map (dest_Const o mk_ctr As) ctrs)
  6.1463 -          |> Generic_Target.theory_declaration;
  6.1464 -      in
  6.1465 -        lthy
  6.1466 -        |> Local_Theory.notes (common_notes @ notes) |> snd
  6.1467 -        |> register_fp_sugars Greatest_FP pre_bnfs nested_bnfs nesting_bnfs fp_res ctr_defss
  6.1468 -          ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
  6.1469 -          (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
  6.1470 -          (transpose [sel_unfold_thmsss, sel_corec_thmsss])
  6.1471 -        |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
  6.1472 -      end;
  6.1473 -
  6.1474 -    val lthy'' = lthy'
  6.1475 -      |> fold_map define_ctrs_dtrs_for_type (fp_bnfs ~~ fp_bs ~~ fpTs ~~ ctors ~~ dtors ~~
  6.1476 -        xtor_co_iterss ~~ ctor_dtors ~~ dtor_ctors ~~ ctor_injects ~~ pre_map_defs ~~
  6.1477 -        pre_set_defss ~~ pre_rel_defs ~~ xtor_map_thms ~~ xtor_set_thmss ~~ xtor_rel_thms ~~ ns ~~
  6.1478 -        kss ~~ mss ~~ ctr_bindingss ~~ ctr_mixfixess ~~ ctr_Tsss ~~ disc_bindingss ~~
  6.1479 -        sel_bindingsss ~~ raw_sel_defaultsss)
  6.1480 -      |> wrap_types_etc
  6.1481 -      |> fp_case fp derive_note_induct_iters_thms_for_types
  6.1482 -           derive_note_coinduct_coiters_thms_for_types;
  6.1483 -
  6.1484 -    val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
  6.1485 -      co_prefix fp ^ "datatype"));
  6.1486 -  in
  6.1487 -    timer; lthy''
  6.1488 -  end;
  6.1489 -
  6.1490 -fun co_datatypes x = define_co_datatypes (K I) (K I) (K I) x;
  6.1491 -
  6.1492 -fun co_datatype_cmd x =
  6.1493 -  define_co_datatypes Typedecl.read_constraint Syntax.parse_typ Syntax.parse_term x;
  6.1494 -
  6.1495 -val parse_ctr_arg =
  6.1496 -  @{keyword "("} |-- parse_binding_colon -- Parse.typ --| @{keyword ")"} ||
  6.1497 -  (Parse.typ >> pair Binding.empty);
  6.1498 -
  6.1499 -val parse_defaults =
  6.1500 -  @{keyword "("} |-- Parse.reserved "defaults" |-- Scan.repeat parse_bound_term --| @{keyword ")"};
  6.1501 -
  6.1502 -val parse_type_arg_constrained =
  6.1503 -  Parse.type_ident -- Scan.option (@{keyword "::"} |-- Parse.!!! Parse.sort);
  6.1504 -
  6.1505 -val parse_type_arg_named_constrained = parse_opt_binding_colon -- parse_type_arg_constrained;
  6.1506 -
  6.1507 -(*FIXME: use parse_type_args_named_constrained from BNF_Util and thus 
  6.1508 -  allow users to kill certain arguments of a (co)datatype*)
  6.1509 -val parse_type_args_named_constrained =
  6.1510 -  parse_type_arg_constrained >> (single o pair Binding.empty) ||
  6.1511 -  @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
  6.1512 -  Scan.succeed [];
  6.1513 -
  6.1514 -val parse_ctr_spec =
  6.1515 -  parse_opt_binding_colon -- parse_binding -- Scan.repeat parse_ctr_arg --
  6.1516 -  Scan.optional parse_defaults [] -- Parse.opt_mixfix;
  6.1517 -
  6.1518 -val parse_spec =
  6.1519 -  parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings --
  6.1520 -  Parse.opt_mixfix -- (@{keyword "="} |-- Parse.enum1 "|" parse_ctr_spec);
  6.1521 -
  6.1522 -val parse_co_datatype = parse_wrap_free_constructors_options -- Parse.and_list1 parse_spec;
  6.1523 -
  6.1524 -fun parse_co_datatype_cmd fp construct_fp = parse_co_datatype >> co_datatype_cmd fp construct_fp;
  6.1525 -
  6.1526 -end;
     7.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Mon Jan 20 18:24:56 2014 +0100
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,181 +0,0 @@
     7.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML
     7.5 -    Author:     Jasmin Blanchette, TU Muenchen
     7.6 -    Copyright   2012
     7.7 -
     7.8 -Tactics for datatype and codatatype sugar.
     7.9 -*)
    7.10 -
    7.11 -signature BNF_FP_DEF_SUGAR_TACTICS =
    7.12 -sig
    7.13 -  val sum_prod_thms_map: thm list
    7.14 -  val sum_prod_thms_set: thm list
    7.15 -  val sum_prod_thms_rel: thm list
    7.16 -
    7.17 -  val mk_coinduct_tac: Proof.context -> thm list -> int -> int list -> thm -> thm list ->
    7.18 -    thm list -> thm list -> thm list list -> thm list list list -> thm list list list -> tactic
    7.19 -  val mk_coiter_tac: thm list -> thm list -> thm -> thm -> thm -> Proof.context -> tactic
    7.20 -  val mk_ctor_iff_dtor_tac: Proof.context -> ctyp option list -> cterm -> cterm -> thm -> thm ->
    7.21 -    tactic
    7.22 -  val mk_disc_coiter_iff_tac: thm list -> thm list -> thm list -> Proof.context -> tactic
    7.23 -  val mk_exhaust_tac: Proof.context -> int -> thm list -> thm -> thm -> tactic
    7.24 -  val mk_half_distinct_tac: Proof.context -> thm -> thm list -> tactic
    7.25 -  val mk_induct_tac: Proof.context -> int -> int list -> int list list -> int list list list ->
    7.26 -    thm list -> thm -> thm list -> thm list list -> tactic
    7.27 -  val mk_inject_tac: Proof.context -> thm -> thm -> tactic
    7.28 -  val mk_iter_tac: thm list -> thm list -> thm list -> thm -> thm -> Proof.context -> tactic
    7.29 -end;
    7.30 -
    7.31 -structure BNF_FP_Def_Sugar_Tactics : BNF_FP_DEF_SUGAR_TACTICS =
    7.32 -struct
    7.33 -
    7.34 -open BNF_Tactics
    7.35 -open BNF_Util
    7.36 -open BNF_FP_Util
    7.37 -
    7.38 -val basic_simp_thms = @{thms simp_thms(7,8,12,14,22,24)};
    7.39 -val more_simp_thms = basic_simp_thms @ @{thms simp_thms(11,15,16,21)};
    7.40 -
    7.41 -val sum_prod_thms_map = @{thms id_apply map_pair_simp prod.cases sum.cases sum_map.simps};
    7.42 -val sum_prod_thms_set0 =
    7.43 -  @{thms SUP_empty Sup_empty Sup_insert UN_insert Un_empty_left Un_empty_right Un_iff
    7.44 -      Union_Un_distrib collect_def[abs_def] image_def o_apply map_pair_simp
    7.45 -      mem_Collect_eq mem_UN_compreh_eq prod_set_simps sum_map.simps sum_set_simps};
    7.46 -val sum_prod_thms_set = @{thms UN_compreh_eq_eq} @ sum_prod_thms_set0;
    7.47 -val sum_prod_thms_rel = @{thms prod_rel_simp sum_rel_simps id_apply};
    7.48 -
    7.49 -fun hhf_concl_conv cv ctxt ct =
    7.50 -  (case Thm.term_of ct of
    7.51 -    Const (@{const_name all}, _) $ Abs _ =>
    7.52 -    Conv.arg_conv (Conv.abs_conv (hhf_concl_conv cv o snd) ctxt) ct
    7.53 -  | _ => Conv.concl_conv ~1 cv ct);
    7.54 -
    7.55 -fun co_induct_inst_as_projs ctxt k thm =
    7.56 -  let
    7.57 -    val fs = Term.add_vars (prop_of thm) []
    7.58 -      |> filter (fn (_, Type (@{type_name fun}, [_, T'])) => T' <> HOLogic.boolT | _ => false);
    7.59 -    fun mk_cfp (f as (_, T)) =
    7.60 -      (certify ctxt (Var f), certify ctxt (mk_proj T (num_binder_types T) k));
    7.61 -    val cfps = map mk_cfp fs;
    7.62 -  in
    7.63 -    Drule.cterm_instantiate cfps thm
    7.64 -  end;
    7.65 -
    7.66 -val co_induct_inst_as_projs_tac = PRIMITIVE oo co_induct_inst_as_projs;
    7.67 -
    7.68 -fun mk_exhaust_tac ctxt n ctr_defs ctor_iff_dtor sumEN' =
    7.69 -  unfold_thms_tac ctxt (ctor_iff_dtor :: ctr_defs) THEN HEADGOAL (rtac sumEN') THEN
    7.70 -  unfold_thms_tac ctxt @{thms split_paired_all} THEN
    7.71 -  HEADGOAL (EVERY' (maps (fn k => [select_prem_tac n (rotate_tac 1) k,
    7.72 -    REPEAT_DETERM o dtac meta_spec, etac meta_mp, atac]) (1 upto n)));
    7.73 -
    7.74 -fun mk_ctor_iff_dtor_tac ctxt cTs cctor cdtor ctor_dtor dtor_ctor =
    7.75 -  HEADGOAL (rtac iffI THEN'
    7.76 -    EVERY' (map3 (fn cTs => fn cx => fn th =>
    7.77 -      dtac (Drule.instantiate' cTs [NONE, NONE, SOME cx] arg_cong) THEN'
    7.78 -      SELECT_GOAL (unfold_thms_tac ctxt [th]) THEN'
    7.79 -      atac) [rev cTs, cTs] [cdtor, cctor] [dtor_ctor, ctor_dtor]));
    7.80 -
    7.81 -fun mk_half_distinct_tac ctxt ctor_inject ctr_defs =
    7.82 -  unfold_thms_tac ctxt (ctor_inject :: @{thms sum.inject} @ ctr_defs) THEN
    7.83 -  HEADGOAL (rtac @{thm sum.distinct(1)});
    7.84 -
    7.85 -fun mk_inject_tac ctxt ctr_def ctor_inject =
    7.86 -  unfold_thms_tac ctxt [ctr_def] THEN HEADGOAL (rtac (ctor_inject RS ssubst)) THEN
    7.87 -  unfold_thms_tac ctxt @{thms sum.inject Pair_eq conj_assoc} THEN HEADGOAL (rtac refl);
    7.88 -
    7.89 -val iter_unfold_thms =
    7.90 -  @{thms comp_def convol_def fst_conv id_def prod_case_Pair_iden snd_conv
    7.91 -      split_conv unit_case_Unity} @ sum_prod_thms_map;
    7.92 -
    7.93 -fun mk_iter_tac pre_map_defs map_idents iter_defs ctor_iter ctr_def ctxt =
    7.94 -  unfold_thms_tac ctxt (ctr_def :: ctor_iter :: iter_defs @ pre_map_defs @ map_idents @
    7.95 -    iter_unfold_thms) THEN HEADGOAL (rtac refl);
    7.96 -
    7.97 -val coiter_unfold_thms = @{thms id_def} @ sum_prod_thms_map;
    7.98 -val ss_if_True_False = simpset_of (ss_only @{thms if_True if_False} @{context});
    7.99 -
   7.100 -fun mk_coiter_tac coiter_defs map_idents ctor_dtor_coiter pre_map_def ctr_def ctxt =
   7.101 -  unfold_thms_tac ctxt (ctr_def :: coiter_defs) THEN
   7.102 -  HEADGOAL (rtac (ctor_dtor_coiter RS trans) THEN'
   7.103 -    asm_simp_tac (put_simpset ss_if_True_False ctxt)) THEN_MAYBE
   7.104 -  (unfold_thms_tac ctxt (pre_map_def :: map_idents @ coiter_unfold_thms) THEN
   7.105 -   HEADGOAL (rtac refl ORELSE' rtac (@{thm unit_eq} RS arg_cong)));
   7.106 -
   7.107 -fun mk_disc_coiter_iff_tac case_splits' coiters discs ctxt =
   7.108 -  EVERY (map3 (fn case_split_tac => fn coiter_thm => fn disc =>
   7.109 -      HEADGOAL case_split_tac THEN unfold_thms_tac ctxt [coiter_thm] THEN
   7.110 -      HEADGOAL (asm_simp_tac (ss_only basic_simp_thms ctxt)) THEN
   7.111 -      (if is_refl disc then all_tac else HEADGOAL (rtac disc)))
   7.112 -    (map rtac case_splits' @ [K all_tac]) coiters discs);
   7.113 -
   7.114 -fun solve_prem_prem_tac ctxt =
   7.115 -  REPEAT o (eresolve_tac @{thms bexE rev_bexI} ORELSE' rtac @{thm rev_bexI[OF UNIV_I]} ORELSE'
   7.116 -    hyp_subst_tac ctxt ORELSE' resolve_tac @{thms disjI1 disjI2}) THEN'
   7.117 -  (rtac refl ORELSE' atac ORELSE' rtac @{thm singletonI});
   7.118 -
   7.119 -fun mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs =
   7.120 -  HEADGOAL (EVERY' (maps (fn kk => [select_prem_tac nn (dtac meta_spec) kk, etac meta_mp,
   7.121 -    SELECT_GOAL (unfold_thms_tac ctxt (pre_set_defs @ set_maps @ sum_prod_thms_set0)),
   7.122 -    solve_prem_prem_tac ctxt]) (rev kks)));
   7.123 -
   7.124 -fun mk_induct_discharge_prem_tac ctxt nn n set_maps pre_set_defs m k kks =
   7.125 -  let val r = length kks in
   7.126 -    HEADGOAL (EVERY' [select_prem_tac n (rotate_tac 1) k, rotate_tac ~1, hyp_subst_tac ctxt,
   7.127 -      REPEAT_DETERM_N m o (dtac meta_spec THEN' rotate_tac ~1)]) THEN
   7.128 -    EVERY [REPEAT_DETERM_N r
   7.129 -        (HEADGOAL (rotate_tac ~1 THEN' dtac meta_mp THEN' rotate_tac 1) THEN prefer_tac 2),
   7.130 -      if r > 0 then ALLGOALS (Goal.norm_hhf_tac ctxt) else all_tac, HEADGOAL atac,
   7.131 -      mk_induct_leverage_prem_prems_tac ctxt nn kks set_maps pre_set_defs]
   7.132 -  end;
   7.133 -
   7.134 -fun mk_induct_tac ctxt nn ns mss kkss ctr_defs ctor_induct' set_maps pre_set_defss =
   7.135 -  let val n = Integer.sum ns in
   7.136 -    unfold_thms_tac ctxt ctr_defs THEN HEADGOAL (rtac ctor_induct') THEN
   7.137 -    co_induct_inst_as_projs_tac ctxt 0 THEN
   7.138 -    EVERY (map4 (EVERY oooo map3 o mk_induct_discharge_prem_tac ctxt nn n set_maps) pre_set_defss
   7.139 -      mss (unflat mss (1 upto n)) kkss)
   7.140 -  end;
   7.141 -
   7.142 -fun mk_coinduct_same_ctr_tac ctxt rel_eqs pre_rel_def dtor_ctor ctr_def discs sels =
   7.143 -  hyp_subst_tac ctxt THEN'
   7.144 -  CONVERSION (hhf_concl_conv
   7.145 -    (Conv.top_conv (K (Conv.try_conv (Conv.rewr_conv ctr_def))) ctxt) ctxt) THEN'
   7.146 -  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels)) THEN'
   7.147 -  SELECT_GOAL (unfold_thms_tac ctxt (pre_rel_def :: dtor_ctor :: sels @ sum_prod_thms_rel)) THEN'
   7.148 -  (atac ORELSE' REPEAT o etac conjE THEN'
   7.149 -     full_simp_tac
   7.150 -       (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
   7.151 -     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
   7.152 -     REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
   7.153 -
   7.154 -fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
   7.155 -  let
   7.156 -    val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
   7.157 -      |> distinct Thm.eq_thm_prop;
   7.158 -  in
   7.159 -    hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
   7.160 -    full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
   7.161 -  end;
   7.162 -
   7.163 -fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
   7.164 -    discss selss =
   7.165 -  let val ks = 1 upto n in
   7.166 -    EVERY' ([rtac allI, rtac allI, rtac impI, select_prem_tac nn (dtac meta_spec) kk,
   7.167 -        dtac meta_spec, dtac meta_mp, atac, rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 0),
   7.168 -        hyp_subst_tac ctxt] @
   7.169 -      map4 (fn k => fn ctr_def => fn discs => fn sels =>
   7.170 -        EVERY' ([rtac exhaust, K (co_induct_inst_as_projs_tac ctxt 1)] @
   7.171 -          map2 (fn k' => fn discs' =>
   7.172 -            if k' = k then
   7.173 -              mk_coinduct_same_ctr_tac ctxt rel_eqs' pre_rel_def dtor_ctor ctr_def discs sels
   7.174 -            else
   7.175 -              mk_coinduct_distinct_ctrs_tac ctxt discs discs') ks discss)) ks ctr_defs discss selss)
   7.176 -  end;
   7.177 -
   7.178 -fun mk_coinduct_tac ctxt rel_eqs' nn ns dtor_coinduct' pre_rel_defs dtor_ctors exhausts ctr_defss
   7.179 -    discsss selsss =
   7.180 -  HEADGOAL (rtac dtor_coinduct' THEN'
   7.181 -    EVERY' (map8 (mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn)
   7.182 -      (1 upto nn) ns pre_rel_defs dtor_ctors exhausts ctr_defss discsss selsss));
   7.183 -
   7.184 -end;
     8.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_n2m.ML	Mon Jan 20 18:24:56 2014 +0100
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,378 +0,0 @@
     8.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m.ML
     8.5 -    Author:     Dmitriy Traytel, TU Muenchen
     8.6 -    Copyright   2013
     8.7 -
     8.8 -Flattening of nested to mutual (co)recursion.
     8.9 -*)
    8.10 -
    8.11 -signature BNF_FP_N2M =
    8.12 -sig
    8.13 -  val construct_mutualized_fp: BNF_FP_Util.fp_kind  -> typ list -> BNF_FP_Def_Sugar.fp_sugar list ->
    8.14 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
    8.15 -    local_theory -> BNF_FP_Util.fp_result * local_theory
    8.16 -end;
    8.17 -
    8.18 -structure BNF_FP_N2M : BNF_FP_N2M =
    8.19 -struct
    8.20 -
    8.21 -open BNF_Def
    8.22 -open BNF_Util
    8.23 -open BNF_FP_Util
    8.24 -open BNF_FP_Def_Sugar
    8.25 -open BNF_Tactics
    8.26 -open BNF_FP_N2M_Tactics
    8.27 -
    8.28 -fun force_typ ctxt T =
    8.29 -  map_types Type_Infer.paramify_vars
    8.30 -  #> Type.constraint T
    8.31 -  #> Syntax.check_term ctxt
    8.32 -  #> singleton (Variable.polymorphic ctxt);
    8.33 -
    8.34 -fun mk_prod_map f g =
    8.35 -  let
    8.36 -    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
    8.37 -    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
    8.38 -  in
    8.39 -    Const (@{const_name map_pair},
    8.40 -      fT --> gT --> HOLogic.mk_prodT (fAT, gAT) --> HOLogic.mk_prodT (fBT, gBT)) $ f $ g
    8.41 -  end;
    8.42 -
    8.43 -fun mk_sum_map f g =
    8.44 -  let
    8.45 -    val ((fAT, fBT), fT) = `dest_funT (fastype_of f);
    8.46 -    val ((gAT, gBT), gT) = `dest_funT (fastype_of g);
    8.47 -  in
    8.48 -    Const (@{const_name sum_map}, fT --> gT --> mk_sumT (fAT, gAT) --> mk_sumT (fBT, gBT)) $ f $ g
    8.49 -  end;
    8.50 -
    8.51 -fun construct_mutualized_fp fp fpTs fp_sugars bs resBs (resDs, Dss) bnfs lthy =
    8.52 -  let
    8.53 -    fun steal get = map (of_fp_sugar (get o #fp_res)) fp_sugars;
    8.54 -
    8.55 -    val n = length bnfs;
    8.56 -    val deads = fold (union (op =)) Dss resDs;
    8.57 -    val As = subtract (op =) deads (map TFree resBs);
    8.58 -    val names_lthy = fold Variable.declare_typ (As @ deads) lthy;
    8.59 -    val m = length As;
    8.60 -    val live = m + n;
    8.61 -    val ((Xs, Bs), names_lthy) = names_lthy
    8.62 -      |> mk_TFrees n
    8.63 -      ||>> mk_TFrees m;
    8.64 -    val allAs = As @ Xs;
    8.65 -    val phiTs = map2 mk_pred2T As Bs;
    8.66 -    val theta = As ~~ Bs;
    8.67 -    val fpTs' = map (Term.typ_subst_atomic theta) fpTs;
    8.68 -    val pre_phiTs = map2 mk_pred2T fpTs fpTs';
    8.69 -
    8.70 -    fun mk_co_algT T U = fp_case fp (T --> U) (U --> T);
    8.71 -    fun co_swap pair = fp_case fp I swap pair;
    8.72 -    val dest_co_algT = co_swap o dest_funT;
    8.73 -    val co_alg_argT = fp_case fp range_type domain_type;
    8.74 -    val co_alg_funT = fp_case fp domain_type range_type;
    8.75 -    val mk_co_product = curry (fp_case fp mk_convol mk_sum_case);
    8.76 -    val mk_map_co_product = fp_case fp mk_prod_map mk_sum_map;
    8.77 -    val co_proj1_const = fp_case fp (fst_const o fst) (uncurry Inl_const o dest_sumT o snd);
    8.78 -    val mk_co_productT = curry (fp_case fp HOLogic.mk_prodT mk_sumT);
    8.79 -    val dest_co_productT = fp_case fp HOLogic.dest_prodT dest_sumT;
    8.80 -
    8.81 -    val ((ctors, dtors), (xtor's, xtors)) =
    8.82 -      let
    8.83 -        val ctors = map2 (force_typ names_lthy o (fn T => dummyT --> T)) fpTs (steal #ctors);
    8.84 -        val dtors = map2 (force_typ names_lthy o (fn T => T --> dummyT)) fpTs (steal #dtors);
    8.85 -      in
    8.86 -        ((ctors, dtors), `(map (Term.subst_atomic_types theta)) (fp_case fp ctors dtors))
    8.87 -      end;
    8.88 -
    8.89 -    val xTs = map (domain_type o fastype_of) xtors;
    8.90 -    val yTs = map (domain_type o fastype_of) xtor's;
    8.91 -
    8.92 -    val (((((phis, phis'), pre_phis), xs), ys), names_lthy) = names_lthy
    8.93 -      |> mk_Frees' "R" phiTs
    8.94 -      ||>> mk_Frees "S" pre_phiTs
    8.95 -      ||>> mk_Frees "x" xTs
    8.96 -      ||>> mk_Frees "y" yTs;
    8.97 -
    8.98 -    val fp_bnfs = steal #bnfs;
    8.99 -    val pre_bnfs = map (of_fp_sugar #pre_bnfs) fp_sugars;
   8.100 -    val pre_bnfss = map #pre_bnfs fp_sugars;
   8.101 -    val nesty_bnfss = map (fn sugar => #nested_bnfs sugar @ #nesting_bnfs sugar) fp_sugars;
   8.102 -    val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
   8.103 -    val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
   8.104 -
   8.105 -    val rels =
   8.106 -      let
   8.107 -        fun find_rel T As Bs = fp_nesty_bnfss
   8.108 -          |> map (filter_out (curry eq_bnf BNF_Comp.DEADID_bnf))
   8.109 -          |> get_first (find_first (fn bnf => Type.could_unify (T_of_bnf bnf, T)))
   8.110 -          |> Option.map (fn bnf =>
   8.111 -            let val live = live_of_bnf bnf;
   8.112 -            in (mk_rel live As Bs (rel_of_bnf bnf), live) end)
   8.113 -          |> the_default (HOLogic.eq_const T, 0);
   8.114 -
   8.115 -        fun mk_rel (T as Type (_, Ts)) (Type (_, Us)) =
   8.116 -              let
   8.117 -                val (rel, live) = find_rel T Ts Us;
   8.118 -                val (Ts', Us') = fastype_of rel |> strip_typeN live |> fst |> map_split dest_pred2T;
   8.119 -                val rels = map2 mk_rel Ts' Us';
   8.120 -              in
   8.121 -                Term.list_comb (rel, rels)
   8.122 -              end
   8.123 -          | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
   8.124 -              handle General.Subscript => HOLogic.eq_const T)
   8.125 -          | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
   8.126 -      in
   8.127 -        map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
   8.128 -      end;
   8.129 -
   8.130 -    val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
   8.131 -
   8.132 -    val rel_unfoldss = map (maps (fn bnf => no_refl [rel_def_of_bnf bnf])) pre_bnfss;
   8.133 -    val rel_xtor_co_inducts = steal (split_conj_thm o #rel_xtor_co_induct_thm)
   8.134 -      |> map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) rel_unfoldss;
   8.135 -
   8.136 -    val rel_defs = map rel_def_of_bnf bnfs;
   8.137 -    val rel_monos = map rel_mono_of_bnf bnfs;
   8.138 -
   8.139 -    val rel_xtor_co_induct_thm =
   8.140 -      mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's
   8.141 -        (mk_rel_xtor_co_induct_tactic fp rel_xtor_co_inducts rel_defs rel_monos) lthy;
   8.142 -
   8.143 -    val rel_eqs = no_refl (map rel_eq_of_bnf fp_nesty_bnfs);
   8.144 -    val map_id0s = no_refl (map map_id0_of_bnf bnfs);
   8.145 -
   8.146 -    val xtor_co_induct_thm =
   8.147 -      (case fp of
   8.148 -        Least_FP =>
   8.149 -          let
   8.150 -            val (Ps, names_lthy) = names_lthy
   8.151 -              |> mk_Frees "P" (map (fn T => T --> HOLogic.boolT) fpTs);
   8.152 -            fun mk_Grp_id P =
   8.153 -              let val T = domain_type (fastype_of P);
   8.154 -              in mk_Grp (HOLogic.Collect_const T $ P) (HOLogic.id_const T) end;
   8.155 -            val cts = map (SOME o certify lthy) (map HOLogic.eq_const As @ map mk_Grp_id Ps);
   8.156 -          in
   8.157 -            cterm_instantiate_pos cts rel_xtor_co_induct_thm
   8.158 -            |> singleton (Proof_Context.export names_lthy lthy)
   8.159 -            |> unfold_thms lthy (@{thms eq_le_Grp_id_iff all_simps(1,2)[symmetric]} @ rel_eqs)
   8.160 -            |> funpow n (fn thm => thm RS spec)
   8.161 -            |> unfold_thms lthy (@{thm eq_alt} :: map rel_Grp_of_bnf bnfs @ map_id0s)
   8.162 -            |> unfold_thms lthy @{thms Grp_id_mono_subst eqTrueI[OF subset_UNIV] simp_thms(22)}
   8.163 -            |> unfold_thms lthy @{thms subset_iff mem_Collect_eq
   8.164 -               atomize_conjL[symmetric] atomize_all[symmetric] atomize_imp[symmetric]}
   8.165 -            |> unfold_thms lthy (maps set_defs_of_bnf bnfs)
   8.166 -          end
   8.167 -      | Greatest_FP =>
   8.168 -          let
   8.169 -            val cts = NONE :: map (SOME o certify lthy) (map HOLogic.eq_const As);
   8.170 -          in
   8.171 -            cterm_instantiate_pos cts rel_xtor_co_induct_thm
   8.172 -            |> unfold_thms lthy (@{thms le_fun_def le_bool_def all_simps(1,2)[symmetric]} @ rel_eqs)
   8.173 -            |> funpow (2 * n) (fn thm => thm RS spec)
   8.174 -            |> Conv.fconv_rule (Object_Logic.atomize lthy)
   8.175 -            |> funpow n (fn thm => thm RS mp)
   8.176 -          end);
   8.177 -
   8.178 -    val fold_preTs = map2 (fn Ds => mk_T_of_bnf Ds allAs) Dss bnfs;
   8.179 -    val fold_pre_deads_only_Ts = map2 (fn Ds => mk_T_of_bnf Ds (replicate live dummyT)) Dss bnfs;
   8.180 -    val rec_theta = Xs ~~ map2 mk_co_productT fpTs Xs;
   8.181 -    val rec_preTs = map (Term.typ_subst_atomic rec_theta) fold_preTs;
   8.182 -
   8.183 -    val fold_strTs = map2 mk_co_algT fold_preTs Xs;
   8.184 -    val rec_strTs = map2 mk_co_algT rec_preTs Xs;
   8.185 -    val resTs = map2 mk_co_algT fpTs Xs;
   8.186 -
   8.187 -    val (((fold_strs, fold_strs'), (rec_strs, rec_strs')), names_lthy) = names_lthy
   8.188 -      |> mk_Frees' "s" fold_strTs
   8.189 -      ||>> mk_Frees' "s" rec_strTs;
   8.190 -
   8.191 -    val co_iters = steal #xtor_co_iterss;
   8.192 -    val ns = map (length o #pre_bnfs) fp_sugars;
   8.193 -    fun substT rho (Type (@{type_name "fun"}, [T, U])) = substT rho T --> substT rho U
   8.194 -      | substT rho (Type (s, Ts)) = Type (s, map (typ_subst_nonatomic rho) Ts)
   8.195 -      | substT _ T = T;
   8.196 -    fun force_iter is_rec i TU TU_rec raw_iters =
   8.197 -      let
   8.198 -        val approx_fold = un_fold_of raw_iters
   8.199 -          |> force_typ names_lthy
   8.200 -            (replicate (nth ns i) dummyT ---> (if is_rec then TU_rec else TU));
   8.201 -        val TUs = binder_fun_types (Term.typ_subst_atomic (Xs ~~ fpTs) (fastype_of approx_fold));
   8.202 -        val js = find_indices Type.could_unify
   8.203 -          TUs (map (Term.typ_subst_atomic (Xs ~~ fpTs)) fold_strTs);
   8.204 -        val Tpats = map (fn j => mk_co_algT (nth fold_pre_deads_only_Ts j) (nth Xs j)) js;
   8.205 -        val iter = raw_iters |> (if is_rec then co_rec_of else un_fold_of);
   8.206 -      in
   8.207 -        force_typ names_lthy (Tpats ---> TU) iter
   8.208 -      end;
   8.209 -
   8.210 -    fun mk_iter b_opt is_rec iters lthy TU =
   8.211 -      let
   8.212 -        val x = co_alg_argT TU;
   8.213 -        val i = find_index (fn T => x = T) Xs;
   8.214 -        val TUiter =
   8.215 -          (case find_first (fn f => body_fun_type (fastype_of f) = TU) iters of
   8.216 -            NONE => nth co_iters i
   8.217 -              |> force_iter is_rec i
   8.218 -                (TU |> (is_none b_opt andalso not is_rec) ? substT (fpTs ~~ Xs))
   8.219 -                (TU |> (is_none b_opt) ? substT (map2 mk_co_productT fpTs Xs ~~ Xs))
   8.220 -          | SOME f => f);
   8.221 -        val TUs = binder_fun_types (fastype_of TUiter);
   8.222 -        val iter_preTs = if is_rec then rec_preTs else fold_preTs;
   8.223 -        val iter_strs = if is_rec then rec_strs else fold_strs;
   8.224 -        fun mk_s TU' =
   8.225 -          let
   8.226 -            val i = find_index (fn T => co_alg_argT TU' = T) Xs;
   8.227 -            val sF = co_alg_funT TU';
   8.228 -            val F = nth iter_preTs i;
   8.229 -            val s = nth iter_strs i;
   8.230 -          in
   8.231 -            (if sF = F then s
   8.232 -            else
   8.233 -              let
   8.234 -                val smapT = replicate live dummyT ---> mk_co_algT sF F;
   8.235 -                fun hidden_to_unit t =
   8.236 -                  Term.subst_TVars (map (rpair HOLogic.unitT) (Term.add_tvar_names t [])) t;
   8.237 -                val smap = map_of_bnf (nth bnfs i)
   8.238 -                  |> force_typ names_lthy smapT
   8.239 -                  |> hidden_to_unit;
   8.240 -                val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
   8.241 -                fun mk_smap_arg TU =
   8.242 -                  (if domain_type TU = range_type TU then
   8.243 -                    HOLogic.id_const (domain_type TU)
   8.244 -                  else if is_rec then
   8.245 -                    let
   8.246 -                      val (TY, (U, X)) = TU |> dest_co_algT ||> dest_co_productT;
   8.247 -                      val T = mk_co_algT TY U;
   8.248 -                    in
   8.249 -                      (case try (force_typ lthy T o build_map lthy co_proj1_const o dest_funT) T of
   8.250 -                        SOME f => mk_co_product f
   8.251 -                          (fst (fst (mk_iter NONE is_rec iters lthy (mk_co_algT TY X))))
   8.252 -                      | NONE => mk_map_co_product
   8.253 -                          (build_map lthy co_proj1_const
   8.254 -                            (dest_funT (mk_co_algT (dest_co_productT TY |> fst) U)))
   8.255 -                          (HOLogic.id_const X))
   8.256 -                    end
   8.257 -                  else
   8.258 -                    fst (fst (mk_iter NONE is_rec iters lthy TU)))
   8.259 -                val smap_args = map mk_smap_arg smap_argTs;
   8.260 -              in
   8.261 -                HOLogic.mk_comp (co_swap (s, Term.list_comb (smap, smap_args)))
   8.262 -              end)
   8.263 -          end;
   8.264 -        val t = Term.list_comb (TUiter, map mk_s TUs);
   8.265 -      in
   8.266 -        (case b_opt of
   8.267 -          NONE => ((t, Drule.dummy_thm), lthy)
   8.268 -        | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
   8.269 -            fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
   8.270 -      end;
   8.271 -
   8.272 -    fun mk_iters is_rec name lthy =
   8.273 -      fold2 (fn TU => fn b => fn ((iters, defs), lthy) =>
   8.274 -        mk_iter (SOME b) is_rec iters lthy TU |>> (fn (f, d) => (f :: iters, d :: defs)))
   8.275 -      resTs (map (Binding.suffix_name ("_" ^ name)) bs) (([], []), lthy)
   8.276 -      |>> apfst rev o apsnd rev;
   8.277 -    val foldN = fp_case fp ctor_foldN dtor_unfoldN;
   8.278 -    val recN = fp_case fp ctor_recN dtor_corecN;
   8.279 -    val (((raw_un_folds, raw_un_fold_defs), (raw_co_recs, raw_co_rec_defs)), (lthy, raw_lthy)) =
   8.280 -      lthy
   8.281 -      |> mk_iters false foldN
   8.282 -      ||>> mk_iters true recN
   8.283 -      ||> `Local_Theory.restore;
   8.284 -
   8.285 -    val phi = Proof_Context.export_morphism raw_lthy lthy;
   8.286 -
   8.287 -    val un_folds = map (Morphism.term phi) raw_un_folds;
   8.288 -    val co_recs = map (Morphism.term phi) raw_co_recs;
   8.289 -
   8.290 -    val (xtor_un_fold_thms, xtor_co_rec_thms) =
   8.291 -      let
   8.292 -        val folds = map (fn f => Term.list_comb (f, fold_strs)) raw_un_folds;
   8.293 -        val recs = map (fn r => Term.list_comb (r, rec_strs)) raw_co_recs;
   8.294 -        val fold_mapTs = co_swap (As @ fpTs, As @ Xs);
   8.295 -        val rec_mapTs = co_swap (As @ fpTs, As @ map2 mk_co_productT fpTs Xs);
   8.296 -        val pre_fold_maps =
   8.297 -          map2 (fn Ds => fn bnf =>
   8.298 -            Term.list_comb (uncurry (mk_map_of_bnf Ds) fold_mapTs bnf,
   8.299 -              map HOLogic.id_const As @ folds))
   8.300 -          Dss bnfs;
   8.301 -        val pre_rec_maps =
   8.302 -          map2 (fn Ds => fn bnf =>
   8.303 -            Term.list_comb (uncurry (mk_map_of_bnf Ds) rec_mapTs bnf,
   8.304 -              map HOLogic.id_const As @ map2 (mk_co_product o HOLogic.id_const) fpTs recs))
   8.305 -          Dss bnfs;
   8.306 -
   8.307 -        fun mk_goals f xtor s smap =
   8.308 -          ((f, xtor), (s, smap))
   8.309 -          |> pairself (HOLogic.mk_comp o co_swap)
   8.310 -          |> HOLogic.mk_eq;
   8.311 -
   8.312 -        val fold_goals = map4 mk_goals folds xtors fold_strs pre_fold_maps
   8.313 -        val rec_goals = map4 mk_goals recs xtors rec_strs pre_rec_maps;
   8.314 -
   8.315 -        fun mk_thms ss goals tac =
   8.316 -          Library.foldr1 HOLogic.mk_conj goals
   8.317 -          |> HOLogic.mk_Trueprop
   8.318 -          |> fold_rev Logic.all ss
   8.319 -          |> (fn goal => Goal.prove_sorry raw_lthy [] [] goal tac)
   8.320 -          |> Thm.close_derivation
   8.321 -          |> Morphism.thm phi
   8.322 -          |> split_conj_thm
   8.323 -          |> map (fn thm => thm RS @{thm comp_eq_dest});
   8.324 -
   8.325 -        val pre_map_defs = no_refl (map map_def_of_bnf bnfs);
   8.326 -        val fp_pre_map_defs = no_refl (map map_def_of_bnf pre_bnfs);
   8.327 -
   8.328 -        val map_unfoldss = map (maps (fn bnf => no_refl [map_def_of_bnf bnf])) pre_bnfss;
   8.329 -        val unfold_map = map2 (fn unfs => unfold_thms lthy (id_apply :: unfs)) map_unfoldss;
   8.330 -
   8.331 -        val fp_xtor_co_iterss = steal #xtor_co_iter_thmss;
   8.332 -        val fp_xtor_un_folds = map (mk_pointfree lthy o un_fold_of) fp_xtor_co_iterss |> unfold_map;
   8.333 -        val fp_xtor_co_recs = map (mk_pointfree lthy o co_rec_of) fp_xtor_co_iterss |> unfold_map;
   8.334 -
   8.335 -        val fp_co_iter_o_mapss = steal #xtor_co_iter_o_map_thmss;
   8.336 -        val fp_fold_o_maps = map un_fold_of fp_co_iter_o_mapss |> unfold_map;
   8.337 -        val fp_rec_o_maps = map co_rec_of fp_co_iter_o_mapss |> unfold_map;
   8.338 -        val fold_thms = fp_case fp @{thm o_assoc[symmetric]} @{thm o_assoc} ::
   8.339 -          @{thms id_apply o_apply o_id id_o map_pair.comp map_pair.id sum_map.comp sum_map.id};
   8.340 -        val rec_thms = fold_thms @ fp_case fp
   8.341 -          @{thms fst_convol map_pair_o_convol convol_o}
   8.342 -          @{thms sum_case_o_inj(1) sum_case_o_sum_map o_sum_case};
   8.343 -        val map_thms = no_refl (maps (fn bnf =>
   8.344 -          [map_comp0_of_bnf bnf RS sym, map_id0_of_bnf bnf]) fp_nesty_bnfs);
   8.345 -
   8.346 -        fun mk_tac defs o_map_thms xtor_thms thms {context = ctxt, prems = _} =
   8.347 -          unfold_thms_tac ctxt
   8.348 -            (flat [thms, defs, pre_map_defs, fp_pre_map_defs, xtor_thms, o_map_thms, map_thms]) THEN
   8.349 -          CONJ_WRAP (K (HEADGOAL (rtac refl))) bnfs;
   8.350 -
   8.351 -        val fold_tac = mk_tac raw_un_fold_defs fp_fold_o_maps fp_xtor_un_folds fold_thms;
   8.352 -        val rec_tac = mk_tac raw_co_rec_defs fp_rec_o_maps fp_xtor_co_recs rec_thms;
   8.353 -      in
   8.354 -        (mk_thms fold_strs fold_goals fold_tac, mk_thms rec_strs rec_goals rec_tac)
   8.355 -      end;
   8.356 -
   8.357 -    (* These results are half broken. This is deliberate. We care only about those fields that are
   8.358 -       used by "primrec_new", "primcorecursive", and "datatype_new_compat". *)
   8.359 -    val fp_res =
   8.360 -      ({Ts = fpTs,
   8.361 -        bnfs = steal #bnfs,
   8.362 -        dtors = dtors,
   8.363 -        ctors = ctors,
   8.364 -        xtor_co_iterss = transpose [un_folds, co_recs],
   8.365 -        xtor_co_induct = xtor_co_induct_thm,
   8.366 -        dtor_ctors = steal #dtor_ctors (*too general types*),
   8.367 -        ctor_dtors = steal #ctor_dtors (*too general types*),
   8.368 -        ctor_injects = steal #ctor_injects (*too general types*),
   8.369 -        dtor_injects = steal #dtor_injects (*too general types*),
   8.370 -        xtor_map_thms = steal #xtor_map_thms (*too general types and terms*),
   8.371 -        xtor_set_thmss = steal #xtor_set_thmss (*too general types and terms*),
   8.372 -        xtor_rel_thms = steal #xtor_rel_thms (*too general types and terms*),
   8.373 -        xtor_co_iter_thmss = transpose [xtor_un_fold_thms, xtor_co_rec_thms],
   8.374 -        xtor_co_iter_o_map_thmss = steal #xtor_co_iter_o_map_thmss (*theorem about old constant*),
   8.375 -        rel_xtor_co_induct_thm = rel_xtor_co_induct_thm}
   8.376 -       |> morph_fp_result (Morphism.term_morphism "BNF" (singleton (Variable.polymorphic lthy))));
   8.377 -  in
   8.378 -    (fp_res, lthy)
   8.379 -  end;
   8.380 -
   8.381 -end;
     9.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_n2m_sugar.ML	Mon Jan 20 18:24:56 2014 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,394 +0,0 @@
     9.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_sugar.ML
     9.5 -    Author:     Jasmin Blanchette, TU Muenchen
     9.6 -    Copyright   2013
     9.7 -
     9.8 -Suggared flattening of nested to mutual (co)recursion.
     9.9 -*)
    9.10 -
    9.11 -signature BNF_FP_N2M_SUGAR =
    9.12 -sig
    9.13 -  val unfold_let: term -> term
    9.14 -  val dest_map: Proof.context -> string -> term -> term * term list
    9.15 -
    9.16 -  val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
    9.17 -    term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
    9.18 -    (BNF_FP_Def_Sugar.fp_sugar list
    9.19 -     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
    9.20 -    * local_theory
    9.21 -  val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
    9.22 -    term list list list
    9.23 -  val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
    9.24 -    (term * term list list) list list -> local_theory ->
    9.25 -    (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
    9.26 -     * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
    9.27 -    * local_theory
    9.28 -end;
    9.29 -
    9.30 -structure BNF_FP_N2M_Sugar : BNF_FP_N2M_SUGAR =
    9.31 -struct
    9.32 -
    9.33 -open Ctr_Sugar
    9.34 -open BNF_Util
    9.35 -open BNF_Def
    9.36 -open BNF_FP_Util
    9.37 -open BNF_FP_Def_Sugar
    9.38 -open BNF_FP_N2M
    9.39 -
    9.40 -val n2mN = "n2m_"
    9.41 -
    9.42 -type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
    9.43 -
    9.44 -structure Data = Generic_Data
    9.45 -(
    9.46 -  type T = n2m_sugar Typtab.table;
    9.47 -  val empty = Typtab.empty;
    9.48 -  val extend = I;
    9.49 -  val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
    9.50 -);
    9.51 -
    9.52 -fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
    9.53 -  (map (morph_fp_sugar phi) fp_sugars,
    9.54 -   (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
    9.55 -    Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
    9.56 -
    9.57 -val transfer_n2m_sugar =
    9.58 -  morph_n2m_sugar o Morphism.transfer_morphism o Proof_Context.theory_of;
    9.59 -
    9.60 -fun n2m_sugar_of ctxt =
    9.61 -  Typtab.lookup (Data.get (Context.Proof ctxt))
    9.62 -  #> Option.map (transfer_n2m_sugar ctxt);
    9.63 -
    9.64 -fun register_n2m_sugar key n2m_sugar =
    9.65 -  Local_Theory.declaration {syntax = false, pervasive = false}
    9.66 -    (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
    9.67 -
    9.68 -fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
    9.69 -  | unfold_let (Const (@{const_name prod_case}, _) $ t) =
    9.70 -    (case unfold_let t of
    9.71 -      t' as Abs (s1, T1, Abs (s2, T2, _)) =>
    9.72 -      let val v = Var ((s1 ^ s2, Term.maxidx_of_term t' + 1), HOLogic.mk_prodT (T1, T2)) in
    9.73 -        lambda v (incr_boundvars 1 (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
    9.74 -      end
    9.75 -    | _ => t)
    9.76 -  | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
    9.77 -  | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
    9.78 -  | unfold_let t = t;
    9.79 -
    9.80 -fun mk_map_pattern ctxt s =
    9.81 -  let
    9.82 -    val bnf = the (bnf_of ctxt s);
    9.83 -    val mapx = map_of_bnf bnf;
    9.84 -    val live = live_of_bnf bnf;
    9.85 -    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
    9.86 -    val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
    9.87 -  in
    9.88 -    (mapx, betapplys (mapx, fs))
    9.89 -  end;
    9.90 -
    9.91 -fun dest_map ctxt s call =
    9.92 -  let
    9.93 -    val (map0, pat) = mk_map_pattern ctxt s;
    9.94 -    val (_, tenv) = fo_match ctxt call pat;
    9.95 -  in
    9.96 -    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
    9.97 -  end;
    9.98 -
    9.99 -fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
   9.100 -  | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
   9.101 -
   9.102 -fun map_partition f xs =
   9.103 -  fold_rev (fn x => fn (ys, (good, bad)) =>
   9.104 -      case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
   9.105 -    xs ([], ([], []));
   9.106 -
   9.107 -fun key_of_fp_eqs fp fpTs fp_eqs =
   9.108 -  Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
   9.109 -
   9.110 -(* TODO: test with sort constraints on As *)
   9.111 -fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
   9.112 -  let
   9.113 -    val thy = Proof_Context.theory_of no_defs_lthy0;
   9.114 -
   9.115 -    val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
   9.116 -
   9.117 -    fun incompatible_calls t1 t2 =
   9.118 -      error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
   9.119 -    fun nested_self_call t =
   9.120 -      error ("Unsupported nested self-call " ^ qsotm t);
   9.121 -
   9.122 -    val b_names = map Binding.name_of bs;
   9.123 -    val fp_b_names = map base_name_of_typ fpTs;
   9.124 -
   9.125 -    val nn = length fpTs;
   9.126 -
   9.127 -    fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
   9.128 -      let
   9.129 -        val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
   9.130 -        val phi = Morphism.term_morphism "BNF" (Term.subst_TVars rho);
   9.131 -      in
   9.132 -        morph_ctr_sugar phi (nth ctr_sugars index)
   9.133 -      end;
   9.134 -
   9.135 -    val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
   9.136 -    val mapss = map (of_fp_sugar #mapss) fp_sugars0;
   9.137 -    val ctr_sugars = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
   9.138 -
   9.139 -    val ctrss = map #ctrs ctr_sugars;
   9.140 -    val ctr_Tss = map (map fastype_of) ctrss;
   9.141 -
   9.142 -    val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
   9.143 -    val As = map TFree As';
   9.144 -
   9.145 -    val ((Cs, Xs), no_defs_lthy) =
   9.146 -      no_defs_lthy0
   9.147 -      |> fold Variable.declare_typ As
   9.148 -      |> mk_TFrees nn
   9.149 -      ||>> variant_tfrees fp_b_names;
   9.150 -
   9.151 -    fun check_call_dead live_call call =
   9.152 -      if null (get_indices call) then () else incompatible_calls live_call call;
   9.153 -
   9.154 -    fun freeze_fpTs_simple (T as Type (s, Ts)) =
   9.155 -        (case find_index (curry (op =) T) fpTs of
   9.156 -          ~1 => Type (s, map freeze_fpTs_simple Ts)
   9.157 -        | kk => nth Xs kk)
   9.158 -      | freeze_fpTs_simple T = T;
   9.159 -
   9.160 -    fun freeze_fpTs_map (fpT as Type (_, Ts')) (callss, (live_call :: _, dead_calls))
   9.161 -        (T as Type (s, Ts)) =
   9.162 -      if Ts' = Ts then
   9.163 -        nested_self_call live_call
   9.164 -      else
   9.165 -        (List.app (check_call_dead live_call) dead_calls;
   9.166 -         Type (s, map2 (freeze_fpTs fpT) (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
   9.167 -           (transpose callss)) Ts))
   9.168 -    and freeze_fpTs fpT calls (T as Type (s, _)) =
   9.169 -        (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
   9.170 -          ([], _) =>
   9.171 -          (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
   9.172 -            ([], _) => freeze_fpTs_simple T
   9.173 -          | callsp => freeze_fpTs_map fpT callsp T)
   9.174 -        | callsp => freeze_fpTs_map fpT callsp T)
   9.175 -      | freeze_fpTs _ _ T = T;
   9.176 -
   9.177 -    val ctr_Tsss = map (map binder_types) ctr_Tss;
   9.178 -    val ctrXs_Tsss = map3 (map2 o map2 o freeze_fpTs) fpTs callssss ctr_Tsss;
   9.179 -    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
   9.180 -    val ctr_Ts = map (body_type o hd) ctr_Tss;
   9.181 -
   9.182 -    val ns = map length ctr_Tsss;
   9.183 -    val kss = map (fn n => 1 upto n) ns;
   9.184 -    val mss = map (map length) ctr_Tsss;
   9.185 -
   9.186 -    val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
   9.187 -    val key = key_of_fp_eqs fp fpTs fp_eqs;
   9.188 -  in
   9.189 -    (case n2m_sugar_of no_defs_lthy key of
   9.190 -      SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
   9.191 -    | NONE =>
   9.192 -      let
   9.193 -        val base_fp_names = Name.variant_list [] fp_b_names;
   9.194 -        val fp_bs = map2 (fn b_name => fn base_fp_name =>
   9.195 -            Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
   9.196 -          b_names base_fp_names;
   9.197 -
   9.198 -        val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
   9.199 -               dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
   9.200 -          fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
   9.201 -
   9.202 -        val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
   9.203 -        val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
   9.204 -
   9.205 -        val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
   9.206 -          mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
   9.207 -
   9.208 -        fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
   9.209 -
   9.210 -        val ((co_iterss, co_iter_defss), lthy) =
   9.211 -          fold_map2 (fn b =>
   9.212 -            (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
   9.213 -             else define_coiters [unfoldN, corecN] (the coiters_args_types))
   9.214 -              (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
   9.215 -          |>> split_list;
   9.216 -
   9.217 -        val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
   9.218 -              sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
   9.219 -          if fp = Least_FP then
   9.220 -            derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
   9.221 -              xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
   9.222 -              co_iterss co_iter_defss lthy
   9.223 -            |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
   9.224 -              ([induct], fold_thmss, rec_thmss, [], [], [], []))
   9.225 -            ||> (fn info => (SOME info, NONE))
   9.226 -          else
   9.227 -            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
   9.228 -              dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
   9.229 -              ns ctr_defss ctr_sugars co_iterss co_iter_defss
   9.230 -              (Proof_Context.export lthy no_defs_lthy) lthy
   9.231 -            |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
   9.232 -                    (disc_unfold_thmss, disc_corec_thmss, _), _,
   9.233 -                    (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
   9.234 -              (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
   9.235 -               disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
   9.236 -            ||> (fn info => (NONE, SOME info));
   9.237 -
   9.238 -        val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
   9.239 -
   9.240 -        fun mk_target_fp_sugar (kk, T) =
   9.241 -          {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
   9.242 -           nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
   9.243 -           ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
   9.244 -           co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
   9.245 -           disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
   9.246 -           sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
   9.247 -          |> morph_fp_sugar phi;
   9.248 -
   9.249 -        val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
   9.250 -      in
   9.251 -        (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
   9.252 -      end)
   9.253 -  end;
   9.254 -
   9.255 -fun indexify_callsss fp_sugar callsss =
   9.256 -  let
   9.257 -    val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
   9.258 -    fun indexify_ctr ctr =
   9.259 -      (case AList.lookup Term.aconv_untyped callsss ctr of
   9.260 -        NONE => replicate (num_binder_types (fastype_of ctr)) []
   9.261 -      | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
   9.262 -  in
   9.263 -    map indexify_ctr ctrs
   9.264 -  end;
   9.265 -
   9.266 -fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
   9.267 -
   9.268 -fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
   9.269 -    f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
   9.270 -  | fold_subtype_pairs f TU = f TU;
   9.271 -
   9.272 -fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
   9.273 -  let
   9.274 -    val qsoty = quote o Syntax.string_of_typ lthy;
   9.275 -    val qsotys = space_implode " or " o map qsoty;
   9.276 -
   9.277 -    fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
   9.278 -    fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
   9.279 -    fun not_co_datatype (T as Type (s, _)) =
   9.280 -        if fp = Least_FP andalso
   9.281 -           is_some (Datatype_Data.get_info (Proof_Context.theory_of lthy) s) then
   9.282 -          error (qsoty T ^ " is not a new-style datatype (cf. \"datatype_new\")")
   9.283 -        else
   9.284 -          not_co_datatype0 T
   9.285 -      | not_co_datatype T = not_co_datatype0 T;
   9.286 -    fun not_mutually_nested_rec Ts1 Ts2 =
   9.287 -      error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
   9.288 -        " nor nested recursive via " ^ qsotys Ts2);
   9.289 -
   9.290 -    val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
   9.291 -
   9.292 -    val perm_actual_Ts =
   9.293 -      sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
   9.294 -
   9.295 -    fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
   9.296 -
   9.297 -    fun the_fp_sugar_of (T as Type (T_name, _)) =
   9.298 -      (case fp_sugar_of lthy T_name of
   9.299 -        SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
   9.300 -      | NONE => not_co_datatype T);
   9.301 -
   9.302 -    fun gen_rhss_in gen_Ts rho subTs =
   9.303 -      let
   9.304 -        fun maybe_insert (T, Type (_, gen_tyargs)) =
   9.305 -            if member (op =) subTs T then insert (op =) gen_tyargs else I
   9.306 -          | maybe_insert _ = I;
   9.307 -
   9.308 -        val ctrs = maps the_ctrs_of gen_Ts;
   9.309 -        val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
   9.310 -        val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
   9.311 -      in
   9.312 -        fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
   9.313 -      end;
   9.314 -
   9.315 -    fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
   9.316 -      | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
   9.317 -        let
   9.318 -          val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
   9.319 -          val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
   9.320 -
   9.321 -          val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
   9.322 -            not_mutually_nested_rec mutual_Ts seen;
   9.323 -
   9.324 -          fun fresh_tyargs () =
   9.325 -            let
   9.326 -              (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
   9.327 -              val (gen_tyargs, lthy') =
   9.328 -                variant_tfrees (replicate (length tyargs) "z") lthy
   9.329 -                |>> map Logic.varifyT_global;
   9.330 -              val rho' = (gen_tyargs ~~ tyargs) @ rho;
   9.331 -            in
   9.332 -              (rho', gen_tyargs, gen_seen, lthy')
   9.333 -            end;
   9.334 -
   9.335 -          val (rho', gen_tyargs, gen_seen', lthy') =
   9.336 -            if exists (exists_subtype_in seen) mutual_Ts then
   9.337 -              (case gen_rhss_in gen_seen rho mutual_Ts of
   9.338 -                [] => fresh_tyargs ()
   9.339 -              | gen_tyargs :: gen_tyargss_tl =>
   9.340 -                let
   9.341 -                  val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
   9.342 -                  val mgu = Type.raw_unifys unify_pairs Vartab.empty;
   9.343 -                  val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
   9.344 -                  val gen_seen' = map (Envir.subst_type mgu) gen_seen;
   9.345 -                in
   9.346 -                  (rho, gen_tyargs', gen_seen', lthy)
   9.347 -                end)
   9.348 -            else
   9.349 -              fresh_tyargs ();
   9.350 -
   9.351 -          val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
   9.352 -          val Ts' = filter_out (member (op =) mutual_Ts) Ts;
   9.353 -        in
   9.354 -          gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
   9.355 -            Ts'
   9.356 -        end
   9.357 -      | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
   9.358 -
   9.359 -    val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
   9.360 -    val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
   9.361 -
   9.362 -    val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
   9.363 -    val Ts = actual_Ts @ missing_Ts;
   9.364 -
   9.365 -    val nn = length Ts;
   9.366 -    val kks = 0 upto nn - 1;
   9.367 -
   9.368 -    val callssss0 = pad_list [] nn actual_callssss0;
   9.369 -
   9.370 -    val common_name = mk_common_name (map Binding.name_of actual_bs);
   9.371 -    val bs = pad_list (Binding.name common_name) nn actual_bs;
   9.372 -
   9.373 -    fun permute xs = permute_like (op =) Ts perm_Ts xs;
   9.374 -    fun unpermute perm_xs = permute_like (op =) perm_Ts Ts perm_xs;
   9.375 -
   9.376 -    val perm_bs = permute bs;
   9.377 -    val perm_kks = permute kks;
   9.378 -    val perm_callssss0 = permute callssss0;
   9.379 -    val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
   9.380 -
   9.381 -    val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
   9.382 -
   9.383 -    val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
   9.384 -
   9.385 -    val ((perm_fp_sugars, fp_sugar_thms), lthy) =
   9.386 -      if num_groups > 1 then
   9.387 -        mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
   9.388 -          perm_fp_sugars0 lthy
   9.389 -      else
   9.390 -        ((perm_fp_sugars0, (NONE, NONE)), lthy);
   9.391 -
   9.392 -    val fp_sugars = unpermute perm_fp_sugars;
   9.393 -  in
   9.394 -    ((missing_Ts, perm_kks, fp_sugars, fp_sugar_thms), lthy)
   9.395 -  end;
   9.396 -
   9.397 -end;
    10.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_n2m_tactics.ML	Mon Jan 20 18:24:56 2014 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,41 +0,0 @@
    10.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_n2m_tactics.ML
    10.5 -    Author:     Dmitriy Traytel, TU Muenchen
    10.6 -    Copyright   2013
    10.7 -
    10.8 -Tactics for mutualization of nested (co)datatypes.
    10.9 -*)
   10.10 -
   10.11 -signature BNF_FP_N2M_TACTICS =
   10.12 -sig
   10.13 -  val mk_rel_xtor_co_induct_tactic: BNF_FP_Util.fp_kind -> thm list -> thm list -> thm list ->
   10.14 -    {prems: thm list, context: Proof.context} -> tactic
   10.15 -end;
   10.16 -
   10.17 -structure BNF_FP_N2M_Tactics : BNF_FP_N2M_TACTICS =
   10.18 -struct
   10.19 -
   10.20 -open BNF_Util
   10.21 -open BNF_FP_Util
   10.22 -
   10.23 -fun mk_rel_xtor_co_induct_tactic fp co_inducts rel_defs rel_monos
   10.24 -  {context = ctxt, prems = raw_C_IHs} =
   10.25 -  let
   10.26 -    val unfolds = map (fn def => unfold_thms ctxt (id_apply :: no_reflexive [def])) rel_defs;
   10.27 -    val folded_C_IHs = map (fn thm => thm RS @{thm spec2} RS mp) raw_C_IHs;
   10.28 -    val C_IHs = map2 (curry op |>) folded_C_IHs unfolds;
   10.29 -    val C_IH_monos =
   10.30 -      map3 (fn C_IH => fn mono => fn unfold =>
   10.31 -        (mono RSN (2, @{thm rev_predicate2D}), C_IH)
   10.32 -        |> fp = Greatest_FP ? swap
   10.33 -        |> op RS
   10.34 -        |> unfold)
   10.35 -      folded_C_IHs rel_monos unfolds;
   10.36 -  in
   10.37 -    HEADGOAL (CONJ_WRAP_GEN' (rtac @{thm context_conjI})
   10.38 -      (fn thm => rtac thm THEN_ALL_NEW (rotate_tac ~1 THEN'
   10.39 -         REPEAT_ALL_NEW (FIRST' [eresolve_tac C_IHs, eresolve_tac C_IH_monos,
   10.40 -           rtac @{thm order_refl}, atac, resolve_tac co_inducts])))
   10.41 -    co_inducts)
   10.42 -  end;
   10.43 -
   10.44 -end;
    11.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_rec_sugar_util.ML	Mon Jan 20 18:24:56 2014 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,67 +0,0 @@
    11.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML
    11.5 -    Author:     Lorenz Panny, TU Muenchen
    11.6 -    Author:     Jasmin Blanchette, TU Muenchen
    11.7 -    Copyright   2013
    11.8 -
    11.9 -Library for recursor and corecursor sugar.
   11.10 -*)
   11.11 -
   11.12 -signature BNF_FP_REC_SUGAR_UTIL =
   11.13 -sig
   11.14 -  val indexed: 'a list -> int -> int list * int
   11.15 -  val indexedd: 'a list list -> int -> int list list * int
   11.16 -  val indexeddd: 'a list list list -> int -> int list list list * int
   11.17 -  val indexedddd: 'a list list list list -> int -> int list list list list * int
   11.18 -  val find_index_eq: ''a list -> ''a -> int
   11.19 -  val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
   11.20 -
   11.21 -  val drop_all: term -> term
   11.22 -
   11.23 -  val mk_partial_compN: int -> typ -> term -> term
   11.24 -  val mk_partial_comp: typ -> typ -> term -> term
   11.25 -  val mk_compN: int -> typ list -> term * term -> term
   11.26 -  val mk_comp: typ list -> term * term -> term
   11.27 -
   11.28 -  val get_indices: ((binding * typ) * 'a) list -> term -> int list
   11.29 -end;
   11.30 -
   11.31 -structure BNF_FP_Rec_Sugar_Util : BNF_FP_REC_SUGAR_UTIL =
   11.32 -struct
   11.33 -
   11.34 -fun indexe _ h = (h, h + 1);
   11.35 -fun indexed xs = fold_map indexe xs;
   11.36 -fun indexedd xss = fold_map indexed xss;
   11.37 -fun indexeddd xsss = fold_map indexedd xsss;
   11.38 -fun indexedddd xssss = fold_map indexeddd xssss;
   11.39 -
   11.40 -fun find_index_eq hs h = find_index (curry (op =) h) hs;
   11.41 -
   11.42 -fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
   11.43 -
   11.44 -fun drop_all t =
   11.45 -  subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
   11.46 -    strip_qnt_body @{const_name all} t);
   11.47 -
   11.48 -fun mk_partial_comp gT fT g =
   11.49 -  let val T = domain_type fT --> range_type gT in
   11.50 -    Const (@{const_name Fun.comp}, gT --> fT --> T) $ g
   11.51 -  end;
   11.52 -
   11.53 -fun mk_partial_compN 0 _ g = g
   11.54 -  | mk_partial_compN n fT g =
   11.55 -    let val g' = mk_partial_compN (n - 1) (range_type fT) g in
   11.56 -      mk_partial_comp (fastype_of g') fT g'
   11.57 -    end;
   11.58 -
   11.59 -fun mk_compN n bound_Ts (g, f) =
   11.60 -  let val typof = curry fastype_of1 bound_Ts in
   11.61 -    mk_partial_compN n (typof f) g $ f
   11.62 -  end;
   11.63 -
   11.64 -val mk_comp = mk_compN 1;
   11.65 -
   11.66 -fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
   11.67 -  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
   11.68 -  |> map_filter I;
   11.69 -
   11.70 -end;
    12.1 --- a/src/HOL/Tools/BNF/Tools/bnf_fp_util.ML	Mon Jan 20 18:24:56 2014 +0100
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,635 +0,0 @@
    12.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_util.ML
    12.5 -    Author:     Dmitriy Traytel, TU Muenchen
    12.6 -    Author:     Jasmin Blanchette, TU Muenchen
    12.7 -    Copyright   2012, 2013
    12.8 -
    12.9 -Shared library for the datatype and codatatype constructions.
   12.10 -*)
   12.11 -
   12.12 -signature BNF_FP_UTIL =
   12.13 -sig
   12.14 -  datatype fp_kind = Least_FP | Greatest_FP
   12.15 -  val fp_case: fp_kind -> 'a -> 'a -> 'a
   12.16 -
   12.17 -  type fp_result =
   12.18 -    {Ts: typ list,
   12.19 -     bnfs: BNF_Def.bnf list,
   12.20 -     ctors: term list,
   12.21 -     dtors: term list,
   12.22 -     xtor_co_iterss: term list list,
   12.23 -     xtor_co_induct: thm,
   12.24 -     dtor_ctors: thm list,
   12.25 -     ctor_dtors: thm list,
   12.26 -     ctor_injects: thm list,
   12.27 -     dtor_injects: thm list,
   12.28 -     xtor_map_thms: thm list,
   12.29 -     xtor_set_thmss: thm list list,
   12.30 -     xtor_rel_thms: thm list,
   12.31 -     xtor_co_iter_thmss: thm list list,
   12.32 -     xtor_co_iter_o_map_thmss: thm list list,
   12.33 -     rel_xtor_co_induct_thm: thm}
   12.34 -
   12.35 -  val morph_fp_result: morphism -> fp_result -> fp_result
   12.36 -  val eq_fp_result: fp_result * fp_result -> bool
   12.37 -  val un_fold_of: 'a list -> 'a
   12.38 -  val co_rec_of: 'a list -> 'a
   12.39 -
   12.40 -  val time: Proof.context -> Timer.real_timer -> string -> Timer.real_timer
   12.41 -
   12.42 -  val IITN: string
   12.43 -  val LevN: string
   12.44 -  val algN: string
   12.45 -  val behN: string
   12.46 -  val bisN: string
   12.47 -  val carTN: string
   12.48 -  val caseN: string
   12.49 -  val coN: string
   12.50 -  val coinductN: string
   12.51 -  val corecN: string
   12.52 -  val ctorN: string
   12.53 -  val ctor_dtorN: string
   12.54 -  val ctor_exhaustN: string
   12.55 -  val ctor_induct2N: string
   12.56 -  val ctor_inductN: string
   12.57 -  val ctor_injectN: string
   12.58 -  val ctor_foldN: string
   12.59 -  val ctor_fold_o_mapN: string
   12.60 -  val ctor_fold_transferN: string
   12.61 -  val ctor_fold_uniqueN: string
   12.62 -  val ctor_mapN: string
   12.63 -  val ctor_map_uniqueN: string
   12.64 -  val ctor_recN: string
   12.65 -  val ctor_rec_o_mapN: string
   12.66 -  val ctor_rec_uniqueN: string
   12.67 -  val ctor_relN: string
   12.68 -  val ctor_set_inclN: string
   12.69 -  val ctor_set_set_inclN: string
   12.70 -  val disc_unfoldN: string
   12.71 -  val disc_unfold_iffN: string
   12.72 -  val disc_corecN: string
   12.73 -  val disc_corec_iffN: string
   12.74 -  val dtorN: string
   12.75 -  val dtor_coinductN: string
   12.76 -  val dtor_corecN: string
   12.77 -  val dtor_corec_o_mapN: string
   12.78 -  val dtor_corec_uniqueN: string
   12.79 -  val dtor_ctorN: string
   12.80 -  val dtor_exhaustN: string
   12.81 -  val dtor_injectN: string
   12.82 -  val dtor_mapN: string
   12.83 -  val dtor_map_coinductN: string
   12.84 -  val dtor_map_strong_coinductN: string
   12.85 -  val dtor_map_uniqueN: string
   12.86 -  val dtor_relN: string
   12.87 -  val dtor_set_inclN: string
   12.88 -  val dtor_set_set_inclN: string
   12.89 -  val dtor_strong_coinductN: string
   12.90 -  val dtor_unfoldN: string
   12.91 -  val dtor_unfold_o_mapN: string
   12.92 -  val dtor_unfold_transferN: string
   12.93 -  val dtor_unfold_uniqueN: string
   12.94 -  val exhaustN: string
   12.95 -  val foldN: string
   12.96 -  val hsetN: string
   12.97 -  val hset_recN: string
   12.98 -  val inductN: string
   12.99 -  val injectN: string
  12.100 -  val isNodeN: string
  12.101 -  val lsbisN: string
  12.102 -  val mapN: string
  12.103 -  val map_uniqueN: string
  12.104 -  val min_algN: string
  12.105 -  val morN: string
  12.106 -  val nchotomyN: string
  12.107 -  val recN: string
  12.108 -  val rel_coinductN: string
  12.109 -  val rel_inductN: string
  12.110 -  val rel_injectN: string
  12.111 -  val rel_distinctN: string
  12.112 -  val rvN: string
  12.113 -  val sel_corecN: string
  12.114 -  val set_inclN: string
  12.115 -  val set_set_inclN: string
  12.116 -  val sel_unfoldN: string
  12.117 -  val setN: string
  12.118 -  val simpsN: string
  12.119 -  val strTN: string
  12.120 -  val str_initN: string
  12.121 -  val strong_coinductN: string
  12.122 -  val sum_bdN: string
  12.123 -  val sum_bdTN: string
  12.124 -  val unfoldN: string
  12.125 -  val uniqueN: string
  12.126 -
  12.127 -  (* TODO: Don't index set facts. Isabelle packages traditionally generate uniform names. *)
  12.128 -  val mk_ctor_setN: int -> string
  12.129 -  val mk_dtor_setN: int -> string
  12.130 -  val mk_dtor_set_inductN: int -> string
  12.131 -  val mk_set_inductN: int -> string
  12.132 -
  12.133 -  val co_prefix: fp_kind -> string
  12.134 -
  12.135 -  val base_name_of_typ: typ -> string
  12.136 -  val mk_common_name: string list -> string
  12.137 -
  12.138 -  val split_conj_thm: thm -> thm list
  12.139 -  val split_conj_prems: int -> thm -> thm
  12.140 -
  12.141 -  val mk_sumTN: typ list -> typ
  12.142 -  val mk_sumTN_balanced: typ list -> typ
  12.143 -
  12.144 -  val mk_proj: typ -> int -> int -> term
  12.145 -
  12.146 -  val mk_convol: term * term -> term
  12.147 -
  12.148 -  val Inl_const: typ -> typ -> term
  12.149 -  val Inr_const: typ -> typ -> term
  12.150 -
  12.151 -  val mk_Inl: typ -> term -> term
  12.152 -  val mk_Inr: typ -> term -> term
  12.153 -  val mk_InN: typ list -> term -> int -> term
  12.154 -  val mk_InN_balanced: typ -> int -> term -> int -> term
  12.155 -  val mk_sum_case: term * term -> term
  12.156 -  val mk_sum_caseN: term list -> term
  12.157 -  val mk_sum_caseN_balanced: term list -> term
  12.158 -
  12.159 -  val dest_sumT: typ -> typ * typ
  12.160 -  val dest_sumTN: int -> typ -> typ list
  12.161 -  val dest_sumTN_balanced: int -> typ -> typ list
  12.162 -  val dest_tupleT: int -> typ -> typ list
  12.163 -
  12.164 -  val If_const: typ -> term
  12.165 -
  12.166 -  val mk_Field: term -> term
  12.167 -  val mk_If: term -> term -> term -> term
  12.168 -  val mk_union: term * term -> term
  12.169 -
  12.170 -  val mk_sumEN: int -> thm
  12.171 -  val mk_sumEN_balanced: int -> thm
  12.172 -  val mk_sumEN_tupled_balanced: int list -> thm
  12.173 -  val mk_sum_casesN: int -> int -> thm
  12.174 -  val mk_sum_casesN_balanced: int -> int -> thm
  12.175 -
  12.176 -  val fixpoint: ('a * 'a -> bool) -> ('a list -> 'a list) -> 'a list -> 'a list
  12.177 -
  12.178 -  val mk_rel_xtor_co_induct_thm: fp_kind -> term list -> term list -> term list -> term list ->
  12.179 -    term list -> term list -> term list -> term list ->
  12.180 -    ({prems: thm list, context: Proof.context} -> tactic) -> Proof.context -> thm
  12.181 -  val mk_un_fold_transfer_thms: fp_kind -> term list -> term list -> term list -> term list ->
  12.182 -    term list -> term list -> ({prems: thm list, context: Proof.context} -> tactic) ->
  12.183 -    Proof.context -> thm list
  12.184 -  val mk_xtor_un_fold_o_map_thms: fp_kind -> bool -> int -> thm -> thm list -> thm list ->
  12.185 -    thm list -> thm list -> thm list
  12.186 -
  12.187 -  val mk_strong_coinduct_thm: thm -> thm list -> thm list -> Proof.context -> thm
  12.188 -
  12.189 -  val fp_bnf: (binding list -> (string * sort) list -> typ list * typ list list ->
  12.190 -      BNF_Def.bnf list -> local_theory -> 'a) ->
  12.191 -    binding list -> (string * sort) list -> ((string * sort) * typ) list -> local_theory ->
  12.192 -    BNF_Def.bnf list * 'a
  12.193 -end;
  12.194 -
  12.195 -structure BNF_FP_Util : BNF_FP_UTIL =
  12.196 -struct
  12.197 -
  12.198 -open BNF_Comp
  12.199 -open BNF_Def
  12.200 -open BNF_Util
  12.201 -
  12.202 -datatype fp_kind = Least_FP | Greatest_FP;
  12.203 -
  12.204 -fun fp_case Least_FP l _ = l
  12.205 -  | fp_case Greatest_FP _ g = g;
  12.206 -
  12.207 -type fp_result =
  12.208 -  {Ts: typ list,
  12.209 -   bnfs: BNF_Def.bnf list,
  12.210 -   ctors: term list,
  12.211 -   dtors: term list,
  12.212 -   xtor_co_iterss: term list list,
  12.213 -   xtor_co_induct: thm,
  12.214 -   dtor_ctors: thm list,
  12.215 -   ctor_dtors: thm list,
  12.216 -   ctor_injects: thm list,
  12.217 -   dtor_injects: thm list,
  12.218 -   xtor_map_thms: thm list,
  12.219 -   xtor_set_thmss: thm list list,
  12.220 -   xtor_rel_thms: thm list,
  12.221 -   xtor_co_iter_thmss: thm list list,
  12.222 -   xtor_co_iter_o_map_thmss: thm list list,
  12.223 -   rel_xtor_co_induct_thm: thm};
  12.224 -
  12.225 -fun morph_fp_result phi {Ts, bnfs, ctors, dtors, xtor_co_iterss, xtor_co_induct, dtor_ctors,
  12.226 -    ctor_dtors, ctor_injects, dtor_injects, xtor_map_thms, xtor_set_thmss, xtor_rel_thms,
  12.227 -    xtor_co_iter_thmss, xtor_co_iter_o_map_thmss, rel_xtor_co_induct_thm} =
  12.228 -  {Ts = map (Morphism.typ phi) Ts,
  12.229 -   bnfs = map (morph_bnf phi) bnfs,
  12.230 -   ctors = map (Morphism.term phi) ctors,
  12.231 -   dtors = map (Morphism.term phi) dtors,
  12.232 -   xtor_co_iterss = map (map (Morphism.term phi)) xtor_co_iterss,
  12.233 -   xtor_co_induct = Morphism.thm phi xtor_co_induct,
  12.234 -   dtor_ctors = map (Morphism.thm phi) dtor_ctors,
  12.235 -   ctor_dtors = map (Morphism.thm phi) ctor_dtors,
  12.236 -   ctor_injects = map (Morphism.thm phi) ctor_injects,
  12.237 -   dtor_injects = map (Morphism.thm phi) dtor_injects,
  12.238 -   xtor_map_thms = map (Morphism.thm phi) xtor_map_thms,
  12.239 -   xtor_set_thmss = map (map (Morphism.thm phi)) xtor_set_thmss,
  12.240 -   xtor_rel_thms = map (Morphism.thm phi) xtor_rel_thms,
  12.241 -   xtor_co_iter_thmss = map (map (Morphism.thm phi)) xtor_co_iter_thmss,
  12.242 -   xtor_co_iter_o_map_thmss = map (map (Morphism.thm phi)) xtor_co_iter_o_map_thmss,
  12.243 -   rel_xtor_co_induct_thm = Morphism.thm phi rel_xtor_co_induct_thm};
  12.244 -
  12.245 -fun eq_fp_result ({bnfs = bnfs1, ...} : fp_result, {bnfs = bnfs2, ...} : fp_result) =
  12.246 -  eq_list eq_bnf (bnfs1, bnfs2);
  12.247 -
  12.248 -fun un_fold_of [f, _] = f;
  12.249 -fun co_rec_of [_, r] = r;
  12.250 -
  12.251 -
  12.252 -fun time ctxt timer msg = (if Config.get ctxt bnf_timing
  12.253 -  then warning (msg ^ ": " ^ ATP_Util.string_of_time (Timer.checkRealTimer timer))
  12.254 -  else (); Timer.startRealTimer ());
  12.255 -
  12.256 -val preN = "pre_"
  12.257 -val rawN = "raw_"
  12.258 -
  12.259 -val coN = "co"
  12.260 -val unN = "un"
  12.261 -val algN = "alg"
  12.262 -val IITN = "IITN"
  12.263 -val foldN = "fold"
  12.264 -val unfoldN = unN ^ foldN
  12.265 -val uniqueN = "_unique"
  12.266 -val transferN = "_transfer"
  12.267 -val simpsN = "simps"
  12.268 -val ctorN = "ctor"
  12.269 -val dtorN = "dtor"
  12.270 -val ctor_foldN = ctorN ^ "_" ^ foldN
  12.271 -val dtor_unfoldN = dtorN ^ "_" ^ unfoldN
  12.272 -val ctor_fold_uniqueN = ctor_foldN ^ uniqueN
  12.273 -val ctor_fold_o_mapN = ctor_foldN ^ "_o_" ^ mapN
  12.274 -val dtor_unfold_uniqueN = dtor_unfoldN ^ uniqueN
  12.275 -val dtor_unfold_o_mapN = dtor_unfoldN ^ "_o_" ^ mapN
  12.276 -val ctor_fold_transferN = ctor_foldN ^ transferN
  12.277 -val dtor_unfold_transferN = dtor_unfoldN ^ transferN
  12.278 -val ctor_mapN = ctorN ^ "_" ^ mapN
  12.279 -val dtor_mapN = dtorN ^ "_" ^ mapN
  12.280 -val map_uniqueN = mapN ^ uniqueN
  12.281 -val ctor_map_uniqueN = ctorN ^ "_" ^ map_uniqueN
  12.282 -val dtor_map_uniqueN = dtorN ^ "_" ^ map_uniqueN
  12.283 -val min_algN = "min_alg"
  12.284 -val morN = "mor"
  12.285 -val bisN = "bis"
  12.286 -val lsbisN = "lsbis"
  12.287 -val sum_bdTN = "sbdT"
  12.288 -val sum_bdN = "sbd"
  12.289 -val carTN = "carT"
  12.290 -val strTN = "strT"
  12.291 -val isNodeN = "isNode"
  12.292 -val LevN = "Lev"
  12.293 -val rvN = "recover"
  12.294 -val behN = "beh"
  12.295 -val setN = "set"
  12.296 -val mk_ctor_setN = prefix (ctorN ^ "_") o mk_setN
  12.297 -val mk_dtor_setN = prefix (dtorN ^ "_") o mk_setN
  12.298 -fun mk_set_inductN i = mk_setN i ^ "_induct"
  12.299 -val mk_dtor_set_inductN = prefix (dtorN ^ "_") o mk_set_inductN
  12.300 -
  12.301 -val str_initN = "str_init"
  12.302 -val recN = "rec"
  12.303 -val corecN = coN ^ recN
  12.304 -val ctor_recN = ctorN ^ "_" ^ recN
  12.305 -val ctor_rec_o_mapN = ctor_recN ^ "_o_" ^ mapN
  12.306 -val ctor_rec_uniqueN = ctor_recN ^ uniqueN
  12.307 -val dtor_corecN = dtorN ^ "_" ^ corecN
  12.308 -val dtor_corec_o_mapN = dtor_corecN ^ "_o_" ^ mapN
  12.309 -val dtor_corec_uniqueN = dtor_corecN ^ uniqueN
  12.310 -
  12.311 -val ctor_dtorN = ctorN ^ "_" ^ dtorN
  12.312 -val dtor_ctorN = dtorN ^ "_" ^ ctorN
  12.313 -val nchotomyN = "nchotomy"
  12.314 -val injectN = "inject"
  12.315 -val exhaustN = "exhaust"
  12.316 -val ctor_injectN = ctorN ^ "_" ^ injectN
  12.317 -val ctor_exhaustN = ctorN ^ "_" ^ exhaustN
  12.318 -val dtor_injectN = dtorN ^ "_" ^ injectN
  12.319 -val dtor_exhaustN = dtorN ^ "_" ^ exhaustN
  12.320 -val ctor_relN = ctorN ^ "_" ^ relN
  12.321 -val dtor_relN = dtorN ^ "_" ^ relN
  12.322 -val inductN = "induct"
  12.323 -val coinductN = coN ^ inductN
  12.324 -val ctor_inductN = ctorN ^ "_" ^ inductN
  12.325 -val ctor_induct2N = ctor_inductN ^ "2"
  12.326 -val dtor_map_coinductN = dtor_mapN ^ "_" ^ coinductN
  12.327 -val dtor_coinductN = dtorN ^ "_" ^ coinductN
  12.328 -val strong_coinductN = "strong_" ^ coinductN
  12.329 -val dtor_map_strong_coinductN = dtor_mapN ^ "_" ^ strong_coinductN
  12.330 -val dtor_strong_coinductN = dtorN ^ "_" ^ strong_coinductN
  12.331 -val hsetN = "Hset"
  12.332 -val hset_recN = hsetN ^ "_rec"
  12.333 -val set_inclN = "set_incl"
  12.334 -val ctor_set_inclN = ctorN ^ "_" ^ set_inclN
  12.335 -val dtor_set_inclN = dtorN ^ "_" ^ set_inclN
  12.336 -val set_set_inclN = "set_set_incl"
  12.337 -val ctor_set_set_inclN = ctorN ^ "_" ^ set_set_inclN
  12.338 -val dtor_set_set_inclN = dtorN ^ "_" ^ set_set_inclN
  12.339 -
  12.340 -val caseN = "case"
  12.341 -val discN = "disc"
  12.342 -val disc_unfoldN = discN ^ "_" ^ unfoldN
  12.343 -val disc_corecN = discN ^ "_" ^ corecN
  12.344 -val iffN = "_iff"
  12.345 -val disc_unfold_iffN = discN ^ "_" ^ unfoldN ^ iffN
  12.346 -val disc_corec_iffN = discN ^ "_" ^ corecN ^ iffN
  12.347 -val distinctN = "distinct"
  12.348 -val rel_distinctN = relN ^ "_" ^ distinctN
  12.349 -val injectN = "inject"
  12.350 -val rel_injectN = relN ^ "_" ^ injectN
  12.351 -val rel_coinductN = relN ^ "_" ^ coinductN
  12.352 -val rel_inductN = relN ^ "_" ^ inductN
  12.353 -val selN = "sel"
  12.354 -val sel_unfoldN = selN ^ "_" ^ unfoldN
  12.355 -val sel_corecN = selN ^ "_" ^ corecN
  12.356 -
  12.357 -fun co_prefix fp = (if fp = Greatest_FP then "co" else "");
  12.358 -
  12.359 -fun add_components_of_typ (Type (s, Ts)) =
  12.360 -    cons (Long_Name.base_name s) #> fold_rev add_components_of_typ Ts
  12.361 -  | add_components_of_typ _ = I;
  12.362 -
  12.363 -fun base_name_of_typ T = space_implode "_" (add_components_of_typ T []);
  12.364 -
  12.365 -val mk_common_name = space_implode "_";
  12.366 -
  12.367 -fun dest_sumT (Type (@{type_name sum}, [T, T'])) = (T, T');
  12.368 -
  12.369 -fun dest_sumTN 1 T = [T]
  12.370 -  | dest_sumTN n (Type (@{type_name sum}, [T, T'])) = T :: dest_sumTN (n - 1) T';
  12.371 -
  12.372 -val dest_sumTN_balanced = Balanced_Tree.dest dest_sumT;
  12.373 -
  12.374 -(* TODO: move something like this to "HOLogic"? *)
  12.375 -fun dest_tupleT 0 @{typ unit} = []
  12.376 -  | dest_tupleT 1 T = [T]
  12.377 -  | dest_tupleT n (Type (@{type_name prod}, [T, T'])) = T :: dest_tupleT (n - 1) T';
  12.378 -
  12.379 -val mk_sumTN = Library.foldr1 mk_sumT;
  12.380 -val mk_sumTN_balanced = Balanced_Tree.make mk_sumT;
  12.381 -
  12.382 -fun mk_proj T n k =
  12.383 -  let val (binders, _) = strip_typeN n T in
  12.384 -    fold_rev (fn T => fn t => Abs (Name.uu, T, t)) binders (Bound (n - k - 1))
  12.385 -  end;
  12.386 -
  12.387 -fun mk_convol (f, g) =
  12.388 -  let
  12.389 -    val (fU, fTU) = `range_type (fastype_of f);
  12.390 -    val ((gT, gU), gTU) = `dest_funT (fastype_of g);
  12.391 -    val convolT = fTU --> gTU --> gT --> HOLogic.mk_prodT (fU, gU);
  12.392 -  in Const (@{const_name convol}, convolT) $ f $ g end;
  12.393 -
  12.394 -fun Inl_const LT RT = Const (@{const_name Inl}, LT --> mk_sumT (LT, RT));
  12.395 -fun mk_Inl RT t = Inl_const (fastype_of t) RT $ t;
  12.396 -
  12.397 -fun Inr_const LT RT = Const (@{const_name Inr}, RT --> mk_sumT (LT, RT));
  12.398 -fun mk_Inr LT t = Inr_const LT (fastype_of t) $ t;
  12.399 -
  12.400 -fun mk_InN [_] t 1 = t
  12.401 -  | mk_InN (_ :: Ts) t 1 = mk_Inl (mk_sumTN Ts) t
  12.402 -  | mk_InN (LT :: Ts) t m = mk_Inr LT (mk_InN Ts t (m - 1))
  12.403 -  | mk_InN Ts t _ = raise (TYPE ("mk_InN", Ts, [t]));
  12.404 -
  12.405 -fun mk_InN_balanced sum_T n t k =
  12.406 -  let
  12.407 -    fun repair_types T (Const (s as @{const_name Inl}, _) $ t) = repair_inj_types T s fst t
  12.408 -      | repair_types T (Const (s as @{const_name Inr}, _) $ t) = repair_inj_types T s snd t
  12.409 -      | repair_types _ t = t
  12.410 -    and repair_inj_types T s get t =
  12.411 -      let val T' = get (dest_sumT T) in
  12.412 -        Const (s, T' --> T) $ repair_types T' t
  12.413 -      end;
  12.414 -  in
  12.415 -    Balanced_Tree.access {left = mk_Inl dummyT, right = mk_Inr dummyT, init = t} n k
  12.416 -    |> repair_types sum_T
  12.417 -  end;
  12.418 -
  12.419 -fun mk_sum_case (f, g) =
  12.420 -  let
  12.421 -    val fT = fastype_of f;
  12.422 -    val gT = fastype_of g;
  12.423 -  in
  12.424 -    Const (@{const_name sum_case},
  12.425 -      fT --> gT --> mk_sumT (domain_type fT, domain_type gT) --> range_type fT) $ f $ g
  12.426 -  end;
  12.427 -
  12.428 -val mk_sum_caseN = Library.foldr1 mk_sum_case;
  12.429 -val mk_sum_caseN_balanced = Balanced_Tree.make mk_sum_case;
  12.430 -
  12.431 -fun If_const T = Const (@{const_name If}, HOLogic.boolT --> T --> T --> T);
  12.432 -fun mk_If p t f = let val T = fastype_of t in If_const T $ p $ t $ f end;
  12.433 -
  12.434 -fun mk_Field r =
  12.435 -  let val T = fst (dest_relT (fastype_of r));
  12.436 -  in Const (@{const_name Field}, mk_relT (T, T) --> HOLogic.mk_setT T) $ r end;
  12.437 -
  12.438 -val mk_union = HOLogic.mk_binop @{const_name sup};
  12.439 -
  12.440 -(*dangerous; use with monotonic, converging functions only!*)
  12.441 -fun fixpoint eq f X = if subset eq (f X, X) then X else fixpoint eq f (f X);
  12.442 -
  12.443 -(* stolen from "~~/src/HOL/Tools/Datatype/datatype_aux.ML" *)
  12.444 -fun split_conj_thm th =
  12.445 -  ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
  12.446 -
  12.447 -fun split_conj_prems limit th =
  12.448 -  let
  12.449 -    fun split n i th =
  12.450 -      if i = n then th else split n (i + 1) (conjI RSN (i, th)) handle THM _ => th;
  12.451 -  in split limit 1 th end;
  12.452 -
  12.453 -fun mk_sumEN 1 = @{thm one_pointE}
  12.454 -  | mk_sumEN 2 = @{thm sumE}
  12.455 -  | mk_sumEN n =
  12.456 -    (fold (fn i => fn thm => @{thm obj_sumE_f} RSN (i, thm)) (2 upto n - 1) @{thm obj_sumE}) OF
  12.457 -      replicate n (impI RS allI);
  12.458 -
  12.459 -fun mk_obj_sumEN_balanced n =
  12.460 -  Balanced_Tree.make (fn (thm1, thm2) => thm1 RSN (1, thm2 RSN (2, @{thm obj_sumE_f})))
  12.461 -    (replicate n asm_rl);
  12.462 -
  12.463 -fun mk_sumEN_balanced' n all_impIs = mk_obj_sumEN_balanced n OF all_impIs RS @{thm obj_one_pointE};
  12.464 -
  12.465 -fun mk_sumEN_balanced 1 = @{thm one_pointE} (*optimization*)
  12.466 -  | mk_sumEN_balanced 2 = @{thm sumE} (*optimization*)
  12.467 -  | mk_sumEN_balanced n = mk_sumEN_balanced' n (replicate n (impI RS allI));
  12.468 -
  12.469 -fun mk_tupled_allIN 0 = @{thm unit_all_impI}
  12.470 -  | mk_tupled_allIN 1 = @{thm impI[THEN allI]}
  12.471 -  | mk_tupled_allIN 2 = @{thm prod_all_impI} (*optimization*)
  12.472 -  | mk_tupled_allIN n = mk_tupled_allIN (n - 1) RS @{thm prod_all_impI_step};
  12.473 -
  12.474 -fun mk_sumEN_tupled_balanced ms =
  12.475 -  let val n = length ms in
  12.476 -    if forall (curry op = 1) ms then mk_sumEN_balanced n
  12.477 -    else mk_sumEN_balanced' n (map mk_tupled_allIN ms)
  12.478 -  end;
  12.479 -
  12.480 -fun mk_sum_casesN 1 1 = refl
  12.481 -  | mk_sum_casesN _ 1 = @{thm sum.cases(1)}
  12.482 -  | mk_sum_casesN 2 2 = @{thm sum.cases(2)}
  12.483 -  | mk_sum_casesN n k = trans OF [@{thm sum_case_step(2)}, mk_sum_casesN (n - 1) (k - 1)];
  12.484 -
  12.485 -fun mk_sum_step base step thm =
  12.486 -  if Thm.eq_thm_prop (thm, refl) then base else trans OF [step, thm];
  12.487 -
  12.488 -fun mk_sum_casesN_balanced 1 1 = refl
  12.489 -  | mk_sum_casesN_balanced n k =
  12.490 -    Balanced_Tree.access {left = mk_sum_step @{thm sum.cases(1)} @{thm sum_case_step(1)},
  12.491 -      right = mk_sum_step @{thm sum.cases(2)} @{thm sum_case_step(2)}, init = refl} n k;
  12.492 -
  12.493 -fun mk_rel_xtor_co_induct_thm fp pre_rels pre_phis rels phis xs ys xtors xtor's tac lthy =
  12.494 -  let
  12.495 -    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
  12.496 -    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
  12.497 -    fun mk_xtor fp' xtor x = if fp = fp' then xtor $ x else x;
  12.498 -    val dtor = mk_xtor Greatest_FP;
  12.499 -    val ctor = mk_xtor Least_FP;
  12.500 -    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
  12.501 -
  12.502 -    fun mk_prem pre_relphi phi x y xtor xtor' =
  12.503 -      HOLogic.mk_Trueprop (list_all_free [x, y] (flip (curry HOLogic.mk_imp)
  12.504 -        (pre_relphi $ (dtor xtor x) $ (dtor xtor' y)) (phi $ (ctor xtor x) $ (ctor xtor' y))));
  12.505 -    val prems = map6 mk_prem pre_relphis pre_phis xs ys xtors xtor's;
  12.506 -
  12.507 -    val concl = HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  12.508 -      (map2 (flip mk_leq) relphis pre_phis));
  12.509 -  in
  12.510 -    Goal.prove_sorry lthy (map (fst o dest_Free) (phis @ pre_phis)) prems concl tac
  12.511 -    |> Thm.close_derivation
  12.512 -    |> (fn thm => thm OF (replicate (length pre_rels) @{thm allI[OF allI[OF impI]]}))
  12.513 -  end;
  12.514 -
  12.515 -fun mk_un_fold_transfer_thms fp pre_rels pre_phis rels phis un_folds un_folds' tac lthy =
  12.516 -  let
  12.517 -    val pre_relphis = map (fn rel => Term.list_comb (rel, phis @ pre_phis)) pre_rels;
  12.518 -    val relphis = map (fn rel => Term.list_comb (rel, phis)) rels;
  12.519 -    fun flip f x y = if fp = Greatest_FP then f y x else f x y;
  12.520 -
  12.521 -    val arg_rels = map2 (flip mk_fun_rel) pre_relphis pre_phis;
  12.522 -    fun mk_transfer relphi pre_phi un_fold un_fold' =
  12.523 -      fold_rev mk_fun_rel arg_rels (flip mk_fun_rel relphi pre_phi) $ un_fold $ un_fold';
  12.524 -    val transfers = map4 mk_transfer relphis pre_phis un_folds un_folds';
  12.525 -
  12.526 -    val goal = fold_rev Logic.all (phis @ pre_phis)
  12.527 -      (HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj transfers));
  12.528 -  in
  12.529 -    Goal.prove_sorry lthy [] [] goal tac
  12.530 -    |> Thm.close_derivation
  12.531 -    |> split_conj_thm
  12.532 -  end;
  12.533 -
  12.534 -fun mk_xtor_un_fold_o_map_thms fp is_rec m un_fold_unique xtor_maps xtor_un_folds sym_map_comps
  12.535 -    map_cong0s =
  12.536 -  let
  12.537 -    val n = length sym_map_comps;
  12.538 -    val rewrite_comp_comp2 = fp_case fp @{thm rewriteR_comp_comp2} @{thm rewriteL_comp_comp2};
  12.539 -    val rewrite_comp_comp = fp_case fp @{thm rewriteR_comp_comp} @{thm rewriteL_comp_comp};
  12.540 -    val map_cong_passive_args1 = replicate m (fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
  12.541 -    val map_cong_active_args1 = replicate n (if is_rec
  12.542 -      then fp_case fp @{thm convol_o} @{thm o_sum_case} RS fun_cong
  12.543 -      else refl);
  12.544 -    val map_cong_passive_args2 = replicate m (fp_case fp @{thm o_id} @{thm id_o} RS fun_cong);
  12.545 -    val map_cong_active_args2 = replicate n (if is_rec
  12.546 -      then fp_case fp @{thm map_pair_o_convol_id} @{thm sum_case_o_sum_map_id}
  12.547 -      else fp_case fp @{thm id_o} @{thm o_id} RS fun_cong);
  12.548 -    fun mk_map_congs passive active = map (fn thm => thm OF (passive @ active) RS ext) map_cong0s;
  12.549 -    val map_cong1s = mk_map_congs map_cong_passive_args1 map_cong_active_args1;
  12.550 -    val map_cong2s = mk_map_congs map_cong_passive_args2 map_cong_active_args2;
  12.551 -    
  12.552 -    fun mk_rewrites map_congs = map2 (fn sym_map_comp => fn map_cong =>
  12.553 -      mk_trans sym_map_comp map_cong RS rewrite_comp_comp) sym_map_comps map_congs;
  12.554 -    val rewrite1s = mk_rewrites map_cong1s;
  12.555 -    val rewrite2s = mk_rewrites map_cong2s;
  12.556 -    val unique_prems =
  12.557 -      map4 (fn xtor_map => fn un_fold => fn rewrite1 => fn rewrite2 =>
  12.558 -        mk_trans (rewrite_comp_comp2 OF [xtor_map, un_fold])
  12.559 -          (mk_trans rewrite1 (mk_sym rewrite2)))
  12.560 -      xtor_maps xtor_un_folds rewrite1s rewrite2s;
  12.561 -  in
  12.562 -    split_conj_thm (un_fold_unique OF map (fp_case fp I mk_sym) unique_prems)
  12.563 -  end;
  12.564 -
  12.565 -fun mk_strong_coinduct_thm coind rel_eqs rel_monos ctxt =
  12.566 -  let
  12.567 -    val n = Thm.nprems_of coind;
  12.568 -    val m = Thm.nprems_of (hd rel_monos) - n;
  12.569 -    fun mk_inst phi = (phi, mk_union (phi, HOLogic.eq_const (fst (dest_pred2T (fastype_of phi)))))
  12.570 -      |> pairself (certify ctxt);
  12.571 -    val insts = Term.add_vars (Thm.prop_of coind) [] |> rev |> take n |> map (mk_inst o Var);
  12.572 -    fun mk_unfold rel_eq rel_mono =
  12.573 -      let
  12.574 -        val eq = iffD2 OF [rel_eq RS @{thm predicate2_eqD}, refl];
  12.575 -        val mono = rel_mono OF (replicate m @{thm order_refl} @ replicate n @{thm eq_subset});
  12.576 -      in eq RS (mono RS @{thm predicate2D}) RS @{thm eqTrueI} end;
  12.577 -    val unfolds = map2 mk_unfold rel_eqs rel_monos @ @{thms sup_fun_def sup_bool_def
  12.578 -      imp_disjL all_conj_distrib subst_eq_imp simp_thms(18,21,35)};
  12.579 -  in
  12.580 -    Thm.instantiate ([], insts) coind
  12.581 -    |> unfold_thms ctxt unfolds
  12.582 -  end;
  12.583 -
  12.584 -fun fp_bnf construct_fp bs resBs fp_eqs lthy =
  12.585 -  let
  12.586 -    val time = time lthy;
  12.587 -    val timer = time (Timer.startRealTimer ());
  12.588 -    val (Xs, rhsXs) = split_list fp_eqs;
  12.589 -
  12.590 -    (* FIXME: because of "@ Xs", the output could contain type variables that are not in the
  12.591 -       input; also, "fp_sort" should put the "resBs" first and in the order in which they appear *)
  12.592 -    fun fp_sort Ass =
  12.593 -      subtract (op =) Xs (filter (fn T => exists (fn Ts => member (op =) Ts T) Ass) resBs) @ Xs;
  12.594 -
  12.595 -    fun raw_qualify base_b =
  12.596 -      let val (_, qs, n) = Binding.dest base_b;
  12.597 -      in
  12.598 -        Binding.prefix_name rawN
  12.599 -        #> fold_rev (fn (s, mand) => Binding.qualify mand s) (qs @ [(n, true)])
  12.600 -        #> Binding.conceal
  12.601 -      end;
  12.602 -
  12.603 -    val ((bnfs, (deadss, livess)), (unfold_set, lthy)) = apfst (apsnd split_list o split_list)
  12.604 -      (fold_map2 (fn b => bnf_of_typ Smart_Inline (raw_qualify b) fp_sort Xs) bs rhsXs
  12.605 -        (empty_unfolds, lthy));
  12.606 -
  12.607 -    fun norm_qualify i = Binding.qualify true (Binding.name_of (nth bs (Int.max (0, i - 1))))
  12.608 -      #> Binding.conceal;
  12.609 -
  12.610 -    val Ass = map (map dest_TFree) livess;
  12.611 -    val resDs = fold (subtract (op =)) Ass resBs;
  12.612 -    val Ds = fold (fold Term.add_tfreesT) deadss [];
  12.613 -
  12.614 -    val timer = time (timer "Construction of BNFs");
  12.615 -
  12.616 -    val ((kill_poss, _), (bnfs', (unfold_set', lthy'))) =
  12.617 -      normalize_bnfs norm_qualify Ass Ds fp_sort bnfs unfold_set lthy;
  12.618 -
  12.619 -    val Dss = map3 (append oo map o nth) livess kill_poss deadss;
  12.620 -
  12.621 -    fun pre_qualify b = Binding.qualify false (Binding.name_of b)
  12.622 -      #> Config.get lthy' bnf_note_all = false ? Binding.conceal;
  12.623 -
  12.624 -    val ((pre_bnfs, deadss), lthy'') =
  12.625 -      fold_map3 (fn b => seal_bnf (pre_qualify b) unfold_set' (Binding.prefix_name preN b))
  12.626 -        bs Dss bnfs' lthy'
  12.627 -      |>> split_list;
  12.628 -
  12.629 -    val timer = time (timer "Normalization & sealing of BNFs");
  12.630 -
  12.631 -    val res = construct_fp bs resBs (map TFree resDs, deadss) pre_bnfs lthy'';
  12.632 -
  12.633 -    val timer = time (timer "FP construction in total");
  12.634 -  in
  12.635 -    timer; (pre_bnfs, res)
  12.636 -  end;
  12.637 -
  12.638 -end;
    13.1 --- a/src/HOL/Tools/BNF/Tools/bnf_gfp.ML	Mon Jan 20 18:24:56 2014 +0100
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,2827 +0,0 @@
    13.4 -(*  Title:      HOL/BNF/Tools/bnf_gfp.ML
    13.5 -    Author:     Dmitriy Traytel, TU Muenchen
    13.6 -    Author:     Andrei Popescu, TU Muenchen
    13.7 -    Author:     Jasmin Blanchette, TU Muenchen
    13.8 -    Copyright   2012
    13.9 -
   13.10 -Codatatype construction.
   13.11 -*)
   13.12 -
   13.13 -signature BNF_GFP =
   13.14 -sig
   13.15 -  val construct_gfp: mixfix list -> binding list -> binding list -> binding list list ->
   13.16 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
   13.17 -    local_theory -> BNF_FP_Util.fp_result * local_theory
   13.18 -end;
   13.19 -
   13.20 -structure BNF_GFP : BNF_GFP =
   13.21 -struct
   13.22 -
   13.23 -open BNF_Def
   13.24 -open BNF_Util
   13.25 -open BNF_Tactics
   13.26 -open BNF_Comp
   13.27 -open BNF_FP_Util
   13.28 -open BNF_FP_Def_Sugar
   13.29 -open BNF_GFP_Rec_Sugar
   13.30 -open BNF_GFP_Util
   13.31 -open BNF_GFP_Tactics
   13.32 -
   13.33 -datatype wit_tree = Wit_Leaf of int | Wit_Node of (int * int * int list) * wit_tree list;
   13.34 -
   13.35 -fun mk_tree_args (I, T) (I', Ts) = (sort_distinct int_ord (I @ I'), T :: Ts);
   13.36 -
   13.37 -fun finish Iss m seen i (nwit, I) =
   13.38 -  let
   13.39 -    val treess = map (fn j =>
   13.40 -        if j < m orelse member (op =) seen j then [([j], Wit_Leaf j)]
   13.41 -        else
   13.42 -          map_index (finish Iss m (insert (op =) j seen) j) (nth Iss (j - m))
   13.43 -          |> flat
   13.44 -          |> minimize_wits)
   13.45 -      I;
   13.46 -  in
   13.47 -    map (fn (I, t) => (I, Wit_Node ((i - m, nwit, filter (fn i => i < m) I), t)))
   13.48 -      (fold_rev (map_product mk_tree_args) treess [([], [])])
   13.49 -    |> minimize_wits
   13.50 -  end;
   13.51 -
   13.52 -fun tree_to_ctor_wit vars _ _ (Wit_Leaf j) = ([j], nth vars j)
   13.53 -  | tree_to_ctor_wit vars ctors witss (Wit_Node ((i, nwit, I), subtrees)) =
   13.54 -     (I, nth ctors i $ (Term.list_comb (snd (nth (nth witss i) nwit),
   13.55 -       map (snd o tree_to_ctor_wit vars ctors witss) subtrees)));
   13.56 -
   13.57 -fun tree_to_coind_wits _ (Wit_Leaf _) = []
   13.58 -  | tree_to_coind_wits lwitss (Wit_Node ((i, nwit, I), subtrees)) =
   13.59 -     ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
   13.60 -
   13.61 -(*all BNFs have the same lives*)
   13.62 -fun construct_gfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs lthy =
   13.63 -  let
   13.64 -    val time = time lthy;
   13.65 -    val timer = time (Timer.startRealTimer ());
   13.66 -
   13.67 -    val live = live_of_bnf (hd bnfs);
   13.68 -    val n = length bnfs; (*active*)
   13.69 -    val ks = 1 upto n;
   13.70 -    val m = live - n; (*passive, if 0 don't generate a new BNF*)
   13.71 -    val ls = 1 upto m;
   13.72 -
   13.73 -    val note_all = Config.get lthy bnf_note_all;
   13.74 -    val b_names = map Binding.name_of bs;
   13.75 -    val b_name = mk_common_name b_names;
   13.76 -    val b = Binding.name b_name;
   13.77 -    val mk_internal_b = Binding.name #> Binding.prefix true b_name #> Binding.conceal;
   13.78 -    fun mk_internal_bs name =
   13.79 -      map (fn b =>
   13.80 -        Binding.prefix true b_name (Binding.prefix_name (name ^ "_") b) |> Binding.conceal) bs;
   13.81 -    val external_bs = map2 (Binding.prefix false) b_names bs
   13.82 -      |> note_all = false ? map Binding.conceal;
   13.83 -
   13.84 -    (* TODO: check if m, n, etc., are sane *)
   13.85 -
   13.86 -    val deads = fold (union (op =)) Dss resDs;
   13.87 -    val names_lthy = fold Variable.declare_typ deads lthy;
   13.88 -    val passives = map fst (subtract (op = o apsnd TFree) deads resBs);
   13.89 -
   13.90 -    (* tvars *)
   13.91 -    val ((((((passiveAs, activeAs), passiveBs), activeBs), passiveCs), activeCs), idxT) = names_lthy
   13.92 -      |> variant_tfrees passives
   13.93 -      ||>> mk_TFrees n
   13.94 -      ||>> variant_tfrees passives
   13.95 -      ||>> mk_TFrees n
   13.96 -      ||>> mk_TFrees m
   13.97 -      ||>> mk_TFrees n
   13.98 -      ||> fst o mk_TFrees 1
   13.99 -      ||> the_single;
  13.100 -
  13.101 -    val allAs = passiveAs @ activeAs;
  13.102 -    val allBs' = passiveBs @ activeBs;
  13.103 -    val Ass = replicate n allAs;
  13.104 -    val allBs = passiveAs @ activeBs;
  13.105 -    val Bss = replicate n allBs;
  13.106 -    val allCs = passiveAs @ activeCs;
  13.107 -    val allCs' = passiveBs @ activeCs;
  13.108 -    val Css' = replicate n allCs';
  13.109 -
  13.110 -    (* types *)
  13.111 -    val dead_poss =
  13.112 -      map (fn x => if member (op =) deads (TFree x) then SOME (TFree x) else NONE) resBs;
  13.113 -    fun mk_param NONE passive = (hd passive, tl passive)
  13.114 -      | mk_param (SOME a) passive = (a, passive);
  13.115 -    val mk_params = fold_map mk_param dead_poss #> fst;
  13.116 -
  13.117 -    fun mk_FTs Ts = map2 (fn Ds => mk_T_of_bnf Ds Ts) Dss bnfs;
  13.118 -    val (params, params') = `(map Term.dest_TFree) (mk_params passiveAs);
  13.119 -    val (dead_params, dead_params') = `(map Term.dest_TFree) (subtract (op =) passiveAs params');
  13.120 -    val FTsAs = mk_FTs allAs;
  13.121 -    val FTsBs = mk_FTs allBs;
  13.122 -    val FTsCs = mk_FTs allCs;
  13.123 -    val ATs = map HOLogic.mk_setT passiveAs;
  13.124 -    val BTs = map HOLogic.mk_setT activeAs;
  13.125 -    val B'Ts = map HOLogic.mk_setT activeBs;
  13.126 -    val B''Ts = map HOLogic.mk_setT activeCs;
  13.127 -    val sTs = map2 (fn T => fn U => T --> U) activeAs FTsAs;
  13.128 -    val s'Ts = map2 (fn T => fn U => T --> U) activeBs FTsBs;
  13.129 -    val s''Ts = map2 (fn T => fn U => T --> U) activeCs FTsCs;
  13.130 -    val fTs = map2 (fn T => fn U => T --> U) activeAs activeBs;
  13.131 -    val self_fTs = map (fn T => T --> T) activeAs;
  13.132 -    val gTs = map2 (fn T => fn U => T --> U) activeBs activeCs;
  13.133 -    val all_gTs = map2 (fn T => fn U => T --> U) allBs allCs';
  13.134 -    val RTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeBs;
  13.135 -    val sRTs = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeAs activeAs;
  13.136 -    val R'Ts = map2 (fn T => fn U => HOLogic.mk_prodT (T, U)) activeBs activeCs;
  13.137 -    val setsRTs = map HOLogic.mk_setT sRTs;
  13.138 -    val setRTs = map HOLogic.mk_setT RTs;
  13.139 -    val all_sbisT = HOLogic.mk_tupleT setsRTs;
  13.140 -    val setR'Ts = map HOLogic.mk_setT R'Ts;
  13.141 -    val FRTs = mk_FTs (passiveAs @ RTs);
  13.142 -    val sumBsAs = map2 (curry mk_sumT) activeBs activeAs;
  13.143 -    val sumFTs = mk_FTs (passiveAs @ sumBsAs);
  13.144 -    val sum_sTs = map2 (fn T => fn U => T --> U) activeAs sumFTs;
  13.145 -
  13.146 -    (* terms *)
  13.147 -    val mapsAsAs = map4 mk_map_of_bnf Dss Ass Ass bnfs;
  13.148 -    val mapsAsBs = map4 mk_map_of_bnf Dss Ass Bss bnfs;
  13.149 -    val mapsBsCs' = map4 mk_map_of_bnf Dss Bss Css' bnfs;
  13.150 -    val mapsAsCs' = map4 mk_map_of_bnf Dss Ass Css' bnfs;
  13.151 -    val map_Inls = map4 mk_map_of_bnf Dss Bss (replicate n (passiveAs @ sumBsAs)) bnfs;
  13.152 -    val map_Inls_rev = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ sumBsAs)) Bss bnfs;
  13.153 -    val map_fsts = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Ass bnfs;
  13.154 -    val map_snds = map4 mk_map_of_bnf Dss (replicate n (passiveAs @ RTs)) Bss bnfs;
  13.155 -    fun mk_setss Ts = map3 mk_sets_of_bnf (map (replicate live) Dss)
  13.156 -      (map (replicate live) (replicate n Ts)) bnfs;
  13.157 -    val setssAs = mk_setss allAs;
  13.158 -    val setssAs' = transpose setssAs;
  13.159 -    val bis_setss = mk_setss (passiveAs @ RTs);
  13.160 -    val relsAsBs = map4 mk_rel_of_bnf Dss Ass Bss bnfs;
  13.161 -    val bds = map3 mk_bd_of_bnf Dss Ass bnfs;
  13.162 -    val sum_bd = Library.foldr1 (uncurry mk_csum) bds;
  13.163 -    val sum_bdT = fst (dest_relT (fastype_of sum_bd));
  13.164 -
  13.165 -    val emptys = map (fn T => HOLogic.mk_set T []) passiveAs;
  13.166 -    val Zeros = map (fn empty =>
  13.167 -     HOLogic.mk_tuple (map (fn U => absdummy U empty) activeAs)) emptys;
  13.168 -    val hrecTs = map fastype_of Zeros;
  13.169 -    val hsetTs = map (fn hrecT => Library.foldr (op -->) (sTs, HOLogic.natT --> hrecT)) hrecTs;
  13.170 -
  13.171 -    val (((((((((((((((((((((((((((((((((((zs, zs'), zs_copy), zs_copy2), z's), (ys, ys')),
  13.172 -      As), Bs), Bs_copy), B's), B''s), ss), sum_ss), s's), s''s), fs), fs_copy),
  13.173 -      self_fs), gs), all_gs), xFs), yFs), yFs_copy), RFs), (Rtuple, Rtuple')), (hrecs, hrecs')),
  13.174 -      (nat, nat')), Rs), Rs_copy), R's), sRs), (idx, idx')), Idx), Ris), Kss), names_lthy) = lthy
  13.175 -      |> mk_Frees' "b" activeAs
  13.176 -      ||>> mk_Frees "b" activeAs
  13.177 -      ||>> mk_Frees "b" activeAs
  13.178 -      ||>> mk_Frees "b" activeBs
  13.179 -      ||>> mk_Frees' "y" passiveAs
  13.180 -      ||>> mk_Frees "A" ATs
  13.181 -      ||>> mk_Frees "B" BTs
  13.182 -      ||>> mk_Frees "B" BTs
  13.183 -      ||>> mk_Frees "B'" B'Ts
  13.184 -      ||>> mk_Frees "B''" B''Ts
  13.185 -      ||>> mk_Frees "s" sTs
  13.186 -      ||>> mk_Frees "sums" sum_sTs
  13.187 -      ||>> mk_Frees "s'" s'Ts
  13.188 -      ||>> mk_Frees "s''" s''Ts
  13.189 -      ||>> mk_Frees "f" fTs
  13.190 -      ||>> mk_Frees "f" fTs
  13.191 -      ||>> mk_Frees "f" self_fTs
  13.192 -      ||>> mk_Frees "g" gTs
  13.193 -      ||>> mk_Frees "g" all_gTs
  13.194 -      ||>> mk_Frees "x" FTsAs
  13.195 -      ||>> mk_Frees "y" FTsBs
  13.196 -      ||>> mk_Frees "y" FTsBs
  13.197 -      ||>> mk_Frees "x" FRTs
  13.198 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Rtuple") all_sbisT
  13.199 -      ||>> mk_Frees' "rec" hrecTs
  13.200 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "n") HOLogic.natT
  13.201 -      ||>> mk_Frees "R" setRTs
  13.202 -      ||>> mk_Frees "R" setRTs
  13.203 -      ||>> mk_Frees "R'" setR'Ts
  13.204 -      ||>> mk_Frees "R" setsRTs
  13.205 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "i") idxT
  13.206 -      ||>> yield_singleton (mk_Frees "I") (HOLogic.mk_setT idxT)
  13.207 -      ||>> mk_Frees "Ri" (map (fn T => idxT --> T) setRTs)
  13.208 -      ||>> mk_Freess "K" (map (fn AT => map (fn T => T --> AT) activeAs) ATs);
  13.209 -
  13.210 -    val passive_UNIVs = map HOLogic.mk_UNIV passiveAs;
  13.211 -    val passive_Id_ons = map mk_Id_on As;
  13.212 -    val active_UNIVs = map HOLogic.mk_UNIV activeAs;
  13.213 -    val sum_UNIVs = map HOLogic.mk_UNIV sumBsAs;
  13.214 -    val passive_ids = map HOLogic.id_const passiveAs;
  13.215 -    val active_ids = map HOLogic.id_const activeAs;
  13.216 -    val Inls = map2 Inl_const activeBs activeAs;
  13.217 -    val fsts = map fst_const RTs;
  13.218 -    val snds = map snd_const RTs;
  13.219 -
  13.220 -    (* thms *)
  13.221 -    val bd_card_orders = map bd_card_order_of_bnf bnfs;
  13.222 -    val bd_card_order = hd bd_card_orders
  13.223 -    val bd_Card_orders = map bd_Card_order_of_bnf bnfs;
  13.224 -    val bd_Card_order = hd bd_Card_orders;
  13.225 -    val bd_Cinfinites = map bd_Cinfinite_of_bnf bnfs;
  13.226 -    val bd_Cinfinite = hd bd_Cinfinites;
  13.227 -    val in_monos = map in_mono_of_bnf bnfs;
  13.228 -    val map_comp0s = map map_comp0_of_bnf bnfs;
  13.229 -    val sym_map_comps = map mk_sym map_comp0s;
  13.230 -    val map_comps = map map_comp_of_bnf bnfs;
  13.231 -    val map_cong0s = map map_cong0_of_bnf bnfs;
  13.232 -    val map_id0s = map map_id0_of_bnf bnfs;
  13.233 -    val map_ids = map map_id_of_bnf bnfs;
  13.234 -    val set_bdss = map set_bd_of_bnf bnfs;
  13.235 -    val set_mapss = map set_map_of_bnf bnfs;
  13.236 -    val rel_congs = map rel_cong_of_bnf bnfs;
  13.237 -    val rel_converseps = map rel_conversep_of_bnf bnfs;
  13.238 -    val rel_Grps = map rel_Grp_of_bnf bnfs;
  13.239 -    val rel_OOs = map rel_OO_of_bnf bnfs;
  13.240 -    val rel_OO_Grps = map rel_OO_Grp_of_bnf bnfs;
  13.241 -
  13.242 -    val timer = time (timer "Extracted terms & thms");
  13.243 -
  13.244 -    (* derived thms *)
  13.245 -
  13.246 -    (*map g1 ... gm g(m+1) ... g(m+n) (map id ... id f(m+1) ... f(m+n) x) =
  13.247 -      map g1 ... gm (g(m+1) o f(m+1)) ... (g(m+n) o f(m+n)) x*)
  13.248 -    fun mk_map_comp_id x mapAsBs mapBsCs mapAsCs map_comp0 =
  13.249 -      let
  13.250 -        val lhs = Term.list_comb (mapBsCs, all_gs) $
  13.251 -          (Term.list_comb (mapAsBs, passive_ids @ fs) $ x);
  13.252 -        val rhs =
  13.253 -          Term.list_comb (mapAsCs, take m all_gs @ map HOLogic.mk_comp (drop m all_gs ~~ fs)) $ x;
  13.254 -      in
  13.255 -        Goal.prove_sorry lthy [] []
  13.256 -          (fold_rev Logic.all (x :: fs @ all_gs) (mk_Trueprop_eq (lhs, rhs)))
  13.257 -          (K (mk_map_comp_id_tac map_comp0))
  13.258 -        |> Thm.close_derivation
  13.259 -      end;
  13.260 -
  13.261 -    val map_comp_id_thms = map5 mk_map_comp_id xFs mapsAsBs mapsBsCs' mapsAsCs' map_comps;
  13.262 -
  13.263 -    (*forall a : set(m+1) x. f(m+1) a = a; ...; forall a : set(m+n) x. f(m+n) a = a ==>
  13.264 -      map id ... id f(m+1) ... f(m+n) x = x*)
  13.265 -    fun mk_map_cong0L x mapAsAs sets map_cong0 map_id =
  13.266 -      let
  13.267 -        fun mk_prem set f z z' =
  13.268 -          HOLogic.mk_Trueprop
  13.269 -            (mk_Ball (set $ x) (Term.absfree z' (HOLogic.mk_eq (f $ z, z))));
  13.270 -        val prems = map4 mk_prem (drop m sets) self_fs zs zs';
  13.271 -        val goal = mk_Trueprop_eq (Term.list_comb (mapAsAs, passive_ids @ self_fs) $ x, x);
  13.272 -      in
  13.273 -        Goal.prove_sorry lthy [] []
  13.274 -          (fold_rev Logic.all (x :: self_fs) (Logic.list_implies (prems, goal)))
  13.275 -          (K (mk_map_cong0L_tac m map_cong0 map_id))
  13.276 -        |> Thm.close_derivation
  13.277 -      end;
  13.278 -
  13.279 -    val map_cong0L_thms = map5 mk_map_cong0L xFs mapsAsAs setssAs map_cong0s map_ids;
  13.280 -    val in_mono'_thms = map (fn thm =>
  13.281 -      (thm OF (replicate m subset_refl)) RS @{thm set_mp}) in_monos;
  13.282 -
  13.283 -    val map_arg_cong_thms =
  13.284 -      let
  13.285 -        val prems = map2 (curry mk_Trueprop_eq) yFs yFs_copy;
  13.286 -        val maps = map (fn mapx => Term.list_comb (mapx, all_gs)) mapsBsCs';
  13.287 -        val concls =
  13.288 -          map3 (fn x => fn y => fn mapx => mk_Trueprop_eq (mapx $ x, mapx $ y)) yFs yFs_copy maps;
  13.289 -        val goals =
  13.290 -          map4 (fn prem => fn concl => fn x => fn y =>
  13.291 -            fold_rev Logic.all (x :: y :: all_gs) (Logic.mk_implies (prem, concl)))
  13.292 -          prems concls yFs yFs_copy;
  13.293 -      in
  13.294 -        map (fn goal => Goal.prove_sorry lthy [] [] goal
  13.295 -          (K ((hyp_subst_tac lthy THEN' rtac refl) 1)) |> Thm.close_derivation) goals
  13.296 -      end;
  13.297 -
  13.298 -    val timer = time (timer "Derived simple theorems");
  13.299 -
  13.300 -    (* coalgebra *)
  13.301 -
  13.302 -    val coalg_bind = mk_internal_b (coN ^ algN) ;
  13.303 -    val coalg_name = Binding.name_of coalg_bind;
  13.304 -    val coalg_def_bind = (Thm.def_binding coalg_bind, []);
  13.305 -
  13.306 -    (*forall i = 1 ... n: (\<forall>x \<in> Bi. si \<in> Fi_in A1 .. Am B1 ... Bn)*)
  13.307 -    val coalg_spec =
  13.308 -      let
  13.309 -        val coalgT = Library.foldr (op -->) (ATs @ BTs @ sTs, HOLogic.boolT);
  13.310 -
  13.311 -        val ins = map3 mk_in (replicate n (As @ Bs)) setssAs FTsAs;
  13.312 -        fun mk_coalg_conjunct B s X z z' =
  13.313 -          mk_Ball B (Term.absfree z' (HOLogic.mk_mem (s $ z, X)));
  13.314 -
  13.315 -        val lhs = Term.list_comb (Free (coalg_name, coalgT), As @ Bs @ ss);
  13.316 -        val rhs = Library.foldr1 HOLogic.mk_conj (map5 mk_coalg_conjunct Bs ss ins zs zs')
  13.317 -      in
  13.318 -        mk_Trueprop_eq (lhs, rhs)
  13.319 -      end;
  13.320 -
  13.321 -    val ((coalg_free, (_, coalg_def_free)), (lthy, lthy_old)) =
  13.322 -      lthy
  13.323 -      |> Specification.definition (SOME (coalg_bind, NONE, NoSyn), (coalg_def_bind, coalg_spec))
  13.324 -      ||> `Local_Theory.restore;
  13.325 -
  13.326 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.327 -    val coalg = fst (Term.dest_Const (Morphism.term phi coalg_free));
  13.328 -    val coalg_def = Morphism.thm phi coalg_def_free;
  13.329 -
  13.330 -    fun mk_coalg As Bs ss =
  13.331 -      let
  13.332 -        val args = As @ Bs @ ss;
  13.333 -        val Ts = map fastype_of args;
  13.334 -        val coalgT = Library.foldr (op -->) (Ts, HOLogic.boolT);
  13.335 -      in
  13.336 -        Term.list_comb (Const (coalg, coalgT), args)
  13.337 -      end;
  13.338 -
  13.339 -    val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
  13.340 -
  13.341 -    val coalg_in_thms = map (fn i =>
  13.342 -      coalg_def RS iffD1 RS mk_conjunctN n i RS bspec) ks
  13.343 -
  13.344 -    val coalg_set_thmss =
  13.345 -      let
  13.346 -        val coalg_prem = HOLogic.mk_Trueprop (mk_coalg As Bs ss);
  13.347 -        fun mk_prem x B = HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B));
  13.348 -        fun mk_concl s x B set = HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) B);
  13.349 -        val prems = map2 mk_prem zs Bs;
  13.350 -        val conclss = map3 (fn s => fn x => fn sets => map2 (mk_concl s x) (As @ Bs) sets)
  13.351 -          ss zs setssAs;
  13.352 -        val goalss = map3 (fn x => fn prem => fn concls => map (fn concl =>
  13.353 -          fold_rev Logic.all (x :: As @ Bs @ ss)
  13.354 -            (Logic.list_implies (coalg_prem :: [prem], concl))) concls) zs prems conclss;
  13.355 -      in
  13.356 -        map (fn goals => map (fn goal => Goal.prove_sorry lthy [] [] goal
  13.357 -          (K (mk_coalg_set_tac coalg_def)) |> Thm.close_derivation) goals) goalss
  13.358 -      end;
  13.359 -
  13.360 -    fun mk_tcoalg ATs BTs = mk_coalg (map HOLogic.mk_UNIV ATs) (map HOLogic.mk_UNIV BTs);
  13.361 -
  13.362 -    val tcoalg_thm =
  13.363 -      let
  13.364 -        val goal = fold_rev Logic.all ss
  13.365 -          (HOLogic.mk_Trueprop (mk_tcoalg passiveAs activeAs ss))
  13.366 -      in
  13.367 -        Goal.prove_sorry lthy [] [] goal
  13.368 -          (K (stac coalg_def 1 THEN CONJ_WRAP
  13.369 -            (K (EVERY' [rtac ballI, rtac CollectI,
  13.370 -              CONJ_WRAP' (K (EVERY' [rtac @{thm subset_UNIV}])) allAs] 1)) ss))
  13.371 -        |> Thm.close_derivation
  13.372 -      end;
  13.373 -
  13.374 -    val timer = time (timer "Coalgebra definition & thms");
  13.375 -
  13.376 -    (* morphism *)
  13.377 -
  13.378 -    val mor_bind = mk_internal_b morN;
  13.379 -    val mor_name = Binding.name_of mor_bind;
  13.380 -    val mor_def_bind = (Thm.def_binding mor_bind, []);
  13.381 -
  13.382 -    (*fbetw) forall i = 1 ... n: (\<forall>x \<in> Bi. fi x \<in> B'i)*)
  13.383 -    (*mor) forall i = 1 ... n: (\<forall>x \<in> Bi.
  13.384 -       Fi_map id ... id f1 ... fn (si x) = si' (fi x)*)
  13.385 -    val mor_spec =
  13.386 -      let
  13.387 -        val morT = Library.foldr (op -->) (BTs @ sTs @ B'Ts @ s'Ts @ fTs, HOLogic.boolT);
  13.388 -
  13.389 -        fun mk_fbetw f B1 B2 z z' =
  13.390 -          mk_Ball B1 (Term.absfree z' (HOLogic.mk_mem (f $ z, B2)));
  13.391 -        fun mk_mor B mapAsBs f s s' z z' =
  13.392 -          mk_Ball B (Term.absfree z' (HOLogic.mk_eq
  13.393 -            (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ z]), s' $ (f $ z))));
  13.394 -        val lhs = Term.list_comb (Free (mor_name, morT), Bs @ ss @ B's @ s's @ fs);
  13.395 -        val rhs = HOLogic.mk_conj
  13.396 -          (Library.foldr1 HOLogic.mk_conj (map5 mk_fbetw fs Bs B's zs zs'),
  13.397 -           Library.foldr1 HOLogic.mk_conj (map7 mk_mor Bs mapsAsBs fs ss s's zs zs'))
  13.398 -      in
  13.399 -        mk_Trueprop_eq (lhs, rhs)
  13.400 -      end;
  13.401 -
  13.402 -    val ((mor_free, (_, mor_def_free)), (lthy, lthy_old)) =
  13.403 -      lthy
  13.404 -      |> Specification.definition (SOME (mor_bind, NONE, NoSyn), (mor_def_bind, mor_spec))
  13.405 -      ||> `Local_Theory.restore;
  13.406 -
  13.407 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.408 -    val mor = fst (Term.dest_Const (Morphism.term phi mor_free));
  13.409 -    val mor_def = Morphism.thm phi mor_def_free;
  13.410 -
  13.411 -    fun mk_mor Bs1 ss1 Bs2 ss2 fs =
  13.412 -      let
  13.413 -        val args = Bs1 @ ss1 @ Bs2 @ ss2 @ fs;
  13.414 -        val Ts = map fastype_of (Bs1 @ ss1 @ Bs2 @ ss2 @ fs);
  13.415 -        val morT = Library.foldr (op -->) (Ts, HOLogic.boolT);
  13.416 -      in
  13.417 -        Term.list_comb (Const (mor, morT), args)
  13.418 -      end;
  13.419 -
  13.420 -    val mor_prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
  13.421 -
  13.422 -    val (mor_image_thms, morE_thms) =
  13.423 -      let
  13.424 -        val prem = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs);
  13.425 -        fun mk_image_goal f B1 B2 = fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs)
  13.426 -          (Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_leq (mk_image f $ B1) B2)));
  13.427 -        val image_goals = map3 mk_image_goal fs Bs B's;
  13.428 -        fun mk_elim_goal B mapAsBs f s s' x =
  13.429 -          fold_rev Logic.all (x :: Bs @ ss @ B's @ s's @ fs)
  13.430 -            (Logic.list_implies ([prem, HOLogic.mk_Trueprop (HOLogic.mk_mem (x, B))],
  13.431 -              mk_Trueprop_eq (Term.list_comb (mapAsBs, passive_ids @ fs @ [s $ x]), s' $ (f $ x))));
  13.432 -        val elim_goals = map6 mk_elim_goal Bs mapsAsBs fs ss s's zs;
  13.433 -        fun prove goal =
  13.434 -          Goal.prove_sorry lthy [] [] goal (K (mk_mor_elim_tac mor_def))
  13.435 -          |> Thm.close_derivation;
  13.436 -      in
  13.437 -        (map prove image_goals, map prove elim_goals)
  13.438 -      end;
  13.439 -
  13.440 -    val mor_image'_thms = map (fn thm => @{thm set_mp} OF [thm, imageI]) mor_image_thms;
  13.441 -
  13.442 -    val mor_incl_thm =
  13.443 -      let
  13.444 -        val prems = map2 (HOLogic.mk_Trueprop oo mk_leq) Bs Bs_copy;
  13.445 -        val concl = HOLogic.mk_Trueprop (mk_mor Bs ss Bs_copy ss active_ids);
  13.446 -      in
  13.447 -        Goal.prove_sorry lthy [] []
  13.448 -          (fold_rev Logic.all (Bs @ ss @ Bs_copy) (Logic.list_implies (prems, concl)))
  13.449 -          (K (mk_mor_incl_tac mor_def map_ids))
  13.450 -        |> Thm.close_derivation
  13.451 -      end;
  13.452 -
  13.453 -    val mor_id_thm = mor_incl_thm OF (replicate n subset_refl);
  13.454 -
  13.455 -    val mor_comp_thm =
  13.456 -      let
  13.457 -        val prems =
  13.458 -          [HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs),
  13.459 -           HOLogic.mk_Trueprop (mk_mor B's s's B''s s''s gs)];
  13.460 -        val concl =
  13.461 -          HOLogic.mk_Trueprop (mk_mor Bs ss B''s s''s (map2 (curry HOLogic.mk_comp) gs fs));
  13.462 -      in
  13.463 -        Goal.prove_sorry lthy [] []
  13.464 -          (fold_rev Logic.all (Bs @ ss @ B's @ s's @ B''s @ s''s @ fs @ gs)
  13.465 -            (Logic.list_implies (prems, concl)))
  13.466 -          (K (mk_mor_comp_tac mor_def mor_image'_thms morE_thms map_comp_id_thms))
  13.467 -        |> Thm.close_derivation
  13.468 -      end;
  13.469 -
  13.470 -    val mor_cong_thm =
  13.471 -      let
  13.472 -        val prems = map HOLogic.mk_Trueprop
  13.473 -         (map2 (curry HOLogic.mk_eq) fs_copy fs @ [mk_mor Bs ss B's s's fs])
  13.474 -        val concl = HOLogic.mk_Trueprop (mk_mor Bs ss B's s's fs_copy);
  13.475 -      in
  13.476 -        Goal.prove_sorry lthy [] []
  13.477 -          (fold_rev Logic.all (Bs @ ss @ B's @ s's @ fs @ fs_copy)
  13.478 -            (Logic.list_implies (prems, concl)))
  13.479 -          (K ((hyp_subst_tac lthy THEN' atac) 1))
  13.480 -        |> Thm.close_derivation
  13.481 -      end;
  13.482 -
  13.483 -    val mor_UNIV_thm =
  13.484 -      let
  13.485 -        fun mk_conjunct mapAsBs f s s' = HOLogic.mk_eq
  13.486 -            (HOLogic.mk_comp (Term.list_comb (mapAsBs, passive_ids @ fs), s),
  13.487 -            HOLogic.mk_comp (s', f));
  13.488 -        val lhs = mk_mor active_UNIVs ss (map HOLogic.mk_UNIV activeBs) s's fs;
  13.489 -        val rhs = Library.foldr1 HOLogic.mk_conj (map4 mk_conjunct mapsAsBs fs ss s's);
  13.490 -      in
  13.491 -        Goal.prove_sorry lthy [] [] (fold_rev Logic.all (ss @ s's @ fs) (mk_Trueprop_eq (lhs, rhs)))
  13.492 -          (K (mk_mor_UNIV_tac morE_thms mor_def))
  13.493 -        |> Thm.close_derivation
  13.494 -      end;
  13.495 -
  13.496 -    val mor_str_thm =
  13.497 -      let
  13.498 -        val maps = map2 (fn Ds => fn bnf => Term.list_comb
  13.499 -          (mk_map_of_bnf Ds allAs (passiveAs @ FTsAs) bnf, passive_ids @ ss)) Dss bnfs;
  13.500 -      in
  13.501 -        Goal.prove_sorry lthy [] []
  13.502 -          (fold_rev Logic.all ss (HOLogic.mk_Trueprop
  13.503 -            (mk_mor active_UNIVs ss (map HOLogic.mk_UNIV FTsAs) maps ss)))
  13.504 -          (K (mk_mor_str_tac ks mor_UNIV_thm))
  13.505 -        |> Thm.close_derivation
  13.506 -      end;
  13.507 -
  13.508 -    val mor_sum_case_thm =
  13.509 -      let
  13.510 -        val maps = map3 (fn s => fn sum_s => fn mapx =>
  13.511 -          mk_sum_case (HOLogic.mk_comp (Term.list_comb (mapx, passive_ids @ Inls), s), sum_s))
  13.512 -          s's sum_ss map_Inls;
  13.513 -      in
  13.514 -        Goal.prove_sorry lthy [] []
  13.515 -          (fold_rev Logic.all (s's @ sum_ss) (HOLogic.mk_Trueprop
  13.516 -            (mk_mor (map HOLogic.mk_UNIV activeBs) s's sum_UNIVs maps Inls)))
  13.517 -          (K (mk_mor_sum_case_tac ks mor_UNIV_thm))
  13.518 -        |> Thm.close_derivation
  13.519 -      end;
  13.520 -
  13.521 -    val timer = time (timer "Morphism definition & thms");
  13.522 -
  13.523 -    fun hset_rec_bind j = mk_internal_b (hset_recN ^ (if m = 1 then "" else string_of_int j));
  13.524 -    val hset_rec_name = Binding.name_of o hset_rec_bind;
  13.525 -    val hset_rec_def_bind = rpair [] o Thm.def_binding o hset_rec_bind;
  13.526 -
  13.527 -    fun hset_rec_spec j Zero hsetT hrec hrec' =
  13.528 -      let
  13.529 -        fun mk_Suc s setsAs z z' =
  13.530 -          let
  13.531 -            val (set, sets) = apfst (fn xs => nth xs (j - 1)) (chop m setsAs);
  13.532 -            fun mk_UN set k = mk_UNION (set $ (s $ z)) (mk_nthN n hrec k);
  13.533 -          in
  13.534 -            Term.absfree z'
  13.535 -              (mk_union (set $ (s $ z), Library.foldl1 mk_union (map2 mk_UN sets ks)))
  13.536 -          end;
  13.537 -
  13.538 -        val Suc = Term.absdummy HOLogic.natT (Term.absfree hrec'
  13.539 -          (HOLogic.mk_tuple (map4 mk_Suc ss setssAs zs zs')));
  13.540 -
  13.541 -        val lhs = Term.list_comb (Free (hset_rec_name j, hsetT), ss);
  13.542 -        val rhs = mk_nat_rec Zero Suc;
  13.543 -      in
  13.544 -        mk_Trueprop_eq (lhs, rhs)
  13.545 -      end;
  13.546 -
  13.547 -    val ((hset_rec_frees, (_, hset_rec_def_frees)), (lthy, lthy_old)) =
  13.548 -      lthy
  13.549 -      |> fold_map5 (fn j => fn Zero => fn hsetT => fn hrec => fn hrec' => Specification.definition
  13.550 -        (SOME (hset_rec_bind j, NONE, NoSyn),
  13.551 -          (hset_rec_def_bind j, hset_rec_spec j Zero hsetT hrec hrec')))
  13.552 -        ls Zeros hsetTs hrecs hrecs'
  13.553 -      |>> apsnd split_list o split_list
  13.554 -      ||> `Local_Theory.restore;
  13.555 -
  13.556 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.557 -
  13.558 -    val hset_rec_defs = map (Morphism.thm phi) hset_rec_def_frees;
  13.559 -    val hset_recs = map (fst o Term.dest_Const o Morphism.term phi) hset_rec_frees;
  13.560 -
  13.561 -    fun mk_hset_rec ss nat i j T =
  13.562 -      let
  13.563 -        val args = ss @ [nat];
  13.564 -        val Ts = map fastype_of ss;
  13.565 -        val bTs = map domain_type Ts;
  13.566 -        val hrecT = HOLogic.mk_tupleT (map (fn U => U --> HOLogic.mk_setT T) bTs)
  13.567 -        val hset_recT = Library.foldr (op -->) (Ts, HOLogic.natT --> hrecT);
  13.568 -      in
  13.569 -        mk_nthN n (Term.list_comb (Const (nth hset_recs (j - 1), hset_recT), args)) i
  13.570 -      end;
  13.571 -
  13.572 -    val hset_rec_0ss = mk_rec_simps n @{thm nat_rec_0} hset_rec_defs;
  13.573 -    val hset_rec_Sucss = mk_rec_simps n @{thm nat_rec_Suc} hset_rec_defs;
  13.574 -    val hset_rec_0ss' = transpose hset_rec_0ss;
  13.575 -    val hset_rec_Sucss' = transpose hset_rec_Sucss;
  13.576 -
  13.577 -    fun hset_binds j = mk_internal_bs (hsetN ^ (if m = 1 then "" else string_of_int j))
  13.578 -    fun hset_bind i j = nth (hset_binds j) (i - 1);
  13.579 -    val hset_name = Binding.name_of oo hset_bind;
  13.580 -    val hset_def_bind = rpair [] o Thm.def_binding oo hset_bind;
  13.581 -
  13.582 -    fun hset_spec i j =
  13.583 -      let
  13.584 -        val U = nth activeAs (i - 1);
  13.585 -        val z = nth zs (i - 1);
  13.586 -        val T = nth passiveAs (j - 1);
  13.587 -        val setT = HOLogic.mk_setT T;
  13.588 -        val hsetT = Library.foldr (op -->) (sTs, U --> setT);
  13.589 -
  13.590 -        val lhs = Term.list_comb (Free (hset_name i j, hsetT), ss @ [z]);
  13.591 -        val rhs = mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
  13.592 -          (Term.absfree nat' (mk_hset_rec ss nat i j T $ z));
  13.593 -      in
  13.594 -        mk_Trueprop_eq (lhs, rhs)
  13.595 -      end;
  13.596 -
  13.597 -    val ((hset_frees, (_, hset_def_frees)), (lthy, lthy_old)) =
  13.598 -      lthy
  13.599 -      |> fold_map (fn i => fold_map (fn j => Specification.definition
  13.600 -        (SOME (hset_bind i j, NONE, NoSyn), (hset_def_bind i j, hset_spec i j))) ls) ks
  13.601 -      |>> map (apsnd split_list o split_list)
  13.602 -      |>> apsnd split_list o split_list
  13.603 -      ||> `Local_Theory.restore;
  13.604 -
  13.605 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.606 -
  13.607 -    val hset_defss = map (map (Morphism.thm phi)) hset_def_frees;
  13.608 -    val hset_defss' = transpose hset_defss;
  13.609 -    val hset_namess = map (map (fst o Term.dest_Const o Morphism.term phi)) hset_frees;
  13.610 -
  13.611 -    fun mk_hset ss i j T =
  13.612 -      let
  13.613 -        val Ts = map fastype_of ss;
  13.614 -        val bTs = map domain_type Ts;
  13.615 -        val hsetT = Library.foldr (op -->) (Ts, nth bTs (i - 1) --> HOLogic.mk_setT T);
  13.616 -      in
  13.617 -        Term.list_comb (Const (nth (nth hset_namess (i - 1)) (j - 1), hsetT), ss)
  13.618 -      end;
  13.619 -
  13.620 -    val hsetssAs = map (fn i => map2 (mk_hset ss i) ls passiveAs) ks;
  13.621 -
  13.622 -    val (set_incl_hset_thmss, set_hset_incl_hset_thmsss) =
  13.623 -      let
  13.624 -        fun mk_set_incl_hset s x set hset = fold_rev Logic.all (x :: ss)
  13.625 -          (HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) (hset $ x)));
  13.626 -
  13.627 -        fun mk_set_hset_incl_hset s x y set hset1 hset2 =
  13.628 -          fold_rev Logic.all (x :: y :: ss)
  13.629 -            (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x, set $ (s $ y))),
  13.630 -            HOLogic.mk_Trueprop (mk_leq (hset1 $ x) (hset2 $ y))));
  13.631 -
  13.632 -        val set_incl_hset_goalss =
  13.633 -          map4 (fn s => fn x => fn sets => fn hsets =>
  13.634 -            map2 (mk_set_incl_hset s x) (take m sets) hsets)
  13.635 -          ss zs setssAs hsetssAs;
  13.636 -
  13.637 -        (*xk : F(i)set(m+k) (si yi) ==> F(k)_hset(j) s1 ... sn xk <= F(i)_hset(j) s1 ... sn yi*)
  13.638 -        val set_hset_incl_hset_goalsss =
  13.639 -          map4 (fn si => fn yi => fn sets => fn hsetsi =>
  13.640 -            map3 (fn xk => fn set => fn hsetsk =>
  13.641 -              map2 (mk_set_hset_incl_hset si xk yi set) hsetsk hsetsi)
  13.642 -            zs_copy (drop m sets) hsetssAs)
  13.643 -          ss zs setssAs hsetssAs;
  13.644 -      in
  13.645 -        (map3 (fn goals => fn defs => fn rec_Sucs =>
  13.646 -          map3 (fn goal => fn def => fn rec_Suc =>
  13.647 -            Goal.prove_sorry lthy [] [] goal (K (mk_set_incl_hset_tac def rec_Suc))
  13.648 -            |> Thm.close_derivation)
  13.649 -          goals defs rec_Sucs)
  13.650 -        set_incl_hset_goalss hset_defss hset_rec_Sucss,
  13.651 -        map3 (fn goalss => fn defsi => fn rec_Sucs =>
  13.652 -          map3 (fn k => fn goals => fn defsk =>
  13.653 -            map4 (fn goal => fn defk => fn defi => fn rec_Suc =>
  13.654 -              Goal.prove_sorry lthy [] [] goal
  13.655 -                (K (mk_set_hset_incl_hset_tac n [defk, defi] rec_Suc k))
  13.656 -              |> Thm.close_derivation)
  13.657 -            goals defsk defsi rec_Sucs)
  13.658 -          ks goalss hset_defss)
  13.659 -        set_hset_incl_hset_goalsss hset_defss hset_rec_Sucss)
  13.660 -      end;
  13.661 -
  13.662 -    val set_incl_hset_thmss' = transpose set_incl_hset_thmss;
  13.663 -    val set_hset_incl_hset_thmsss' = transpose (map transpose set_hset_incl_hset_thmsss);
  13.664 -    val set_hset_thmss = map (map (fn thm => thm RS @{thm set_mp})) set_incl_hset_thmss;
  13.665 -    val set_hset_hset_thmsss = map (map (map (fn thm => thm RS @{thm set_mp})))
  13.666 -      set_hset_incl_hset_thmsss;
  13.667 -    val set_hset_thmss' = transpose set_hset_thmss;
  13.668 -    val set_hset_hset_thmsss' = transpose (map transpose set_hset_hset_thmsss);
  13.669 -
  13.670 -    val hset_minimal_thms =
  13.671 -      let
  13.672 -        fun mk_passive_prem set s x K =
  13.673 -          Logic.all x (HOLogic.mk_Trueprop (mk_leq (set $ (s $ x)) (K $ x)));
  13.674 -
  13.675 -        fun mk_active_prem s x1 K1 set x2 K2 =
  13.676 -          fold_rev Logic.all [x1, x2]
  13.677 -            (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (x2, set $ (s $ x1))),
  13.678 -              HOLogic.mk_Trueprop (mk_leq (K2 $ x2) (K1 $ x1))));
  13.679 -
  13.680 -        val premss = map2 (fn j => fn Ks =>
  13.681 -          map4 mk_passive_prem (map (fn xs => nth xs (j - 1)) setssAs) ss zs Ks @
  13.682 -            flat (map4 (fn sets => fn s => fn x1 => fn K1 =>
  13.683 -              map3 (mk_active_prem s x1 K1) (drop m sets) zs_copy Ks) setssAs ss zs Ks))
  13.684 -          ls Kss;
  13.685 -
  13.686 -        val hset_rec_minimal_thms =
  13.687 -          let
  13.688 -            fun mk_conjunct j T i K x = mk_leq (mk_hset_rec ss nat i j T $ x) (K $ x);
  13.689 -            fun mk_concl j T Ks = list_all_free zs
  13.690 -              (Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs));
  13.691 -            val concls = map3 mk_concl ls passiveAs Kss;
  13.692 -
  13.693 -            val goals = map2 (fn prems => fn concl =>
  13.694 -              Logic.list_implies (prems, HOLogic.mk_Trueprop concl)) premss concls
  13.695 -
  13.696 -            val ctss =
  13.697 -              map (fn phi => map (SOME o certify lthy) [Term.absfree nat' phi, nat]) concls;
  13.698 -          in
  13.699 -            map4 (fn goal => fn cts => fn hset_rec_0s => fn hset_rec_Sucs =>
  13.700 -              singleton (Proof_Context.export names_lthy lthy)
  13.701 -                (Goal.prove_sorry lthy [] [] goal
  13.702 -                  (mk_hset_rec_minimal_tac m cts hset_rec_0s hset_rec_Sucs))
  13.703 -              |> Thm.close_derivation)
  13.704 -            goals ctss hset_rec_0ss' hset_rec_Sucss'
  13.705 -          end;
  13.706 -
  13.707 -        fun mk_conjunct j T i K x = mk_leq (mk_hset ss i j T $ x) (K $ x);
  13.708 -        fun mk_concl j T Ks = Library.foldr1 HOLogic.mk_conj (map3 (mk_conjunct j T) ks Ks zs);
  13.709 -        val concls = map3 mk_concl ls passiveAs Kss;
  13.710 -
  13.711 -        val goals = map3 (fn Ks => fn prems => fn concl =>
  13.712 -          fold_rev Logic.all (Ks @ ss @ zs)
  13.713 -            (Logic.list_implies (prems, HOLogic.mk_Trueprop concl))) Kss premss concls;
  13.714 -      in
  13.715 -        map3 (fn goal => fn hset_defs => fn hset_rec_minimal =>
  13.716 -          Goal.prove_sorry lthy [] [] goal
  13.717 -            (mk_hset_minimal_tac n hset_defs hset_rec_minimal)
  13.718 -          |> Thm.close_derivation)
  13.719 -        goals hset_defss' hset_rec_minimal_thms
  13.720 -      end;
  13.721 -
  13.722 -    val timer = time (timer "Hereditary sets");
  13.723 -
  13.724 -    (* bisimulation *)
  13.725 -
  13.726 -    val bis_bind = mk_internal_b bisN;
  13.727 -    val bis_name = Binding.name_of bis_bind;
  13.728 -    val bis_def_bind = (Thm.def_binding bis_bind, []);
  13.729 -
  13.730 -    fun mk_bis_le_conjunct R B1 B2 = mk_leq R (mk_Times (B1, B2));
  13.731 -    val bis_le = Library.foldr1 HOLogic.mk_conj (map3 mk_bis_le_conjunct Rs Bs B's)
  13.732 -
  13.733 -    val bis_spec =
  13.734 -      let
  13.735 -        val bisT = Library.foldr (op -->) (ATs @ BTs @ sTs @ B'Ts @ s'Ts @ setRTs, HOLogic.boolT);
  13.736 -
  13.737 -        val fst_args = passive_ids @ fsts;
  13.738 -        val snd_args = passive_ids @ snds;
  13.739 -        fun mk_bis R s s' b1 b2 RF map1 map2 sets =
  13.740 -          list_all_free [b1, b2] (HOLogic.mk_imp
  13.741 -            (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
  13.742 -            mk_Bex (mk_in (As @ Rs) sets (snd (dest_Free RF))) (Term.absfree (dest_Free RF)
  13.743 -              (HOLogic.mk_conj
  13.744 -                (HOLogic.mk_eq (Term.list_comb (map1, fst_args) $ RF, s $ b1),
  13.745 -                HOLogic.mk_eq (Term.list_comb (map2, snd_args) $ RF, s' $ b2))))));
  13.746 -
  13.747 -        val lhs = Term.list_comb (Free (bis_name, bisT), As @ Bs @ ss @ B's @ s's @ Rs);
  13.748 -        val rhs = HOLogic.mk_conj
  13.749 -          (bis_le, Library.foldr1 HOLogic.mk_conj
  13.750 -            (map9 mk_bis Rs ss s's zs z's RFs map_fsts map_snds bis_setss))
  13.751 -      in
  13.752 -        mk_Trueprop_eq (lhs, rhs)
  13.753 -      end;
  13.754 -
  13.755 -    val ((bis_free, (_, bis_def_free)), (lthy, lthy_old)) =
  13.756 -      lthy
  13.757 -      |> Specification.definition (SOME (bis_bind, NONE, NoSyn), (bis_def_bind, bis_spec))
  13.758 -      ||> `Local_Theory.restore;
  13.759 -
  13.760 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.761 -    val bis = fst (Term.dest_Const (Morphism.term phi bis_free));
  13.762 -    val bis_def = Morphism.thm phi bis_def_free;
  13.763 -
  13.764 -    fun mk_bis As Bs1 ss1 Bs2 ss2 Rs =
  13.765 -      let
  13.766 -        val args = As @ Bs1 @ ss1 @ Bs2 @ ss2 @ Rs;
  13.767 -        val Ts = map fastype_of args;
  13.768 -        val bisT = Library.foldr (op -->) (Ts, HOLogic.boolT);
  13.769 -      in
  13.770 -        Term.list_comb (Const (bis, bisT), args)
  13.771 -      end;
  13.772 -
  13.773 -    val bis_cong_thm =
  13.774 -      let
  13.775 -        val prems = map HOLogic.mk_Trueprop
  13.776 -         (mk_bis As Bs ss B's s's Rs :: map2 (curry HOLogic.mk_eq) Rs_copy Rs)
  13.777 -        val concl = HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs_copy);
  13.778 -      in
  13.779 -        Goal.prove_sorry lthy [] []
  13.780 -          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs @ Rs_copy)
  13.781 -            (Logic.list_implies (prems, concl)))
  13.782 -          (K ((hyp_subst_tac lthy THEN' atac) 1))
  13.783 -        |> Thm.close_derivation
  13.784 -      end;
  13.785 -
  13.786 -    val bis_rel_thm =
  13.787 -      let
  13.788 -        fun mk_conjunct R s s' b1 b2 rel =
  13.789 -          list_all_free [b1, b2] (HOLogic.mk_imp
  13.790 -            (HOLogic.mk_mem (HOLogic.mk_prod (b1, b2), R),
  13.791 -            Term.list_comb (rel, map mk_in_rel (passive_Id_ons @ Rs)) $ (s $ b1) $ (s' $ b2)));
  13.792 -
  13.793 -        val rhs = HOLogic.mk_conj
  13.794 -          (bis_le, Library.foldr1 HOLogic.mk_conj
  13.795 -            (map6 mk_conjunct Rs ss s's zs z's relsAsBs))
  13.796 -      in
  13.797 -        Goal.prove_sorry lthy [] []
  13.798 -          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
  13.799 -            (mk_Trueprop_eq (mk_bis As Bs ss B's s's Rs, rhs)))
  13.800 -          (K (mk_bis_rel_tac lthy m bis_def rel_OO_Grps map_comps map_cong0s set_mapss))
  13.801 -        |> Thm.close_derivation
  13.802 -      end;
  13.803 -
  13.804 -    val bis_converse_thm =
  13.805 -      Goal.prove_sorry lthy [] []
  13.806 -        (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ Rs)
  13.807 -          (Logic.mk_implies
  13.808 -            (HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
  13.809 -            HOLogic.mk_Trueprop (mk_bis As B's s's Bs ss (map mk_converse Rs)))))
  13.810 -        (K (mk_bis_converse_tac m bis_rel_thm rel_congs rel_converseps))
  13.811 -      |> Thm.close_derivation;
  13.812 -
  13.813 -    val bis_O_thm =
  13.814 -      let
  13.815 -        val prems =
  13.816 -          [HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's Rs),
  13.817 -           HOLogic.mk_Trueprop (mk_bis As B's s's B''s s''s R's)];
  13.818 -        val concl =
  13.819 -          HOLogic.mk_Trueprop (mk_bis As Bs ss B''s s''s (map2 (curry mk_rel_comp) Rs R's));
  13.820 -      in
  13.821 -        Goal.prove_sorry lthy [] []
  13.822 -          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ B''s @ s''s @ Rs @ R's)
  13.823 -            (Logic.list_implies (prems, concl)))
  13.824 -          (K (mk_bis_O_tac lthy m bis_rel_thm rel_congs rel_OOs))
  13.825 -        |> Thm.close_derivation
  13.826 -      end;
  13.827 -
  13.828 -    val bis_Gr_thm =
  13.829 -      let
  13.830 -        val concl =
  13.831 -          HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map2 mk_Gr Bs fs));
  13.832 -      in
  13.833 -        Goal.prove_sorry lthy [] []
  13.834 -          (fold_rev Logic.all (As @ Bs @ ss @ B's @ s's @ fs)
  13.835 -            (Logic.list_implies ([coalg_prem, mor_prem], concl)))
  13.836 -          (mk_bis_Gr_tac bis_rel_thm rel_Grps mor_image_thms morE_thms coalg_in_thms)
  13.837 -        |> Thm.close_derivation
  13.838 -      end;
  13.839 -
  13.840 -    val bis_image2_thm = bis_cong_thm OF
  13.841 -      ((bis_O_thm OF [bis_Gr_thm RS bis_converse_thm, bis_Gr_thm]) ::
  13.842 -      replicate n @{thm image2_Gr});
  13.843 -
  13.844 -    val bis_Id_on_thm = bis_cong_thm OF ((mor_id_thm RSN (2, bis_Gr_thm)) ::
  13.845 -      replicate n @{thm Id_on_Gr});
  13.846 -
  13.847 -    val bis_Union_thm =
  13.848 -      let
  13.849 -        val prem =
  13.850 -          HOLogic.mk_Trueprop (mk_Ball Idx
  13.851 -            (Term.absfree idx' (mk_bis As Bs ss B's s's (map (fn R => R $ idx) Ris))));
  13.852 -        val concl =
  13.853 -          HOLogic.mk_Trueprop (mk_bis As Bs ss B's s's (map (mk_UNION Idx) Ris));
  13.854 -      in
  13.855 -        Goal.prove_sorry lthy [] []
  13.856 -          (fold_rev Logic.all (Idx :: As @ Bs @ ss @ B's @ s's @ Ris)
  13.857 -            (Logic.mk_implies (prem, concl)))
  13.858 -          (mk_bis_Union_tac bis_def in_mono'_thms)
  13.859 -        |> Thm.close_derivation
  13.860 -      end;
  13.861 -
  13.862 -    (* self-bisimulation *)
  13.863 -
  13.864 -    fun mk_sbis As Bs ss Rs = mk_bis As Bs ss Bs ss Rs;
  13.865 -
  13.866 -    val sbis_prem = HOLogic.mk_Trueprop (mk_sbis As Bs ss sRs);
  13.867 -
  13.868 -    (* largest self-bisimulation *)
  13.869 -
  13.870 -    val lsbis_binds = mk_internal_bs lsbisN;
  13.871 -    fun lsbis_bind i = nth lsbis_binds (i - 1);
  13.872 -    val lsbis_name = Binding.name_of o lsbis_bind;
  13.873 -    val lsbis_def_bind = rpair [] o Thm.def_binding o lsbis_bind;
  13.874 -
  13.875 -    val all_sbis = HOLogic.mk_Collect (fst Rtuple', snd Rtuple', list_exists_free sRs
  13.876 -      (HOLogic.mk_conj (HOLogic.mk_eq (Rtuple, HOLogic.mk_tuple sRs), mk_sbis As Bs ss sRs)));
  13.877 -
  13.878 -    fun lsbis_spec i RT =
  13.879 -      let
  13.880 -        fun mk_lsbisT RT =
  13.881 -          Library.foldr (op -->) (map fastype_of (As @ Bs @ ss), RT);
  13.882 -        val lhs = Term.list_comb (Free (lsbis_name i, mk_lsbisT RT), As @ Bs @ ss);
  13.883 -        val rhs = mk_UNION all_sbis (Term.absfree Rtuple' (mk_nthN n Rtuple i));
  13.884 -      in
  13.885 -        mk_Trueprop_eq (lhs, rhs)
  13.886 -      end;
  13.887 -
  13.888 -    val ((lsbis_frees, (_, lsbis_def_frees)), (lthy, lthy_old)) =
  13.889 -      lthy
  13.890 -      |> fold_map2 (fn i => fn RT => Specification.definition
  13.891 -        (SOME (lsbis_bind i, NONE, NoSyn), (lsbis_def_bind i, lsbis_spec i RT))) ks setsRTs
  13.892 -      |>> apsnd split_list o split_list
  13.893 -      ||> `Local_Theory.restore;
  13.894 -
  13.895 -    val phi = Proof_Context.export_morphism lthy_old lthy;
  13.896 -
  13.897 -    val lsbis_defs = map (Morphism.thm phi) lsbis_def_frees;
  13.898 -    val lsbiss = map (fst o Term.dest_Const o Morphism.term phi) lsbis_frees;
  13.899 -
  13.900 -    fun mk_lsbis As Bs ss i =
  13.901 -      let
  13.902 -        val args = As @ Bs @ ss;
  13.903 -        val Ts = map fastype_of args;
  13.904 -        val RT = mk_relT (`I (HOLogic.dest_setT (fastype_of (nth Bs (i - 1)))));
  13.905 -        val lsbisT = Library.foldr (op -->) (Ts, RT);
  13.906 -      in
  13.907 -        Term.list_comb (Const (nth lsbiss (i - 1), lsbisT), args)
  13.908 -      end;
  13.909 -
  13.910 -    val sbis_lsbis_thm =
  13.911 -      Goal.prove_sorry lthy [] []
  13.912 -        (fold_rev Logic.all (As @ Bs @ ss)
  13.913 -          (HOLogic.mk_Trueprop (mk_sbis As Bs ss (map (mk_lsbis As Bs ss) ks))))
  13.914 -        (K (mk_sbis_lsbis_tac lthy lsbis_defs bis_Union_thm bis_cong_thm))
  13.915 -      |> Thm.close_derivation;
  13.916 -
  13.917 -    val lsbis_incl_thms = map (fn i => sbis_lsbis_thm RS
  13.918 -      (bis_def RS iffD1 RS conjunct1 RS mk_conjunctN n i)) ks;
  13.919 -    val lsbisE_thms = map (fn i => (mk_specN 2 (sbis_lsbis_thm RS
  13.920 -      (bis_def RS iffD1 RS conjunct2 RS mk_conjunctN n i))) RS mp) ks;
  13.921 -
  13.922 -    val incl_lsbis_thms =
  13.923 -      let
  13.924 -        fun mk_concl i R = HOLogic.mk_Trueprop (mk_leq R (mk_lsbis As Bs ss i));
  13.925 -        val goals = map2 (fn i => fn R => fold_rev Logic.all (As @ Bs @ ss @ sRs)
  13.926 -          (Logic.mk_implies (sbis_prem, mk_concl i R))) ks sRs;
  13.927 -      in
  13.928 -        map3 (fn goal => fn i => fn def => Goal.prove_sorry lthy [] [] goal
  13.929 -          (K (mk_incl_lsbis_tac n i def)) |> Thm.close_derivation) goals ks lsbis_defs
  13.930 -      end;
  13.931 -
  13.932 -    val equiv_lsbis_thms =
  13.933 -      let
  13.934 -        fun mk_concl i B = HOLogic.mk_Trueprop (mk_equiv B (mk_lsbis As Bs ss i));
  13.935 -        val goals = map2 (fn i => fn B => fold_rev Logic.all (As @ Bs @ ss)
  13.936 -          (Logic.mk_implies (coalg_prem, mk_concl i B))) ks Bs;
  13.937 -      in
  13.938 -        map3 (fn goal => fn l_incl => fn incl_l =>
  13.939 -          Goal.prove_sorry lthy [] [] goal
  13.940 -            (K (mk_equiv_lsbis_tac sbis_lsbis_thm l_incl incl_l
  13.941 -              bis_Id_on_thm bis_converse_thm bis_O_thm))
  13.942 -          |> Thm.close_derivation)
  13.943 -        goals lsbis_incl_thms incl_lsbis_thms
  13.944 -      end;
  13.945 -
  13.946 -    val timer = time (timer "Bisimulations");
  13.947 -
  13.948 -    (* bounds *)
  13.949 -
  13.950 -    val (lthy, sbd, sbdT,
  13.951 -      sbd_card_order, sbd_Cinfinite, sbd_Card_order, set_sbdss) =
  13.952 -      if n = 1
  13.953 -      then (lthy, sum_bd, sum_bdT, bd_card_order, bd_Cinfinite, bd_Card_order, set_bdss)
  13.954 -      else
  13.955 -        let
  13.956 -          val sbdT_bind = mk_internal_b sum_bdTN;
  13.957 -
  13.958 -          val ((sbdT_name, (sbdT_glob_info, sbdT_loc_info)), lthy) =
  13.959 -            typedef (sbdT_bind, dead_params, NoSyn)
  13.960 -              (HOLogic.mk_UNIV sum_bdT) NONE (EVERY' [rtac exI, rtac UNIV_I] 1) lthy;
  13.961 -
  13.962 -          val sbdT = Type (sbdT_name, dead_params');
  13.963 -          val Abs_sbdT = Const (#Abs_name sbdT_glob_info, sum_bdT --> sbdT);
  13.964 -
  13.965 -          val sbd_bind = mk_internal_b sum_bdN;
  13.966 -          val sbd_name = Binding.name_of sbd_bind;
  13.967 -          val sbd_def_bind = (Thm.def_binding sbd_bind, []);
  13.968 -
  13.969 -          val sbd_spec = HOLogic.mk_Trueprop
  13.970 -            (HOLogic.mk_eq (Free (sbd_name, mk_relT (`I sbdT)), mk_dir_image sum_bd Abs_sbdT));
  13.971 -
  13.972 -          val ((sbd_free, (_, sbd_def_free)), (lthy, lthy_old)) =
  13.973 -            lthy
  13.974 -            |> Specification.definition (SOME (sbd_bind, NONE, NoSyn), (sbd_def_bind, sbd_spec))
  13.975 -            ||> `Local_Theory.restore;
  13.976 -
  13.977 -          val phi = Proof_Context.export_morphism lthy_old lthy;
  13.978 -
  13.979 -          val sbd_def = Morphism.thm phi sbd_def_free;
  13.980 -          val sbd = Const (fst (Term.dest_Const (Morphism.term phi sbd_free)), mk_relT (`I sbdT));
  13.981 -
  13.982 -          val Abs_sbdT_inj = mk_Abs_inj_thm (#Abs_inject sbdT_loc_info);
  13.983 -          val Abs_sbdT_bij = mk_Abs_bij_thm lthy Abs_sbdT_inj (#Abs_cases sbdT_loc_info);
  13.984 -
  13.985 -          fun mk_sum_Cinfinite [thm] = thm
  13.986 -            | mk_sum_Cinfinite (thm :: thms) =
  13.987 -              @{thm Cinfinite_csum_strong} OF [thm, mk_sum_Cinfinite thms];
  13.988 -
  13.989 -          val sum_Cinfinite = mk_sum_Cinfinite bd_Cinfinites;
  13.990 -          val sum_Card_order = sum_Cinfinite RS conjunct2;
  13.991 -
  13.992 -          fun mk_sum_card_order [thm] = thm
  13.993 -            | mk_sum_card_order (thm :: thms) =
  13.994 -              @{thm card_order_csum} OF [thm, mk_sum_card_order thms];
  13.995 -
  13.996 -          val sum_card_order = mk_sum_card_order bd_card_orders;
  13.997 -
  13.998 -          val sbd_ordIso = fold_thms lthy [sbd_def]
  13.999 -            (@{thm dir_image} OF [Abs_sbdT_inj, sum_Card_order]);
 13.1000 -          val sbd_card_order =  fold_thms lthy [sbd_def]
 13.1001 -            (@{thm card_order_dir_image} OF [Abs_sbdT_bij, sum_card_order]);
 13.1002 -          val sbd_Cinfinite = @{thm Cinfinite_cong} OF [sbd_ordIso, sum_Cinfinite];
 13.1003 -          val sbd_Card_order = sbd_Cinfinite RS conjunct2;
 13.1004 -
 13.1005 -          fun mk_set_sbd i bd_Card_order bds =
 13.1006 -            map (fn thm => @{thm ordLeq_ordIso_trans} OF
 13.1007 -              [bd_Card_order RS mk_ordLeq_csum n i thm, sbd_ordIso]) bds;
 13.1008 -          val set_sbdss = map3 mk_set_sbd ks bd_Card_orders set_bdss;
 13.1009 -       in
 13.1010 -         (lthy, sbd, sbdT, sbd_card_order, sbd_Cinfinite, sbd_Card_order, set_sbdss)
 13.1011 -       end;
 13.1012 -
 13.1013 -    val sbdTs = replicate n sbdT;
 13.1014 -    val sum_sbd = Library.foldr1 (uncurry mk_csum) (replicate n sbd);
 13.1015 -    val sum_sbdT = mk_sumTN sbdTs;
 13.1016 -    val sum_sbd_listT = HOLogic.listT sum_sbdT;
 13.1017 -    val sum_sbd_list_setT = HOLogic.mk_setT sum_sbd_listT;
 13.1018 -    val bdTs = passiveAs @ replicate n sbdT;
 13.1019 -    val to_sbd_maps = map4 mk_map_of_bnf Dss Ass (replicate n bdTs) bnfs;
 13.1020 -    val bdFTs = mk_FTs bdTs;
 13.1021 -    val sbdFT = mk_sumTN bdFTs;
 13.1022 -    val treeT = HOLogic.mk_prodT (sum_sbd_list_setT, sum_sbd_listT --> sbdFT);
 13.1023 -    val treeQT = HOLogic.mk_setT treeT;
 13.1024 -    val treeTs = passiveAs @ replicate n treeT;
 13.1025 -    val treeQTs = passiveAs @ replicate n treeQT;
 13.1026 -    val treeFTs = mk_FTs treeTs;
 13.1027 -    val tree_maps = map4 mk_map_of_bnf Dss (replicate n bdTs) (replicate n treeTs) bnfs;
 13.1028 -    val final_maps = map4 mk_map_of_bnf Dss (replicate n treeTs) (replicate n treeQTs) bnfs;
 13.1029 -    val isNode_setss = mk_setss (passiveAs @ replicate n sbdT);
 13.1030 -
 13.1031 -    val root = HOLogic.mk_set sum_sbd_listT [HOLogic.mk_list sum_sbdT []];
 13.1032 -    val Zero = HOLogic.mk_tuple (map (fn U => absdummy U root) activeAs);
 13.1033 -    val Lev_recT = fastype_of Zero;
 13.1034 -    val LevT = Library.foldr (op -->) (sTs, HOLogic.natT --> Lev_recT);
 13.1035 -
 13.1036 -    val Nil = HOLogic.mk_tuple (map3 (fn i => fn z => fn z'=>
 13.1037 -      Term.absfree z' (mk_InN activeAs z i)) ks zs zs');
 13.1038 -    val rv_recT = fastype_of Nil;
 13.1039 -    val rvT = Library.foldr (op -->) (sTs, sum_sbd_listT --> rv_recT);
 13.1040 -
 13.1041 -    val (((((((((((sumx, sumx'), (kks, kks')), (kl, kl')), (kl_copy, kl'_copy)), (Kl, Kl')),
 13.1042 -      (lab, lab')), (Kl_lab, Kl_lab')), xs), (Lev_rec, Lev_rec')), (rv_rec, rv_rec')),
 13.1043 -      names_lthy) = names_lthy
 13.1044 -      |> yield_singleton (apfst (op ~~) oo mk_Frees' "sumx") sum_sbdT
 13.1045 -      ||>> mk_Frees' "k" sbdTs
 13.1046 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
 13.1047 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "kl") sum_sbd_listT
 13.1048 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl") sum_sbd_list_setT
 13.1049 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "lab") (sum_sbd_listT --> sbdFT)
 13.1050 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "Kl_lab") treeT
 13.1051 -      ||>> mk_Frees "x" bdFTs
 13.1052 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") Lev_recT
 13.1053 -      ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "rec") rv_recT;
 13.1054 -
 13.1055 -    val (k, k') = (hd kks, hd kks')
 13.1056 -
 13.1057 -    val timer = time (timer "Bounds");
 13.1058 -
 13.1059 -    (* tree coalgebra *)
 13.1060 -
 13.1061 -    val isNode_binds = mk_internal_bs isNodeN;
 13.1062 -    fun isNode_bind i = nth isNode_binds (i - 1);
 13.1063 -    val isNode_name = Binding.name_of o isNode_bind;
 13.1064 -    val isNode_def_bind = rpair [] o Thm.def_binding o isNode_bind;
 13.1065 -
 13.1066 -    val isNodeT =
 13.1067 -      Library.foldr (op -->) (map fastype_of (As @ [Kl, lab, kl]), HOLogic.boolT);
 13.1068 -
 13.1069 -    val Succs = map3 (fn i => fn k => fn k' =>
 13.1070 -      HOLogic.mk_Collect (fst k', snd k', HOLogic.mk_mem (mk_InN sbdTs k i, mk_Succ Kl kl)))
 13.1071 -      ks kks kks';
 13.1072 -
 13.1073 -    fun isNode_spec sets x i =
 13.1074 -      let
 13.1075 -        val (passive_sets, active_sets) = chop m (map (fn set => set $ x) sets);
 13.1076 -        val lhs = Term.list_comb (Free (isNode_name i, isNodeT), As @ [Kl, lab, kl]);
 13.1077 -        val rhs = list_exists_free [x]
 13.1078 -          (Library.foldr1 HOLogic.mk_conj (HOLogic.mk_eq (lab $ kl, mk_InN bdFTs x i) ::
 13.1079 -          map2 mk_leq passive_sets As @ map2 (curry HOLogic.mk_eq) active_sets Succs));
 13.1080 -      in
 13.1081 -        mk_Trueprop_eq (lhs, rhs)
 13.1082 -      end;
 13.1083 -
 13.1084 -    val ((isNode_frees, (_, isNode_def_frees)), (lthy, lthy_old)) =
 13.1085 -      lthy
 13.1086 -      |> fold_map3 (fn i => fn x => fn sets => Specification.definition
 13.1087 -        (SOME (isNode_bind i, NONE, NoSyn), (isNode_def_bind i, isNode_spec sets x i)))
 13.1088 -        ks xs isNode_setss
 13.1089 -      |>> apsnd split_list o split_list
 13.1090 -      ||> `Local_Theory.restore;
 13.1091 -
 13.1092 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1093 -
 13.1094 -    val isNode_defs = map (Morphism.thm phi) isNode_def_frees;
 13.1095 -    val isNodes = map (fst o Term.dest_Const o Morphism.term phi) isNode_frees;
 13.1096 -
 13.1097 -    fun mk_isNode As kl i =
 13.1098 -      Term.list_comb (Const (nth isNodes (i - 1), isNodeT), As @ [Kl, lab, kl]);
 13.1099 -
 13.1100 -    val isTree =
 13.1101 -      let
 13.1102 -        val empty = HOLogic.mk_mem (HOLogic.mk_list sum_sbdT [], Kl);
 13.1103 -        val Field = mk_leq Kl (mk_Field (mk_clists sum_sbd));
 13.1104 -        val prefCl = mk_prefCl Kl;
 13.1105 -
 13.1106 -        val tree = mk_Ball Kl (Term.absfree kl'
 13.1107 -          (HOLogic.mk_conj
 13.1108 -            (Library.foldr1 HOLogic.mk_disj (map (mk_isNode As kl) ks),
 13.1109 -            Library.foldr1 HOLogic.mk_conj (map4 (fn Succ => fn i => fn k => fn k' =>
 13.1110 -              mk_Ball Succ (Term.absfree k' (mk_isNode As
 13.1111 -                (mk_append (kl, HOLogic.mk_list sum_sbdT [mk_InN sbdTs k i])) i)))
 13.1112 -            Succs ks kks kks'))));
 13.1113 -
 13.1114 -        val undef = list_all_free [kl] (HOLogic.mk_imp
 13.1115 -          (HOLogic.mk_not (HOLogic.mk_mem (kl, Kl)),
 13.1116 -          HOLogic.mk_eq (lab $ kl, mk_undefined sbdFT)));
 13.1117 -      in
 13.1118 -        Library.foldr1 HOLogic.mk_conj [empty, Field, prefCl, tree, undef]
 13.1119 -      end;
 13.1120 -
 13.1121 -    val carT_binds = mk_internal_bs carTN;
 13.1122 -    fun carT_bind i = nth carT_binds (i - 1);
 13.1123 -    val carT_name = Binding.name_of o carT_bind;
 13.1124 -    val carT_def_bind = rpair [] o Thm.def_binding o carT_bind;
 13.1125 -
 13.1126 -    fun carT_spec i =
 13.1127 -      let
 13.1128 -        val carTT = Library.foldr (op -->) (ATs, HOLogic.mk_setT treeT);
 13.1129 -
 13.1130 -        val lhs = Term.list_comb (Free (carT_name i, carTT), As);
 13.1131 -        val rhs = HOLogic.mk_Collect (fst Kl_lab', snd Kl_lab', list_exists_free [Kl, lab]
 13.1132 -          (HOLogic.mk_conj (HOLogic.mk_eq (Kl_lab, HOLogic.mk_prod (Kl, lab)),
 13.1133 -            HOLogic.mk_conj (isTree, mk_isNode As (HOLogic.mk_list sum_sbdT []) i))));
 13.1134 -      in
 13.1135 -        mk_Trueprop_eq (lhs, rhs)
 13.1136 -      end;
 13.1137 -
 13.1138 -    val ((carT_frees, (_, carT_def_frees)), (lthy, lthy_old)) =
 13.1139 -      lthy
 13.1140 -      |> fold_map (fn i => Specification.definition
 13.1141 -        (SOME (carT_bind i, NONE, NoSyn), (carT_def_bind i, carT_spec i))) ks
 13.1142 -      |>> apsnd split_list o split_list
 13.1143 -      ||> `Local_Theory.restore;
 13.1144 -
 13.1145 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1146 -
 13.1147 -    val carT_defs = map (Morphism.thm phi) carT_def_frees;
 13.1148 -    val carTs = map (fst o Term.dest_Const o Morphism.term phi) carT_frees;
 13.1149 -
 13.1150 -    fun mk_carT As i = Term.list_comb
 13.1151 -      (Const (nth carTs (i - 1),
 13.1152 -         Library.foldr (op -->) (map fastype_of As, HOLogic.mk_setT treeT)), As);
 13.1153 -
 13.1154 -    val strT_binds = mk_internal_bs strTN;
 13.1155 -    fun strT_bind i = nth strT_binds (i - 1);
 13.1156 -    val strT_name = Binding.name_of o strT_bind;
 13.1157 -    val strT_def_bind = rpair [] o Thm.def_binding o strT_bind;
 13.1158 -
 13.1159 -    fun strT_spec mapFT FT i =
 13.1160 -      let
 13.1161 -        val strTT = treeT --> FT;
 13.1162 -
 13.1163 -        fun mk_f i k k' =
 13.1164 -          let val in_k = mk_InN sbdTs k i;
 13.1165 -          in Term.absfree k' (HOLogic.mk_prod (mk_Shift Kl in_k, mk_shift lab in_k)) end;
 13.1166 -
 13.1167 -        val f = Term.list_comb (mapFT, passive_ids @ map3 mk_f ks kks kks');
 13.1168 -        val (fTs1, fTs2) = apsnd tl (chop (i - 1) (map (fn T => T --> FT) bdFTs));
 13.1169 -        val fs = map mk_undefined fTs1 @ (f :: map mk_undefined fTs2);
 13.1170 -        val lhs = Free (strT_name i, strTT);
 13.1171 -        val rhs = HOLogic.mk_split (Term.absfree Kl' (Term.absfree lab'
 13.1172 -          (mk_sum_caseN fs $ (lab $ HOLogic.mk_list sum_sbdT []))));
 13.1173 -      in
 13.1174 -        mk_Trueprop_eq (lhs, rhs)
 13.1175 -      end;
 13.1176 -
 13.1177 -    val ((strT_frees, (_, strT_def_frees)), (lthy, lthy_old)) =
 13.1178 -      lthy
 13.1179 -      |> fold_map3 (fn i => fn mapFT => fn FT => Specification.definition
 13.1180 -        (SOME (strT_bind i, NONE, NoSyn), (strT_def_bind i, strT_spec mapFT FT i)))
 13.1181 -        ks tree_maps treeFTs
 13.1182 -      |>> apsnd split_list o split_list
 13.1183 -      ||> `Local_Theory.restore;
 13.1184 -
 13.1185 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1186 -
 13.1187 -    val strT_defs = map ((fn def => trans OF [def RS fun_cong, @{thm prod.cases}]) o
 13.1188 -      Morphism.thm phi) strT_def_frees;
 13.1189 -    val strTs = map (fst o Term.dest_Const o Morphism.term phi) strT_frees;
 13.1190 -
 13.1191 -    fun mk_strT FT i = Const (nth strTs (i - 1), treeT --> FT);
 13.1192 -
 13.1193 -    val carTAs = map (mk_carT As) ks;
 13.1194 -    val strTAs = map2 mk_strT treeFTs ks;
 13.1195 -
 13.1196 -    val coalgT_thm =
 13.1197 -      Goal.prove_sorry lthy [] []
 13.1198 -        (fold_rev Logic.all As (HOLogic.mk_Trueprop (mk_coalg As carTAs strTAs)))
 13.1199 -        (mk_coalgT_tac m (coalg_def :: isNode_defs @ carT_defs) strT_defs set_mapss)
 13.1200 -      |> Thm.close_derivation;
 13.1201 -
 13.1202 -    val timer = time (timer "Tree coalgebra");
 13.1203 -
 13.1204 -    fun mk_to_sbd s x i i' =
 13.1205 -      mk_toCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
 13.1206 -    fun mk_from_sbd s x i i' =
 13.1207 -      mk_fromCard (nth (nth setssAs (i - 1)) (m + i' - 1) $ (s $ x)) sbd;
 13.1208 -
 13.1209 -    fun mk_to_sbd_thmss thm = map (map (fn set_sbd =>
 13.1210 -      thm OF [set_sbd, sbd_Card_order]) o drop m) set_sbdss;
 13.1211 -
 13.1212 -    val to_sbd_inj_thmss = mk_to_sbd_thmss @{thm toCard_inj};
 13.1213 -    val to_sbd_thmss = mk_to_sbd_thmss @{thm toCard};
 13.1214 -    val from_to_sbd_thmss = mk_to_sbd_thmss @{thm fromCard_toCard};
 13.1215 -
 13.1216 -    val Lev_bind = mk_internal_b LevN;
 13.1217 -    val Lev_name = Binding.name_of Lev_bind;
 13.1218 -    val Lev_def_bind = rpair [] (Thm.def_binding Lev_bind);
 13.1219 -
 13.1220 -    val Lev_spec =
 13.1221 -      let
 13.1222 -        fun mk_Suc i s setsAs a a' =
 13.1223 -          let
 13.1224 -            val sets = drop m setsAs;
 13.1225 -            fun mk_set i' set b =
 13.1226 -              let
 13.1227 -                val Cons = HOLogic.mk_eq (kl_copy,
 13.1228 -                  mk_Cons (mk_InN sbdTs (mk_to_sbd s a i i' $ b) i') kl)
 13.1229 -                val b_set = HOLogic.mk_mem (b, set $ (s $ a));
 13.1230 -                val kl_rec = HOLogic.mk_mem (kl, mk_nthN n Lev_rec i' $ b);
 13.1231 -              in
 13.1232 -                HOLogic.mk_Collect (fst kl'_copy, snd kl'_copy, list_exists_free [b, kl]
 13.1233 -                  (HOLogic.mk_conj (Cons, HOLogic.mk_conj (b_set, kl_rec))))
 13.1234 -              end;
 13.1235 -          in
 13.1236 -            Term.absfree a' (Library.foldl1 mk_union (map3 mk_set ks sets zs_copy))
 13.1237 -          end;
 13.1238 -
 13.1239 -        val Suc = Term.absdummy HOLogic.natT (Term.absfree Lev_rec'
 13.1240 -          (HOLogic.mk_tuple (map5 mk_Suc ks ss setssAs zs zs')));
 13.1241 -
 13.1242 -        val lhs = Term.list_comb (Free (Lev_name, LevT), ss);
 13.1243 -        val rhs = mk_nat_rec Zero Suc;
 13.1244 -      in
 13.1245 -        mk_Trueprop_eq (lhs, rhs)
 13.1246 -      end;
 13.1247 -
 13.1248 -    val ((Lev_free, (_, Lev_def_free)), (lthy, lthy_old)) =
 13.1249 -      lthy
 13.1250 -      |> Specification.definition (SOME (Lev_bind, NONE, NoSyn), (Lev_def_bind, Lev_spec))
 13.1251 -      ||> `Local_Theory.restore;
 13.1252 -
 13.1253 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1254 -
 13.1255 -    val Lev_def = Morphism.thm phi Lev_def_free;
 13.1256 -    val Lev = fst (Term.dest_Const (Morphism.term phi Lev_free));
 13.1257 -
 13.1258 -    fun mk_Lev ss nat i =
 13.1259 -      let
 13.1260 -        val Ts = map fastype_of ss;
 13.1261 -        val LevT = Library.foldr (op -->) (Ts, HOLogic.natT -->
 13.1262 -          HOLogic.mk_tupleT (map (fn U => domain_type U --> sum_sbd_list_setT) Ts));
 13.1263 -      in
 13.1264 -        mk_nthN n (Term.list_comb (Const (Lev, LevT), ss) $ nat) i
 13.1265 -      end;
 13.1266 -
 13.1267 -    val Lev_0s = flat (mk_rec_simps n @{thm nat_rec_0} [Lev_def]);
 13.1268 -    val Lev_Sucs = flat (mk_rec_simps n @{thm nat_rec_Suc} [Lev_def]);
 13.1269 -
 13.1270 -    val rv_bind = mk_internal_b rvN;
 13.1271 -    val rv_name = Binding.name_of rv_bind;
 13.1272 -    val rv_def_bind = rpair [] (Thm.def_binding rv_bind);
 13.1273 -
 13.1274 -    val rv_spec =
 13.1275 -      let
 13.1276 -        fun mk_Cons i s b b' =
 13.1277 -          let
 13.1278 -            fun mk_case i' =
 13.1279 -              Term.absfree k' (mk_nthN n rv_rec i' $ (mk_from_sbd s b i i' $ k));
 13.1280 -          in
 13.1281 -            Term.absfree b' (mk_sum_caseN (map mk_case ks) $ sumx)
 13.1282 -          end;
 13.1283 -
 13.1284 -        val Cons = Term.absfree sumx' (Term.absdummy sum_sbd_listT (Term.absfree rv_rec'
 13.1285 -          (HOLogic.mk_tuple (map4 mk_Cons ks ss zs zs'))));
 13.1286 -
 13.1287 -        val lhs = Term.list_comb (Free (rv_name, rvT), ss);
 13.1288 -        val rhs = mk_list_rec Nil Cons;
 13.1289 -      in
 13.1290 -        mk_Trueprop_eq (lhs, rhs)
 13.1291 -      end;
 13.1292 -
 13.1293 -    val ((rv_free, (_, rv_def_free)), (lthy, lthy_old)) =
 13.1294 -      lthy
 13.1295 -      |> Specification.definition (SOME (rv_bind, NONE, NoSyn), (rv_def_bind, rv_spec))
 13.1296 -      ||> `Local_Theory.restore;
 13.1297 -
 13.1298 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1299 -
 13.1300 -    val rv_def = Morphism.thm phi rv_def_free;
 13.1301 -    val rv = fst (Term.dest_Const (Morphism.term phi rv_free));
 13.1302 -
 13.1303 -    fun mk_rv ss kl i =
 13.1304 -      let
 13.1305 -        val Ts = map fastype_of ss;
 13.1306 -        val As = map domain_type Ts;
 13.1307 -        val rvT = Library.foldr (op -->) (Ts, fastype_of kl -->
 13.1308 -          HOLogic.mk_tupleT (map (fn U => U --> mk_sumTN As) As));
 13.1309 -      in
 13.1310 -        mk_nthN n (Term.list_comb (Const (rv, rvT), ss) $ kl) i
 13.1311 -      end;
 13.1312 -
 13.1313 -    val rv_Nils = flat (mk_rec_simps n @{thm list_rec_Nil} [rv_def]);
 13.1314 -    val rv_Conss = flat (mk_rec_simps n @{thm list_rec_Cons} [rv_def]);
 13.1315 -
 13.1316 -    val beh_binds = mk_internal_bs behN;
 13.1317 -    fun beh_bind i = nth beh_binds (i - 1);
 13.1318 -    val beh_name = Binding.name_of o beh_bind;
 13.1319 -    val beh_def_bind = rpair [] o Thm.def_binding o beh_bind;
 13.1320 -
 13.1321 -    fun beh_spec i z =
 13.1322 -      let
 13.1323 -        val mk_behT = Library.foldr (op -->) (map fastype_of (ss @ [z]), treeT);
 13.1324 -
 13.1325 -        fun mk_case i to_sbd_map s k k' =
 13.1326 -          Term.absfree k' (mk_InN bdFTs
 13.1327 -            (Term.list_comb (to_sbd_map, passive_ids @ map (mk_to_sbd s k i) ks) $ (s $ k)) i);
 13.1328 -
 13.1329 -        val Lab = Term.absfree kl' (mk_If
 13.1330 -          (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))
 13.1331 -          (mk_sum_caseN (map5 mk_case ks to_sbd_maps ss zs zs') $ (mk_rv ss kl i $ z))
 13.1332 -          (mk_undefined sbdFT));
 13.1333 -
 13.1334 -        val lhs = Term.list_comb (Free (beh_name i, mk_behT), ss) $ z;
 13.1335 -        val rhs = HOLogic.mk_prod (mk_UNION (HOLogic.mk_UNIV HOLogic.natT)
 13.1336 -          (Term.absfree nat' (mk_Lev ss nat i $ z)), Lab);
 13.1337 -      in
 13.1338 -        mk_Trueprop_eq (lhs, rhs)
 13.1339 -      end;
 13.1340 -
 13.1341 -    val ((beh_frees, (_, beh_def_frees)), (lthy, lthy_old)) =
 13.1342 -      lthy
 13.1343 -      |> fold_map2 (fn i => fn z => Specification.definition
 13.1344 -        (SOME (beh_bind i, NONE, NoSyn), (beh_def_bind i, beh_spec i z))) ks zs
 13.1345 -      |>> apsnd split_list o split_list
 13.1346 -      ||> `Local_Theory.restore;
 13.1347 -
 13.1348 -    val phi = Proof_Context.export_morphism lthy_old lthy;
 13.1349 -
 13.1350 -    val beh_defs = map (Morphism.thm phi) beh_def_frees;
 13.1351 -    val behs = map (fst o Term.dest_Const o Morphism.term phi) beh_frees;
 13.1352 -
 13.1353 -    fun mk_beh ss i =
 13.1354 -      let
 13.1355 -        val Ts = map fastype_of ss;
 13.1356 -        val behT = Library.foldr (op -->) (Ts, nth activeAs (i - 1) --> treeT);
 13.1357 -      in
 13.1358 -        Term.list_comb (Const (nth behs (i - 1), behT), ss)
 13.1359 -      end;
 13.1360 -
 13.1361 -    val Lev_sbd_thms =
 13.1362 -      let
 13.1363 -        fun mk_conjunct i z = mk_leq (mk_Lev ss nat i $ z) (mk_Field (mk_clists sum_sbd));
 13.1364 -        val goal = list_all_free zs
 13.1365 -          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
 13.1366 -
 13.1367 -        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
 13.1368 -
 13.1369 -        val Lev_sbd = singleton (Proof_Context.export names_lthy lthy)
 13.1370 -          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
 13.1371 -            (K (mk_Lev_sbd_tac lthy cts Lev_0s Lev_Sucs to_sbd_thmss))
 13.1372 -          |> Thm.close_derivation);
 13.1373 -
 13.1374 -        val Lev_sbd' = mk_specN n Lev_sbd;
 13.1375 -      in
 13.1376 -        map (fn i => Lev_sbd' RS mk_conjunctN n i) ks
 13.1377 -      end;
 13.1378 -
 13.1379 -    val (length_Lev_thms, length_Lev'_thms) =
 13.1380 -      let
 13.1381 -        fun mk_conjunct i z = HOLogic.mk_imp (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z),
 13.1382 -          HOLogic.mk_eq (mk_size kl, nat));
 13.1383 -        val goal = list_all_free (kl :: zs)
 13.1384 -          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
 13.1385 -
 13.1386 -        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
 13.1387 -
 13.1388 -        val length_Lev = singleton (Proof_Context.export names_lthy lthy)
 13.1389 -          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)
 13.1390 -            (K (mk_length_Lev_tac lthy cts Lev_0s Lev_Sucs))
 13.1391 -          |> Thm.close_derivation);
 13.1392 -
 13.1393 -        val length_Lev' = mk_specN (n + 1) length_Lev;
 13.1394 -        val length_Levs = map (fn i => length_Lev' RS mk_conjunctN n i RS mp) ks;
 13.1395 -
 13.1396 -        fun mk_goal i z = fold_rev Logic.all (z :: kl :: nat :: ss) (Logic.mk_implies
 13.1397 -            (HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z)),
 13.1398 -            HOLogic.mk_Trueprop (HOLogic.mk_mem (kl, mk_Lev ss (mk_size kl) i $ z))));
 13.1399 -        val goals = map2 mk_goal ks zs;
 13.1400 -
 13.1401 -        val length_Levs' = map2 (fn goal => fn length_Lev =>
 13.1402 -          Goal.prove_sorry lthy [] [] goal (K (mk_length_Lev'_tac length_Lev))
 13.1403 -          |> Thm.close_derivation) goals length_Levs;
 13.1404 -      in
 13.1405 -        (length_Levs, length_Levs')
 13.1406 -      end;
 13.1407 -
 13.1408 -    val prefCl_Lev_thms =
 13.1409 -      let
 13.1410 -        fun mk_conjunct i z = HOLogic.mk_imp
 13.1411 -          (HOLogic.mk_conj (HOLogic.mk_mem (kl, mk_Lev ss nat i $ z), mk_prefixeq kl_copy kl),
 13.1412 -          HOLogic.mk_mem (kl_copy, mk_Lev ss (mk_size kl_copy) i $ z));
 13.1413 -        val goal = list_all_free (kl :: kl_copy :: zs)
 13.1414 -          (Library.foldr1 HOLogic.mk_conj (map2 mk_conjunct ks zs));
 13.1415 -
 13.1416 -        val cts = map (SOME o certify lthy) [Term.absfree nat' goal, nat];
 13.1417 -
 13.1418 -        val prefCl_Lev = singleton (Proof_Context.export names_lthy lthy)
 13.1419 -          (Goal.prove_sorry lthy [] [] (HOLogic.mk_Trueprop goal)