src/HOL/Tools/BNF/bnf_comp.ML
changeset 55197 5a54ed681ba2
parent 55067 a452de24a877
child 55480 59cc4a8bc28a
equal deleted inserted replaced
55196:a823137bcd87 55197:5a54ed681ba2
   196             @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
   196             @{thm comp_single_set_bd} OF [nth inner_bd_Card_orders j, nth (nth inner_set_bdss j) i,
   197               nth outer_set_bds j]
   197               nth outer_set_bds j]
   198           val single_set_bd_thmss =
   198           val single_set_bd_thmss =
   199             map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
   199             map ((fn f => map f (0 upto olive - 1)) o single_set_bd_thm) (0 upto ilive - 1);
   200         in
   200         in
   201           map2 (fn set_alt => fn single_set_bds => fn {context = ctxt, prems = _} =>
   201           map2 (fn set_alt => fn single_set_bds => fn ctxt =>
   202             mk_comp_set_bd_tac ctxt set_alt single_set_bds)
   202             mk_comp_set_bd_tac ctxt set_alt single_set_bds)
   203           set_alt_thms single_set_bd_thmss
   203           set_alt_thms single_set_bd_thmss
   204         end;
   204         end;
   205 
   205 
   206     val in_alt_thm =
   206     val in_alt_thm =
   249       |> flat
   249       |> flat
   250       |> map (`(fn t => Term.add_frees t []))
   250       |> map (`(fn t => Term.add_frees t []))
   251       |> minimize_wits
   251       |> minimize_wits
   252       |> map (fn (frees, t) => fold absfree frees t);
   252       |> map (fn (frees, t) => fold absfree frees t);
   253 
   253 
   254     fun wit_tac {context = ctxt, prems = _} =
   254     fun wit_tac ctxt =
   255       mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_map_of_bnf outer)
   255       mk_comp_wit_tac ctxt (wit_thms_of_bnf outer) (collect_set_map_of_bnf outer)
   256         (maps wit_thms_of_bnf inners);
   256         (maps wit_thms_of_bnf inners);
   257 
   257 
   258     val (bnf', lthy') =
   258     val (bnf', lthy') =
   259       bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
   259       bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
   299     val bnf_bd = mk_bd_of_bnf Ds As bnf;
   299     val bnf_bd = mk_bd_of_bnf Ds As bnf;
   300     val bd = mk_cprod
   300     val bd = mk_cprod
   301       (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
   301       (Library.foldr1 (uncurry mk_csum) (map (mk_card_of o HOLogic.mk_UNIV) killedAs)) bnf_bd;
   302 
   302 
   303     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   303     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   304     fun map_comp0_tac {context = ctxt, prems = _} =
   304     fun map_comp0_tac ctxt =
   305       unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) ::
   305       unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) ::
   306         @{thms comp_assoc id_comp comp_id}) THEN rtac refl 1;
   306         @{thms comp_assoc id_comp comp_id}) THEN rtac refl 1;
   307     fun map_cong0_tac {context = ctxt, prems = _} =
   307     fun map_cong0_tac ctxt =
   308       mk_kill_map_cong0_tac ctxt n (live - n) (map_cong0_of_bnf bnf);
   308       mk_kill_map_cong0_tac ctxt n (live - n) (map_cong0_of_bnf bnf);
   309     val set_map0_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_map0_of_bnf bnf));
   309     val set_map0_tacs = map (fn thm => fn _ => rtac thm 1) (drop n (set_map0_of_bnf bnf));
   310     fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
   310     fun bd_card_order_tac _ = mk_kill_bd_card_order_tac n (bd_card_order_of_bnf bnf);
   311     fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
   311     fun bd_cinfinite_tac _ = mk_kill_bd_cinfinite_tac (bd_Cinfinite_of_bnf bnf);
   312     val set_bd_tacs =
   312     val set_bd_tacs =
   320         val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   320         val goal = fold_rev Logic.all Asets (mk_Trueprop_eq (inx, in_alt));
   321       in
   321       in
   322         Goal.prove_sorry lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
   322         Goal.prove_sorry lthy [] [] goal (K kill_in_alt_tac) |> Thm.close_derivation
   323       end;
   323       end;
   324 
   324 
   325     fun le_rel_OO_tac {context = ctxt, prems = _} =
   325     fun le_rel_OO_tac ctxt =
   326       EVERY' [rtac @{thm ord_le_eq_trans}, rtac (le_rel_OO_of_bnf bnf)] 1 THEN
   326       EVERY' [rtac @{thm ord_le_eq_trans}, rtac (le_rel_OO_of_bnf bnf)] 1 THEN
   327       unfold_thms_tac ctxt @{thms eq_OO} THEN rtac refl 1;
   327       unfold_thms_tac ctxt @{thms eq_OO} THEN rtac refl 1;
   328 
   328 
   329     fun rel_OO_Grp_tac _ =
   329     fun rel_OO_Grp_tac _ =
   330       let
   330       let
   391     val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
   391     val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
   392 
   392 
   393     val bd = mk_bd_of_bnf Ds As bnf;
   393     val bd = mk_bd_of_bnf Ds As bnf;
   394 
   394 
   395     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   395     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   396     fun map_comp0_tac {context = ctxt, prems = _} =
   396     fun map_comp0_tac ctxt =
   397       unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) ::
   397       unfold_thms_tac ctxt ((map_comp0_of_bnf bnf RS sym) ::
   398         @{thms comp_assoc id_comp comp_id}) THEN rtac refl 1;
   398         @{thms comp_assoc id_comp comp_id}) THEN rtac refl 1;
   399     fun map_cong0_tac {context = ctxt, prems = _} =
   399     fun map_cong0_tac ctxt =
   400       rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   400       rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   401     val set_map0_tacs =
   401     val set_map0_tacs =
   402       if Config.get lthy quick_and_dirty then
   402       if Config.get lthy quick_and_dirty then
   403         replicate (n + live) (K all_tac)
   403         replicate (n + live) (K all_tac)
   404       else
   404       else
   476 
   476 
   477     val bd = mk_bd_of_bnf Ds As bnf;
   477     val bd = mk_bd_of_bnf Ds As bnf;
   478 
   478 
   479     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   479     fun map_id0_tac _ = rtac (map_id0_of_bnf bnf) 1;
   480     fun map_comp0_tac _ = rtac (map_comp0_of_bnf bnf) 1;
   480     fun map_comp0_tac _ = rtac (map_comp0_of_bnf bnf) 1;
   481     fun map_cong0_tac {context = ctxt, prems = _} =
   481     fun map_cong0_tac ctxt =
   482       rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   482       rtac (map_cong0_of_bnf bnf) 1 THEN REPEAT_DETERM_N live (Goal.assume_rule_tac ctxt 1);
   483     val set_map0_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf));
   483     val set_map0_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_map0_of_bnf bnf));
   484     fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   484     fun bd_card_order_tac _ = rtac (bd_card_order_of_bnf bnf) 1;
   485     fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   485     fun bd_cinfinite_tac _ = rtac (bd_cinfinite_of_bnf bnf) 1;
   486     val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   486     val set_bd_tacs = permute (map (fn thm => fn _ => rtac thm 1) (set_bd_of_bnf bnf));
   626       (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
   626       (@{thm Cinfinite_cong} OF [bd_ordIso, bd_Cinfinite_of_bnf bnf]) RS conjunct1;
   627 
   627 
   628     val set_bds =
   628     val set_bds =
   629       map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
   629       map (fn thm => @{thm ordLeq_ordIso_trans} OF [thm, bd_ordIso]) (set_bd_of_bnf bnf);
   630 
   630 
   631     fun mk_tac thm {context = ctxt, prems = _} =
   631     fun mk_tac thm ctxt =
   632       (rtac (unfold_all ctxt thm) THEN'
   632       (rtac (unfold_all ctxt thm) THEN'
   633       SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
   633       SOLVE o REPEAT_DETERM o (atac ORELSE' Goal.assume_rule_tac ctxt)) 1;
   634 
   634 
   635     val tacs = zip_axioms (mk_tac (map_id0_of_bnf bnf)) (mk_tac (map_comp0_of_bnf bnf))
   635     val tacs = zip_axioms (mk_tac (map_id0_of_bnf bnf)) (mk_tac (map_comp0_of_bnf bnf))
   636       (mk_tac (map_cong0_of_bnf bnf)) (map mk_tac (set_map0_of_bnf bnf))
   636       (mk_tac (map_cong0_of_bnf bnf)) (map mk_tac (set_map0_of_bnf bnf))
   638       (mk_tac (le_rel_OO_of_bnf bnf))
   638       (mk_tac (le_rel_OO_of_bnf bnf))
   639       (mk_tac (rel_OO_Grp_of_bnf bnf));
   639       (mk_tac (rel_OO_Grp_of_bnf bnf));
   640 
   640 
   641     val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   641     val bnf_wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
   642 
   642 
   643     fun wit_tac {context = ctxt, prems = _} =
   643     fun wit_tac ctxt =
   644       mk_simple_wit_tac (map (unfold_all ctxt) (wit_thms_of_bnf bnf));
   644       mk_simple_wit_tac (map (unfold_all ctxt) (wit_thms_of_bnf bnf));
   645 
   645 
   646     val (bnf', lthy') =
   646     val (bnf', lthy') =
   647       bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
   647       bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
   648         Binding.empty Binding.empty []
   648         Binding.empty Binding.empty []