renamed "Codatatype" directory "BNF" (and corresponding session) -- this opens the door to no-nonsense session names like "HOL-BNF-LFP"
authorblanchet
Fri Sep 21 16:45:06 2012 +0200 (2012-09-21)
changeset 49510ba50d204095e
parent 49509 163914705f8d
child 49511 9f5bfef8bd82
renamed "Codatatype" directory "BNF" (and corresponding session) -- this opens the door to no-nonsense session names like "HOL-BNF-LFP"
Admin/lib/Tools/update_keywords
CONTRIBUTORS
NEWS
etc/isar-keywords.el
src/HOL/BNF/BNF.thy
src/HOL/BNF/BNF_Comp.thy
src/HOL/BNF/BNF_Def.thy
src/HOL/BNF/BNF_FP.thy
src/HOL/BNF/BNF_GFP.thy
src/HOL/BNF/BNF_LFP.thy
src/HOL/BNF/BNF_Util.thy
src/HOL/BNF/BNF_Wrap.thy
src/HOL/BNF/Basic_BNFs.thy
src/HOL/BNF/Countable_Set.thy
src/HOL/BNF/Equiv_Relations_More.thy
src/HOL/BNF/Examples/HFset.thy
src/HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
src/HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy
src/HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy
src/HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy
src/HOL/BNF/Examples/Lambda_Term.thy
src/HOL/BNF/Examples/ListF.thy
src/HOL/BNF/Examples/Misc_Codata.thy
src/HOL/BNF/Examples/Misc_Data.thy
src/HOL/BNF/Examples/Process.thy
src/HOL/BNF/Examples/Stream.thy
src/HOL/BNF/Examples/TreeFI.thy
src/HOL/BNF/Examples/TreeFsetI.thy
src/HOL/BNF/More_BNFs.thy
src/HOL/BNF/README.html
src/HOL/BNF/Tools/bnf_comp.ML
src/HOL/BNF/Tools/bnf_comp_tactics.ML
src/HOL/BNF/Tools/bnf_def.ML
src/HOL/BNF/Tools/bnf_def_tactics.ML
src/HOL/BNF/Tools/bnf_fp.ML
src/HOL/BNF/Tools/bnf_fp_sugar.ML
src/HOL/BNF/Tools/bnf_fp_sugar_tactics.ML
src/HOL/BNF/Tools/bnf_gfp.ML
src/HOL/BNF/Tools/bnf_gfp_tactics.ML
src/HOL/BNF/Tools/bnf_gfp_util.ML
src/HOL/BNF/Tools/bnf_lfp.ML
src/HOL/BNF/Tools/bnf_lfp_tactics.ML
src/HOL/BNF/Tools/bnf_lfp_util.ML
src/HOL/BNF/Tools/bnf_tactics.ML
src/HOL/BNF/Tools/bnf_util.ML
src/HOL/BNF/Tools/bnf_wrap.ML
src/HOL/BNF/Tools/bnf_wrap_tactics.ML
src/HOL/Codatatype/BNF.thy
src/HOL/Codatatype/BNF_Comp.thy
src/HOL/Codatatype/BNF_Def.thy
src/HOL/Codatatype/BNF_FP.thy
src/HOL/Codatatype/BNF_GFP.thy
src/HOL/Codatatype/BNF_LFP.thy
src/HOL/Codatatype/BNF_Util.thy
src/HOL/Codatatype/BNF_Wrap.thy
src/HOL/Codatatype/Basic_BNFs.thy
src/HOL/Codatatype/Countable_Set.thy
src/HOL/Codatatype/Equiv_Relations_More.thy
src/HOL/Codatatype/Examples/HFset.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Parallel.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Prelim.thy
src/HOL/Codatatype/Examples/Infinite_Derivation_Trees/Tree.thy
src/HOL/Codatatype/Examples/Lambda_Term.thy
src/HOL/Codatatype/Examples/ListF.thy
src/HOL/Codatatype/Examples/Misc_Codata.thy
src/HOL/Codatatype/Examples/Misc_Data.thy
src/HOL/Codatatype/Examples/Process.thy
src/HOL/Codatatype/Examples/Stream.thy
src/HOL/Codatatype/Examples/TreeFI.thy
src/HOL/Codatatype/Examples/TreeFsetI.thy
src/HOL/Codatatype/More_BNFs.thy
src/HOL/Codatatype/README.html
src/HOL/Codatatype/Tools/bnf_comp.ML
src/HOL/Codatatype/Tools/bnf_comp_tactics.ML
src/HOL/Codatatype/Tools/bnf_def.ML
src/HOL/Codatatype/Tools/bnf_def_tactics.ML
src/HOL/Codatatype/Tools/bnf_fp.ML
src/HOL/Codatatype/Tools/bnf_fp_sugar.ML
src/HOL/Codatatype/Tools/bnf_fp_sugar_tactics.ML
src/HOL/Codatatype/Tools/bnf_gfp.ML
src/HOL/Codatatype/Tools/bnf_gfp_tactics.ML
src/HOL/Codatatype/Tools/bnf_gfp_util.ML
src/HOL/Codatatype/Tools/bnf_lfp.ML
src/HOL/Codatatype/Tools/bnf_lfp_tactics.ML
src/HOL/Codatatype/Tools/bnf_lfp_util.ML
src/HOL/Codatatype/Tools/bnf_tactics.ML
src/HOL/Codatatype/Tools/bnf_util.ML
src/HOL/Codatatype/Tools/bnf_wrap.ML
src/HOL/Codatatype/Tools/bnf_wrap_tactics.ML
src/HOL/ROOT
     1.1 --- a/Admin/lib/Tools/update_keywords	Fri Sep 21 16:34:40 2012 +0200
     1.2 +++ b/Admin/lib/Tools/update_keywords	Fri Sep 21 16:45:06 2012 +0200
     1.3 @@ -9,7 +9,7 @@
     1.4  cd "$ISABELLE_HOME/etc"
     1.5  
     1.6  "$ISABELLE_TOOL" keywords \
     1.7 -  "$LOG/HOLCF.gz" "$LOG/HOL-Boogie.gz" "$LOG/HOL-Codatatype.gz" "$LOG/HOL-Library.gz" "$LOG/HOL-Nominal.gz" \
     1.8 +  "$LOG/HOLCF.gz" "$LOG/HOL-BNF.gz" "$LOG/HOL-Boogie.gz" "$LOG/HOL-Library.gz" "$LOG/HOL-Nominal.gz" \
     1.9    "$LOG/HOL-Statespace.gz" "$LOG/HOL-SPARK.gz" "$LOG/HOL-TPTP.gz" "$LOG/HOL-Import.gz"
    1.10  
    1.11  "$ISABELLE_TOOL" keywords -k ZF "$LOG/ZF.gz"
     2.1 --- a/CONTRIBUTORS	Fri Sep 21 16:34:40 2012 +0200
     2.2 +++ b/CONTRIBUTORS	Fri Sep 21 16:45:06 2012 +0200
     2.3 @@ -14,7 +14,7 @@
     2.4    Sublist_Order) w.r.t. prefixes, suffixes, and embedding on lists.
     2.5  
     2.6  * August 2012: Dmitriy Traytel, Andrei Popescu, Jasmin Blanchette, TUM
     2.7 -  New (co)datatype package.
     2.8 +  New BNF-based (co)datatype package.
     2.9  
    2.10  * August 2012: Andrei Popescu and Dmitriy Traytel, TUM
    2.11    Theories of ordinals and cardinals.
     3.1 --- a/NEWS	Fri Sep 21 16:34:40 2012 +0200
     3.2 +++ b/NEWS	Fri Sep 21 16:45:06 2012 +0200
     3.3 @@ -100,8 +100,9 @@
     3.4  
     3.5      INCOMPATIBILITY.
     3.6  
     3.7 -* HOL/Codatatype: New (co)datatype package with support for mixed,
     3.8 -nested recursion and interesting non-free datatypes.
     3.9 +* HOL/BNF: New (co)datatype package based on bounded natural
    3.10 +functors with support for mixed, nested recursion and interesting
    3.11 +non-free datatypes.
    3.12  
    3.13  * HOL/Cardinals: Theories of ordinals and cardinals
    3.14  (supersedes the AFP entry "Ordinals_and_Cardinals").
     4.1 --- a/etc/isar-keywords.el	Fri Sep 21 16:34:40 2012 +0200
     4.2 +++ b/etc/isar-keywords.el	Fri Sep 21 16:45:06 2012 +0200
     4.3 @@ -1,6 +1,6 @@
     4.4  ;;
     4.5  ;; Keyword classification tables for Isabelle/Isar.
     4.6 -;; Generated from HOLCF + HOL-Boogie + HOL-Codatatype + HOL-Library + HOL-Nominal + HOL-Statespace + HOL-SPARK + HOL-TPTP + HOL-Import.
     4.7 +;; Generated from HOLCF + HOL-BNF + HOL-Boogie + HOL-Library + HOL-Nominal + HOL-Statespace + HOL-SPARK + HOL-TPTP + HOL-Import.
     4.8  ;; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***
     4.9  ;;
    4.10  
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/BNF/BNF.thy	Fri Sep 21 16:45:06 2012 +0200
     5.3 @@ -0,0 +1,16 @@
     5.4 +(*  Title:      HOL/BNF/BNF.thy
     5.5 +    Author:     Dmitriy Traytel, TU Muenchen
     5.6 +    Author:     Andrei Popescu, TU Muenchen
     5.7 +    Author:     Jasmin Blanchette, TU Muenchen
     5.8 +    Copyright   2012
     5.9 +
    5.10 +Bounded natural functors for (co)datatypes.
    5.11 +*)
    5.12 +
    5.13 +header {* Bounded Natural Functors for (Co)datatypes *}
    5.14 +
    5.15 +theory BNF
    5.16 +imports More_BNFs
    5.17 +begin
    5.18 +
    5.19 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/BNF/BNF_Comp.thy	Fri Sep 21 16:45:06 2012 +0200
     6.3 @@ -0,0 +1,91 @@
     6.4 +(*  Title:      HOL/BNF/BNF_Comp.thy
     6.5 +    Author:     Dmitriy Traytel, TU Muenchen
     6.6 +    Copyright   2012
     6.7 +
     6.8 +Composition of bounded natural functors.
     6.9 +*)
    6.10 +
    6.11 +header {* Composition of Bounded Natural Functors *}
    6.12 +
    6.13 +theory BNF_Comp
    6.14 +imports Basic_BNFs
    6.15 +begin
    6.16 +
    6.17 +lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
    6.18 +by (rule ext) simp
    6.19 +
    6.20 +lemma Union_natural: "Union o image (image f) = image f o Union"
    6.21 +by (rule ext) (auto simp only: o_apply)
    6.22 +
    6.23 +lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
    6.24 +by (unfold o_assoc)
    6.25 +
    6.26 +lemma comp_single_set_bd:
    6.27 +  assumes fbd_Card_order: "Card_order fbd" and
    6.28 +    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
    6.29 +    gset_bd: "\<And>x. |gset x| \<le>o gbd"
    6.30 +  shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
    6.31 +apply (subst sym[OF SUP_def])
    6.32 +apply (rule ordLeq_transitive)
    6.33 +apply (rule card_of_UNION_Sigma)
    6.34 +apply (subst SIGMA_CSUM)
    6.35 +apply (rule ordLeq_transitive)
    6.36 +apply (rule card_of_Csum_Times')
    6.37 +apply (rule fbd_Card_order)
    6.38 +apply (rule ballI)
    6.39 +apply (rule fset_bd)
    6.40 +apply (rule ordLeq_transitive)
    6.41 +apply (rule cprod_mono1)
    6.42 +apply (rule gset_bd)
    6.43 +apply (rule ordIso_imp_ordLeq)
    6.44 +apply (rule ordIso_refl)
    6.45 +apply (rule Card_order_cprod)
    6.46 +done
    6.47 +
    6.48 +lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
    6.49 +by simp
    6.50 +
    6.51 +lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
    6.52 +by simp
    6.53 +
    6.54 +lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
    6.55 +by (rule ext) (auto simp add: collect_def)
    6.56 +
    6.57 +lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
    6.58 +by blast
    6.59 +
    6.60 +lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
    6.61 +by blast
    6.62 +
    6.63 +lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>(\<lambda>f. f x) ` X| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
    6.64 +by (unfold o_apply collect_def SUP_def)
    6.65 +
    6.66 +lemma wpull_cong:
    6.67 +"\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
    6.68 +by simp
    6.69 +
    6.70 +lemma Id_def': "Id = {(a,b). a = b}"
    6.71 +by auto
    6.72 +
    6.73 +lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
    6.74 +unfolding Gr_def by auto
    6.75 +
    6.76 +lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
    6.77 +by simp
    6.78 +
    6.79 +lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
    6.80 +by auto
    6.81 +
    6.82 +lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
    6.83 +by blast
    6.84 +
    6.85 +lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
    6.86 +by auto
    6.87 +
    6.88 +lemma mem_Id_eq_eq: "(\<lambda>x y. (x, y) \<in> Id) = (op =)"
    6.89 +by simp
    6.90 +
    6.91 +ML_file "Tools/bnf_comp_tactics.ML"
    6.92 +ML_file "Tools/bnf_comp.ML"
    6.93 +
    6.94 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/BNF/BNF_Def.thy	Fri Sep 21 16:45:06 2012 +0200
     7.3 @@ -0,0 +1,151 @@
     7.4 +(*  Title:      HOL/BNF/BNF_Def.thy
     7.5 +    Author:     Dmitriy Traytel, TU Muenchen
     7.6 +    Copyright   2012
     7.7 +
     7.8 +Definition of bounded natural functors.
     7.9 +*)
    7.10 +
    7.11 +header {* Definition of Bounded Natural Functors *}
    7.12 +
    7.13 +theory BNF_Def
    7.14 +imports BNF_Util
    7.15 +keywords
    7.16 +  "print_bnfs" :: diag and
    7.17 +  "bnf_def" :: thy_goal
    7.18 +begin
    7.19 +
    7.20 +lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
    7.21 +by (rule ext) (auto simp only: o_apply collect_def)
    7.22 +
    7.23 +lemma converse_mono:
    7.24 +"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
    7.25 +unfolding converse_def by auto
    7.26 +
    7.27 +lemma converse_shift:
    7.28 +"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
    7.29 +unfolding converse_def by auto
    7.30 +
    7.31 +definition convol ("<_ , _>") where
    7.32 +"<f , g> \<equiv> %a. (f a, g a)"
    7.33 +
    7.34 +lemma fst_convol:
    7.35 +"fst o <f , g> = f"
    7.36 +apply(rule ext)
    7.37 +unfolding convol_def by simp
    7.38 +
    7.39 +lemma snd_convol:
    7.40 +"snd o <f , g> = g"
    7.41 +apply(rule ext)
    7.42 +unfolding convol_def by simp
    7.43 +
    7.44 +lemma convol_memI:
    7.45 +"\<lbrakk>f x = f' x; g x = g' x; P x\<rbrakk> \<Longrightarrow> <f , g> x \<in> {(f' a, g' a) |a. P a}"
    7.46 +unfolding convol_def by auto
    7.47 +
    7.48 +definition csquare where
    7.49 +"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
    7.50 +
    7.51 +(* The pullback of sets *)
    7.52 +definition thePull where
    7.53 +"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
    7.54 +
    7.55 +lemma wpull_thePull:
    7.56 +"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
    7.57 +unfolding wpull_def thePull_def by auto
    7.58 +
    7.59 +lemma wppull_thePull:
    7.60 +assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
    7.61 +shows
    7.62 +"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
    7.63 +   j a' \<in> A \<and>
    7.64 +   e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
    7.65 +(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
    7.66 +proof(rule bchoice[of ?A' ?phi], default)
    7.67 +  fix a' assume a': "a' \<in> ?A'"
    7.68 +  hence "fst a' \<in> B1" unfolding thePull_def by auto
    7.69 +  moreover
    7.70 +  from a' have "snd a' \<in> B2" unfolding thePull_def by auto
    7.71 +  moreover have "f1 (fst a') = f2 (snd a')"
    7.72 +  using a' unfolding csquare_def thePull_def by auto
    7.73 +  ultimately show "\<exists> ja'. ?phi a' ja'"
    7.74 +  using assms unfolding wppull_def by blast
    7.75 +qed
    7.76 +
    7.77 +lemma wpull_wppull:
    7.78 +assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
    7.79 +1: "\<forall> a' \<in> A'. j a' \<in> A \<and> e1 (p1 (j a')) = e1 (p1' a') \<and> e2 (p2 (j a')) = e2 (p2' a')"
    7.80 +shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
    7.81 +unfolding wppull_def proof safe
    7.82 +  fix b1 b2
    7.83 +  assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
    7.84 +  then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
    7.85 +  using wp unfolding wpull_def by blast
    7.86 +  show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
    7.87 +  apply (rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
    7.88 +qed
    7.89 +
    7.90 +lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
    7.91 +   wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
    7.92 +by (erule wpull_wppull) auto
    7.93 +
    7.94 +lemma Id_alt: "Id = Gr UNIV id"
    7.95 +unfolding Gr_def by auto
    7.96 +
    7.97 +lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
    7.98 +unfolding Gr_def by auto
    7.99 +
   7.100 +lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
   7.101 +unfolding Gr_def by auto
   7.102 +
   7.103 +lemma wpull_Gr:
   7.104 +"wpull (Gr A f) A (f ` A) f id fst snd"
   7.105 +unfolding wpull_def Gr_def by auto
   7.106 +
   7.107 +definition "pick_middle P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
   7.108 +
   7.109 +lemma pick_middle:
   7.110 +"(a,c) \<in> P O Q \<Longrightarrow> (a, pick_middle P Q a c) \<in> P \<and> (pick_middle P Q a c, c) \<in> Q"
   7.111 +unfolding pick_middle_def apply(rule someI_ex)
   7.112 +using assms unfolding relcomp_def by auto
   7.113 +
   7.114 +definition fstO where "fstO P Q ac = (fst ac, pick_middle P Q (fst ac) (snd ac))"
   7.115 +definition sndO where "sndO P Q ac = (pick_middle P Q (fst ac) (snd ac), snd ac)"
   7.116 +
   7.117 +lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
   7.118 +unfolding fstO_def
   7.119 +by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct1])
   7.120 +
   7.121 +lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
   7.122 +unfolding comp_def fstO_def by simp
   7.123 +
   7.124 +lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
   7.125 +unfolding comp_def sndO_def by simp
   7.126 +
   7.127 +lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
   7.128 +unfolding sndO_def
   7.129 +by (subst (asm) surjective_pairing) (rule pick_middle[THEN conjunct2])
   7.130 +
   7.131 +lemma csquare_fstO_sndO:
   7.132 +"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
   7.133 +unfolding csquare_def fstO_def sndO_def using pick_middle by simp
   7.134 +
   7.135 +lemma wppull_fstO_sndO:
   7.136 +shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
   7.137 +using pick_middle unfolding wppull_def fstO_def sndO_def relcomp_def by auto
   7.138 +
   7.139 +lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
   7.140 +by (simp split: prod.split)
   7.141 +
   7.142 +lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
   7.143 +by (simp split: prod.split)
   7.144 +
   7.145 +lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
   7.146 +by auto
   7.147 +
   7.148 +lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
   7.149 +unfolding o_def fun_eq_iff by simp
   7.150 +
   7.151 +ML_file "Tools/bnf_def_tactics.ML"
   7.152 +ML_file"Tools/bnf_def.ML"
   7.153 +
   7.154 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/BNF/BNF_FP.thy	Fri Sep 21 16:45:06 2012 +0200
     8.3 @@ -0,0 +1,113 @@
     8.4 +(*  Title:      HOL/BNF/BNF_FP.thy
     8.5 +    Author:     Dmitriy Traytel, TU Muenchen
     8.6 +    Author:     Jasmin Blanchette, TU Muenchen
     8.7 +    Copyright   2012
     8.8 +
     8.9 +Composition of bounded natural functors.
    8.10 +*)
    8.11 +
    8.12 +header {* Composition of Bounded Natural Functors *}
    8.13 +
    8.14 +theory BNF_FP
    8.15 +imports BNF_Comp BNF_Wrap
    8.16 +keywords
    8.17 +  "defaults"
    8.18 +begin
    8.19 +
    8.20 +lemma case_unit: "(case u of () => f) = f"
    8.21 +by (cases u) (hypsubst, rule unit.cases)
    8.22 +
    8.23 +lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    8.24 +by simp
    8.25 +
    8.26 +lemma prod_all_impI: "(\<And>x y. P (x, y) \<Longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    8.27 +by clarify
    8.28 +
    8.29 +lemma prod_all_impI_step: "(\<And>x. \<forall>y. P (x, y) \<longrightarrow> Q (x, y)) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
    8.30 +by auto
    8.31 +
    8.32 +lemma all_unit_eq: "(\<And>x. PROP P x) \<equiv> PROP P ()"
    8.33 +by simp
    8.34 +
    8.35 +lemma all_prod_eq: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
    8.36 +by clarsimp
    8.37 +
    8.38 +lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
    8.39 +by simp
    8.40 +
    8.41 +lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
    8.42 +by simp
    8.43 +
    8.44 +lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
    8.45 +unfolding o_def fun_eq_iff by simp
    8.46 +
    8.47 +lemma o_bij:
    8.48 +  assumes gf: "g o f = id" and fg: "f o g = id"
    8.49 +  shows "bij f"
    8.50 +unfolding bij_def inj_on_def surj_def proof safe
    8.51 +  fix a1 a2 assume "f a1 = f a2"
    8.52 +  hence "g ( f a1) = g (f a2)" by simp
    8.53 +  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
    8.54 +next
    8.55 +  fix b
    8.56 +  have "b = f (g b)"
    8.57 +  using fg unfolding fun_eq_iff by simp
    8.58 +  thus "EX a. b = f a" by blast
    8.59 +qed
    8.60 +
    8.61 +lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
    8.62 +
    8.63 +lemma sum_case_step:
    8.64 +  "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
    8.65 +  "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
    8.66 +by auto
    8.67 +
    8.68 +lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    8.69 +by simp
    8.70 +
    8.71 +lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
    8.72 +by blast
    8.73 +
    8.74 +lemma obj_sumE_f':
    8.75 +"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f x \<longrightarrow> P"
    8.76 +by (cases x) blast+
    8.77 +
    8.78 +lemma obj_sumE_f:
    8.79 +"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f x \<longrightarrow> P"
    8.80 +by (rule allI) (rule obj_sumE_f')
    8.81 +
    8.82 +lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    8.83 +by (cases s) auto
    8.84 +
    8.85 +lemma obj_sum_step':
    8.86 +"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> s = f (Inr x) \<longrightarrow> P"
    8.87 +by (cases x) blast+
    8.88 +
    8.89 +lemma obj_sum_step:
    8.90 +"\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f (Inr x) \<longrightarrow> P"
    8.91 +by (rule allI) (rule obj_sum_step')
    8.92 +
    8.93 +lemma sum_case_if:
    8.94 +"sum_case f g (if p then Inl x else Inr y) = (if p then f x else g y)"
    8.95 +by simp
    8.96 +
    8.97 +lemma mem_UN_compreh_eq: "(z : \<Union>{y. \<exists>x\<in>A. y = F x}) = (\<exists>x\<in>A. z : F x)"
    8.98 +by blast
    8.99 +
   8.100 +lemma prod_set_simps:
   8.101 +"fsts (x, y) = {x}"
   8.102 +"snds (x, y) = {y}"
   8.103 +unfolding fsts_def snds_def by simp+
   8.104 +
   8.105 +lemma sum_set_simps:
   8.106 +"setl (Inl x) = {x}"
   8.107 +"setl (Inr x) = {}"
   8.108 +"setr (Inl x) = {}"
   8.109 +"setr (Inr x) = {x}"
   8.110 +unfolding sum_set_defs by simp+
   8.111 +
   8.112 +ML_file "Tools/bnf_fp.ML"
   8.113 +ML_file "Tools/bnf_fp_sugar_tactics.ML"
   8.114 +ML_file "Tools/bnf_fp_sugar.ML"
   8.115 +
   8.116 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/BNF/BNF_GFP.thy	Fri Sep 21 16:45:06 2012 +0200
     9.3 @@ -0,0 +1,331 @@
     9.4 +(*  Title:      HOL/BNF/BNF_GFP.thy
     9.5 +    Author:     Dmitriy Traytel, TU Muenchen
     9.6 +    Copyright   2012
     9.7 +
     9.8 +Greatest fixed point operation on bounded natural functors.
     9.9 +*)
    9.10 +
    9.11 +header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
    9.12 +
    9.13 +theory BNF_GFP
    9.14 +imports BNF_FP Equiv_Relations_More "~~/src/HOL/Library/Prefix_Order"
    9.15 +keywords
    9.16 +  "codata_raw" :: thy_decl and
    9.17 +  "codata" :: thy_decl
    9.18 +begin
    9.19 +
    9.20 +lemma sum_case_comp_Inl:
    9.21 +"sum_case f g \<circ> Inl = f"
    9.22 +unfolding comp_def by simp
    9.23 +
    9.24 +lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
    9.25 +by (auto split: sum.splits)
    9.26 +
    9.27 +lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
    9.28 +by auto
    9.29 +
    9.30 +lemma equiv_triv1:
    9.31 +assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
    9.32 +shows "(b, c) \<in> R"
    9.33 +using assms unfolding equiv_def sym_def trans_def by blast
    9.34 +
    9.35 +lemma equiv_triv2:
    9.36 +assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
    9.37 +shows "(a, c) \<in> R"
    9.38 +using assms unfolding equiv_def trans_def by blast
    9.39 +
    9.40 +lemma equiv_proj:
    9.41 +  assumes e: "equiv A R" and "z \<in> R"
    9.42 +  shows "(proj R o fst) z = (proj R o snd) z"
    9.43 +proof -
    9.44 +  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
    9.45 +  have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
    9.46 +  have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
    9.47 +  with P show ?thesis unfolding proj_def[abs_def] by auto
    9.48 +qed
    9.49 +
    9.50 +(* Operators: *)
    9.51 +definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
    9.52 +definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
    9.53 +
    9.54 +lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
    9.55 +unfolding diag_def by simp
    9.56 +
    9.57 +lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
    9.58 +unfolding diag_def by simp
    9.59 +
    9.60 +lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
    9.61 +unfolding diag_def by auto
    9.62 +
    9.63 +lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
    9.64 +unfolding diag_def by auto
    9.65 +
    9.66 +lemma diag_UNIV: "diag UNIV = Id"
    9.67 +unfolding diag_def by auto
    9.68 +
    9.69 +lemma diag_converse: "diag A = (diag A) ^-1"
    9.70 +unfolding diag_def by auto
    9.71 +
    9.72 +lemma diag_Comp: "diag A = diag A O diag A"
    9.73 +unfolding diag_def by auto
    9.74 +
    9.75 +lemma diag_Gr: "diag A = Gr A id"
    9.76 +unfolding diag_def Gr_def by simp
    9.77 +
    9.78 +lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
    9.79 +unfolding diag_def by auto
    9.80 +
    9.81 +lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
    9.82 +unfolding image2_def by auto
    9.83 +
    9.84 +lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
    9.85 +by auto
    9.86 +
    9.87 +lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
    9.88 +by auto
    9.89 +
    9.90 +lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
    9.91 +unfolding image2_def Gr_def by auto
    9.92 +
    9.93 +lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
    9.94 +unfolding Gr_def by simp
    9.95 +
    9.96 +lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
    9.97 +unfolding Gr_def by simp
    9.98 +
    9.99 +lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
   9.100 +unfolding Gr_def by simp
   9.101 +
   9.102 +lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
   9.103 +unfolding Gr_def by simp
   9.104 +
   9.105 +lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
   9.106 +unfolding Gr_def by auto
   9.107 +
   9.108 +definition relImage where
   9.109 +"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
   9.110 +
   9.111 +definition relInvImage where
   9.112 +"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
   9.113 +
   9.114 +lemma relImage_Gr:
   9.115 +"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
   9.116 +unfolding relImage_def Gr_def relcomp_def by auto
   9.117 +
   9.118 +lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
   9.119 +unfolding Gr_def relcomp_def image_def relInvImage_def by auto
   9.120 +
   9.121 +lemma relImage_mono:
   9.122 +"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
   9.123 +unfolding relImage_def by auto
   9.124 +
   9.125 +lemma relInvImage_mono:
   9.126 +"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
   9.127 +unfolding relInvImage_def by auto
   9.128 +
   9.129 +lemma relInvImage_diag:
   9.130 +"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
   9.131 +unfolding relInvImage_def diag_def by auto
   9.132 +
   9.133 +lemma relInvImage_UNIV_relImage:
   9.134 +"R \<subseteq> relInvImage UNIV (relImage R f) f"
   9.135 +unfolding relInvImage_def relImage_def by auto
   9.136 +
   9.137 +lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
   9.138 +unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
   9.139 +
   9.140 +lemma relImage_proj:
   9.141 +assumes "equiv A R"
   9.142 +shows "relImage R (proj R) \<subseteq> diag (A//R)"
   9.143 +unfolding relImage_def diag_def apply safe
   9.144 +using proj_iff[OF assms]
   9.145 +by (metis assms equiv_Image proj_def proj_preserves)
   9.146 +
   9.147 +lemma relImage_relInvImage:
   9.148 +assumes "R \<subseteq> f ` A <*> f ` A"
   9.149 +shows "relImage (relInvImage A R f) f = R"
   9.150 +using assms unfolding relImage_def relInvImage_def by fastforce
   9.151 +
   9.152 +lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
   9.153 +by simp
   9.154 +
   9.155 +lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
   9.156 +by simp
   9.157 +
   9.158 +lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
   9.159 +by simp
   9.160 +
   9.161 +lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
   9.162 +by auto
   9.163 +
   9.164 +lemma image_convolD: "\<lbrakk>(a, b) \<in> <f, g> ` X\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> X \<and> a = f x \<and> b = g x"
   9.165 +unfolding convol_def by auto
   9.166 +
   9.167 +(*Extended Sublist*)
   9.168 +
   9.169 +definition prefCl where
   9.170 +  "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
   9.171 +definition PrefCl where
   9.172 +  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
   9.173 +
   9.174 +lemma prefCl_UN:
   9.175 +  "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
   9.176 +unfolding prefCl_def PrefCl_def by fastforce
   9.177 +
   9.178 +definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
   9.179 +definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
   9.180 +definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
   9.181 +
   9.182 +lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
   9.183 +unfolding Shift_def Succ_def by simp
   9.184 +
   9.185 +lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
   9.186 +unfolding Shift_def clists_def Field_card_of by auto
   9.187 +
   9.188 +lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
   9.189 +unfolding prefCl_def Shift_def
   9.190 +proof safe
   9.191 +  fix kl1 kl2
   9.192 +  assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
   9.193 +    "kl1 \<le> kl2" "k # kl2 \<in> Kl"
   9.194 +  thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
   9.195 +qed
   9.196 +
   9.197 +lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
   9.198 +unfolding Shift_def by simp
   9.199 +
   9.200 +lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
   9.201 +unfolding Succ_def proof
   9.202 +  assume "prefCl Kl" "k # kl \<in> Kl"
   9.203 +  moreover have "k # [] \<le> k # kl" by auto
   9.204 +  ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
   9.205 +  thus "[] @ [k] \<in> Kl" by simp
   9.206 +qed
   9.207 +
   9.208 +lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
   9.209 +unfolding Succ_def by simp
   9.210 +
   9.211 +lemmas SuccE = SuccD[elim_format]
   9.212 +
   9.213 +lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
   9.214 +unfolding Succ_def by simp
   9.215 +
   9.216 +lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
   9.217 +unfolding Shift_def by simp
   9.218 +
   9.219 +lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
   9.220 +unfolding Succ_def Shift_def by auto
   9.221 +
   9.222 +lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
   9.223 +unfolding Shift_def by simp
   9.224 +
   9.225 +lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
   9.226 +unfolding cexp_def Field_card_of by (simp only: card_of_refl)
   9.227 +
   9.228 +lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
   9.229 +unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
   9.230 +
   9.231 +lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
   9.232 +unfolding cpow_def clists_def
   9.233 +by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
   9.234 +   (erule notE, erule ordIso_transitive, rule czero_ordIso)
   9.235 +
   9.236 +lemma incl_UNION_I:
   9.237 +assumes "i \<in> I" and "A \<subseteq> F i"
   9.238 +shows "A \<subseteq> UNION I F"
   9.239 +using assms by auto
   9.240 +
   9.241 +lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
   9.242 +unfolding clists_def Field_card_of by auto
   9.243 +
   9.244 +lemma Cons_clists:
   9.245 +  "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
   9.246 +unfolding clists_def Field_card_of by auto
   9.247 +
   9.248 +lemma length_Cons: "length (x # xs) = Suc (length xs)"
   9.249 +by simp
   9.250 +
   9.251 +lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
   9.252 +by simp
   9.253 +
   9.254 +(*injection into the field of a cardinal*)
   9.255 +definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
   9.256 +definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
   9.257 +
   9.258 +lemma ex_toCard_pred:
   9.259 +"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
   9.260 +unfolding toCard_pred_def
   9.261 +using card_of_ordLeq[of A "Field r"]
   9.262 +      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
   9.263 +by blast
   9.264 +
   9.265 +lemma toCard_pred_toCard:
   9.266 +  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
   9.267 +unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
   9.268 +
   9.269 +lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
   9.270 +  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
   9.271 +using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
   9.272 +
   9.273 +lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
   9.274 +using toCard_pred_toCard unfolding toCard_pred_def by blast
   9.275 +
   9.276 +definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
   9.277 +
   9.278 +lemma fromCard_toCard:
   9.279 +"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
   9.280 +unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
   9.281 +
   9.282 +(* pick according to the weak pullback *)
   9.283 +definition pickWP_pred where
   9.284 +"pickWP_pred A p1 p2 b1 b2 a \<equiv> a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
   9.285 +
   9.286 +definition pickWP where
   9.287 +"pickWP A p1 p2 b1 b2 \<equiv> SOME a. pickWP_pred A p1 p2 b1 b2 a"
   9.288 +
   9.289 +lemma pickWP_pred:
   9.290 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   9.291 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   9.292 +shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
   9.293 +using assms unfolding wpull_def pickWP_pred_def by blast
   9.294 +
   9.295 +lemma pickWP_pred_pickWP:
   9.296 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   9.297 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   9.298 +shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
   9.299 +unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
   9.300 +
   9.301 +lemma pickWP:
   9.302 +assumes "wpull A B1 B2 f1 f2 p1 p2" and
   9.303 +"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
   9.304 +shows "pickWP A p1 p2 b1 b2 \<in> A"
   9.305 +      "p1 (pickWP A p1 p2 b1 b2) = b1"
   9.306 +      "p2 (pickWP A p1 p2 b1 b2) = b2"
   9.307 +using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
   9.308 +
   9.309 +lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
   9.310 +unfolding Field_card_of csum_def by auto
   9.311 +
   9.312 +lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
   9.313 +unfolding Field_card_of csum_def by auto
   9.314 +
   9.315 +lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
   9.316 +by auto
   9.317 +
   9.318 +lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
   9.319 +by auto
   9.320 +
   9.321 +lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
   9.322 +by auto
   9.323 +
   9.324 +lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
   9.325 +by auto
   9.326 +
   9.327 +lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
   9.328 +by simp
   9.329 +
   9.330 +ML_file "Tools/bnf_gfp_util.ML"
   9.331 +ML_file "Tools/bnf_gfp_tactics.ML"
   9.332 +ML_file "Tools/bnf_gfp.ML"
   9.333 +
   9.334 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/BNF/BNF_LFP.thy	Fri Sep 21 16:45:06 2012 +0200
    10.3 @@ -0,0 +1,228 @@
    10.4 +(*  Title:      HOL/BNF/BNF_LFP.thy
    10.5 +    Author:     Dmitriy Traytel, TU Muenchen
    10.6 +    Copyright   2012
    10.7 +
    10.8 +Least fixed point operation on bounded natural functors.
    10.9 +*)
   10.10 +
   10.11 +header {* Least Fixed Point Operation on Bounded Natural Functors *}
   10.12 +
   10.13 +theory BNF_LFP
   10.14 +imports BNF_FP
   10.15 +keywords
   10.16 +  "data_raw" :: thy_decl and
   10.17 +  "data" :: thy_decl
   10.18 +begin
   10.19 +
   10.20 +lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
   10.21 +by blast
   10.22 +
   10.23 +lemma image_Collect_subsetI:
   10.24 +  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
   10.25 +by blast
   10.26 +
   10.27 +lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
   10.28 +by auto
   10.29 +
   10.30 +lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
   10.31 +by auto
   10.32 +
   10.33 +lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
   10.34 +unfolding rel.underS_def by simp
   10.35 +
   10.36 +lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
   10.37 +unfolding rel.underS_def by simp
   10.38 +
   10.39 +lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
   10.40 +unfolding rel.underS_def Field_def by auto
   10.41 +
   10.42 +lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
   10.43 +unfolding Field_def by auto
   10.44 +
   10.45 +lemma fst_convol': "fst (<f, g> x) = f x"
   10.46 +using fst_convol unfolding convol_def by simp
   10.47 +
   10.48 +lemma snd_convol': "snd (<f, g> x) = g x"
   10.49 +using snd_convol unfolding convol_def by simp
   10.50 +
   10.51 +lemma convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
   10.52 +unfolding convol_def by auto
   10.53 +
   10.54 +definition inver where
   10.55 +  "inver g f A = (ALL a : A. g (f a) = a)"
   10.56 +
   10.57 +lemma bij_betw_iff_ex:
   10.58 +  "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
   10.59 +proof (rule iffI)
   10.60 +  assume ?L
   10.61 +  hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
   10.62 +  let ?phi = "% b a. a : A \<and> f a = b"
   10.63 +  have "ALL b : B. EX a. ?phi b a" using f by blast
   10.64 +  then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
   10.65 +    using bchoice[of B ?phi] by blast
   10.66 +  hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
   10.67 +  have gf: "inver g f A" unfolding inver_def
   10.68 +    by (metis (no_types) gg imageI[of _ A f] the_inv_into_f_f[OF inj_f])
   10.69 +  moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
   10.70 +  moreover have "A \<le> g ` B"
   10.71 +  proof safe
   10.72 +    fix a assume a: "a : A"
   10.73 +    hence "f a : B" using f by auto
   10.74 +    moreover have "a = g (f a)" using a gf unfolding inver_def by auto
   10.75 +    ultimately show "a : g ` B" by blast
   10.76 +  qed
   10.77 +  ultimately show ?R by blast
   10.78 +next
   10.79 +  assume ?R
   10.80 +  then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
   10.81 +  show ?L unfolding bij_betw_def
   10.82 +  proof safe
   10.83 +    show "inj_on f A" unfolding inj_on_def
   10.84 +    proof safe
   10.85 +      fix a1 a2 assume a: "a1 : A"  "a2 : A" and "f a1 = f a2"
   10.86 +      hence "g (f a1) = g (f a2)" by simp
   10.87 +      thus "a1 = a2" using a g unfolding inver_def by simp
   10.88 +    qed
   10.89 +  next
   10.90 +    fix a assume "a : A"
   10.91 +    then obtain b where b: "b : B" and a: "a = g b" using g by blast
   10.92 +    hence "b = f (g b)" using g unfolding inver_def by auto
   10.93 +    thus "f a : B" unfolding a using b by simp
   10.94 +  next
   10.95 +    fix b assume "b : B"
   10.96 +    hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
   10.97 +    thus "b : f ` A" by auto
   10.98 +  qed
   10.99 +qed
  10.100 +
  10.101 +lemma bij_betw_ex_weakE:
  10.102 +  "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
  10.103 +by (auto simp only: bij_betw_iff_ex)
  10.104 +
  10.105 +lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
  10.106 +unfolding inver_def by auto (rule rev_image_eqI, auto)
  10.107 +
  10.108 +lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
  10.109 +unfolding inver_def by auto
  10.110 +
  10.111 +lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
  10.112 +unfolding inver_def by simp
  10.113 +
  10.114 +lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
  10.115 +unfolding bij_betw_def by auto
  10.116 +
  10.117 +lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
  10.118 +unfolding bij_betw_def by auto
  10.119 +
  10.120 +lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
  10.121 +unfolding inver_def by auto
  10.122 +
  10.123 +lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
  10.124 +unfolding bij_betw_def inver_def by auto
  10.125 +
  10.126 +lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
  10.127 +unfolding bij_betw_def inver_def by auto
  10.128 +
  10.129 +lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
  10.130 +by (drule bij_betw_imageE, unfold bij_betw_iff_ex) blast
  10.131 +
  10.132 +lemma bij_betwI':
  10.133 +  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
  10.134 +    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
  10.135 +    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
  10.136 +unfolding bij_betw_def inj_on_def
  10.137 +apply (rule conjI)
  10.138 + apply blast
  10.139 +by (erule thin_rl) blast
  10.140 +
  10.141 +lemma surj_fun_eq:
  10.142 +  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
  10.143 +  shows "g1 = g2"
  10.144 +proof (rule ext)
  10.145 +  fix y
  10.146 +  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
  10.147 +  thus "g1 y = g2 y" using eq_on by simp
  10.148 +qed
  10.149 +
  10.150 +lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
  10.151 +unfolding wo_rel_def card_order_on_def by blast 
  10.152 +
  10.153 +lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
  10.154 +  \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
  10.155 +unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
  10.156 +
  10.157 +lemma Card_order_trans:
  10.158 +  "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
  10.159 +unfolding card_order_on_def well_order_on_def linear_order_on_def
  10.160 +  partial_order_on_def preorder_on_def trans_def antisym_def by blast
  10.161 +
  10.162 +lemma Cinfinite_limit2:
  10.163 + assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
  10.164 + shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
  10.165 +proof -
  10.166 +  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
  10.167 +    unfolding card_order_on_def well_order_on_def linear_order_on_def
  10.168 +      partial_order_on_def preorder_on_def by auto
  10.169 +  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
  10.170 +    using Cinfinite_limit[OF x1 r] by blast
  10.171 +  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
  10.172 +    using Cinfinite_limit[OF x2 r] by blast
  10.173 +  show ?thesis
  10.174 +  proof (cases "y1 = y2")
  10.175 +    case True with y1 y2 show ?thesis by blast
  10.176 +  next
  10.177 +    case False
  10.178 +    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
  10.179 +      unfolding total_on_def by auto
  10.180 +    thus ?thesis
  10.181 +    proof
  10.182 +      assume *: "(y1, y2) \<in> r"
  10.183 +      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
  10.184 +      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
  10.185 +    next
  10.186 +      assume *: "(y2, y1) \<in> r"
  10.187 +      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
  10.188 +      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
  10.189 +    qed
  10.190 +  qed
  10.191 +qed
  10.192 +
  10.193 +lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
  10.194 + \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
  10.195 +proof (induct X rule: finite_induct)
  10.196 +  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
  10.197 +next
  10.198 +  case (insert x X)
  10.199 +  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
  10.200 +  then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
  10.201 +    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
  10.202 +  show ?case
  10.203 +    apply (intro bexI ballI)
  10.204 +    apply (erule insertE)
  10.205 +    apply hypsubst
  10.206 +    apply (rule z(2))
  10.207 +    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
  10.208 +    apply blast
  10.209 +    apply (rule z(1))
  10.210 +    done
  10.211 +qed
  10.212 +
  10.213 +lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
  10.214 +by auto
  10.215 +
  10.216 +(*helps resolution*)
  10.217 +lemma well_order_induct_imp:
  10.218 +  "wo_rel r \<Longrightarrow> (\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> y \<in> Field r \<longrightarrow> P y \<Longrightarrow> x \<in> Field r \<longrightarrow> P x) \<Longrightarrow>
  10.219 +     x \<in> Field r \<longrightarrow> P x"
  10.220 +by (erule wo_rel.well_order_induct)
  10.221 +
  10.222 +lemma meta_spec2:
  10.223 +  assumes "(\<And>x y. PROP P x y)"
  10.224 +  shows "PROP P x y"
  10.225 +by (rule `(\<And>x y. PROP P x y)`)
  10.226 +
  10.227 +ML_file "Tools/bnf_lfp_util.ML"
  10.228 +ML_file "Tools/bnf_lfp_tactics.ML"
  10.229 +ML_file "Tools/bnf_lfp.ML"
  10.230 +
  10.231 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/BNF/BNF_Util.thy	Fri Sep 21 16:45:06 2012 +0200
    11.3 @@ -0,0 +1,66 @@
    11.4 +(*  Title:      HOL/BNF/BNF_Util.thy
    11.5 +    Author:     Dmitriy Traytel, TU Muenchen
    11.6 +    Author:     Jasmin Blanchette, TU Muenchen
    11.7 +    Copyright   2012
    11.8 +
    11.9 +Library for bounded natural functors.
   11.10 +*)
   11.11 +
   11.12 +header {* Library for Bounded Natural Functors *}
   11.13 +
   11.14 +theory BNF_Util
   11.15 +imports "../Cardinals/Cardinal_Arithmetic"
   11.16 +begin
   11.17 +
   11.18 +lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
   11.19 +by blast
   11.20 +
   11.21 +lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
   11.22 +by blast
   11.23 +
   11.24 +definition collect where
   11.25 +"collect F x = (\<Union>f \<in> F. f x)"
   11.26 +
   11.27 +(* Weak pullbacks: *)
   11.28 +definition wpull where
   11.29 +"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
   11.30 + (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow> (\<exists> a \<in> A. p1 a = b1 \<and> p2 a = b2))"
   11.31 +
   11.32 +(* Weak pseudo-pullbacks *)
   11.33 +definition wppull where
   11.34 +"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
   11.35 + (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
   11.36 +           (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
   11.37 +
   11.38 +lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
   11.39 +by simp
   11.40 +
   11.41 +lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
   11.42 +by simp
   11.43 +
   11.44 +lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
   11.45 +by simp
   11.46 +
   11.47 +lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
   11.48 +by simp
   11.49 +
   11.50 +lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
   11.51 +unfolding bij_def inj_on_def by auto blast
   11.52 +
   11.53 +lemma pair_mem_Collect_split:
   11.54 +"(\<lambda>x y. (x, y) \<in> {(x, y). P x y}) = P"
   11.55 +by simp
   11.56 +
   11.57 +lemma Collect_pair_mem_eq: "{(x, y). (x, y) \<in> R} = R"
   11.58 +by simp
   11.59 +
   11.60 +lemma Collect_fst_snd_mem_eq: "{p. (fst p, snd p) \<in> A} = A"
   11.61 +by simp
   11.62 +
   11.63 +(* Operator: *)
   11.64 +definition "Gr A f = {(a, f a) | a. a \<in> A}"
   11.65 +
   11.66 +ML_file "Tools/bnf_util.ML"
   11.67 +ML_file "Tools/bnf_tactics.ML"
   11.68 +
   11.69 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/BNF/BNF_Wrap.thy	Fri Sep 21 16:45:06 2012 +0200
    12.3 @@ -0,0 +1,28 @@
    12.4 +(*  Title:      HOL/BNF/BNF_Wrap.thy
    12.5 +    Author:     Jasmin Blanchette, TU Muenchen
    12.6 +    Copyright   2012
    12.7 +
    12.8 +Wrapping datatypes.
    12.9 +*)
   12.10 +
   12.11 +header {* Wrapping Datatypes *}
   12.12 +
   12.13 +theory BNF_Wrap
   12.14 +imports BNF_Util
   12.15 +keywords
   12.16 +  "wrap_data" :: thy_goal and
   12.17 +  "no_dests"
   12.18 +begin
   12.19 +
   12.20 +lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
   12.21 +by (erule iffI) (erule contrapos_pn)
   12.22 +
   12.23 +lemma iff_contradict:
   12.24 +"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
   12.25 +"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
   12.26 +by blast+
   12.27 +
   12.28 +ML_file "Tools/bnf_wrap_tactics.ML"
   12.29 +ML_file "Tools/bnf_wrap.ML"
   12.30 +
   12.31 +end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/BNF/Basic_BNFs.thy	Fri Sep 21 16:45:06 2012 +0200
    13.3 @@ -0,0 +1,417 @@
    13.4 +(*  Title:      HOL/BNF/Basic_BNFs.thy
    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 +Registration of basic types as bounded natural functors.
   13.11 +*)
   13.12 +
   13.13 +header {* Registration of Basic Types as Bounded Natural Functors *}
   13.14 +
   13.15 +theory Basic_BNFs
   13.16 +imports BNF_Def
   13.17 +begin
   13.18 +
   13.19 +lemma wpull_id: "wpull UNIV B1 B2 id id id id"
   13.20 +unfolding wpull_def by simp
   13.21 +
   13.22 +lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
   13.23 +
   13.24 +lemma ctwo_card_order: "card_order ctwo"
   13.25 +using Card_order_ctwo by (unfold ctwo_def Field_card_of)
   13.26 +
   13.27 +lemma natLeq_cinfinite: "cinfinite natLeq"
   13.28 +unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
   13.29 +
   13.30 +bnf_def ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
   13.31 +  "\<lambda>x :: 'a \<Rightarrow> 'b \<Rightarrow> bool. x"
   13.32 +apply auto
   13.33 +apply (rule natLeq_card_order)
   13.34 +apply (rule natLeq_cinfinite)
   13.35 +apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
   13.36 +apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
   13.37 +apply (rule ordLeq_transitive)
   13.38 +apply (rule ordLeq_cexp1[of natLeq])
   13.39 +apply (rule Cinfinite_Cnotzero)
   13.40 +apply (rule conjI)
   13.41 +apply (rule natLeq_cinfinite)
   13.42 +apply (rule natLeq_Card_order)
   13.43 +apply (rule card_of_Card_order)
   13.44 +apply (rule cexp_mono1)
   13.45 +apply (rule ordLeq_csum1)
   13.46 +apply (rule card_of_Card_order)
   13.47 +apply (rule disjI2)
   13.48 +apply (rule cone_ordLeq_cexp)
   13.49 +apply (rule ordLeq_transitive)
   13.50 +apply (rule cone_ordLeq_ctwo)
   13.51 +apply (rule ordLeq_csum2)
   13.52 +apply (rule Card_order_ctwo)
   13.53 +apply (rule natLeq_Card_order)
   13.54 +apply (auto simp: Gr_def fun_eq_iff)
   13.55 +done
   13.56 +
   13.57 +bnf_def DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
   13.58 +  "op =::'a \<Rightarrow> 'a \<Rightarrow> bool"
   13.59 +apply (auto simp add: wpull_id)
   13.60 +apply (rule card_order_csum)
   13.61 +apply (rule natLeq_card_order)
   13.62 +apply (rule card_of_card_order_on)
   13.63 +apply (rule cinfinite_csum)
   13.64 +apply (rule disjI1)
   13.65 +apply (rule natLeq_cinfinite)
   13.66 +apply (rule ordLess_imp_ordLeq)
   13.67 +apply (rule ordLess_ordLeq_trans)
   13.68 +apply (rule ordLess_ctwo_cexp)
   13.69 +apply (rule card_of_Card_order)
   13.70 +apply (rule cexp_mono2'')
   13.71 +apply (rule ordLeq_csum2)
   13.72 +apply (rule card_of_Card_order)
   13.73 +apply (rule ctwo_Cnotzero)
   13.74 +apply (rule card_of_Card_order)
   13.75 +apply (auto simp: Id_def Gr_def fun_eq_iff)
   13.76 +done
   13.77 +
   13.78 +definition setl :: "'a + 'b \<Rightarrow> 'a set" where
   13.79 +"setl x = (case x of Inl z => {z} | _ => {})"
   13.80 +
   13.81 +definition setr :: "'a + 'b \<Rightarrow> 'b set" where
   13.82 +"setr x = (case x of Inr z => {z} | _ => {})"
   13.83 +
   13.84 +lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
   13.85 +
   13.86 +definition sum_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a + 'c \<Rightarrow> 'b + 'd \<Rightarrow> bool" where
   13.87 +"sum_rel \<phi> \<psi> x y =
   13.88 + (case x of Inl a1 \<Rightarrow> (case y of Inl a2 \<Rightarrow> \<phi> a1 a2 | Inr _ \<Rightarrow> False)
   13.89 +          | Inr b1 \<Rightarrow> (case y of Inl _ \<Rightarrow> False | Inr b2 \<Rightarrow> \<psi> b1 b2))"
   13.90 +
   13.91 +bnf_def sum_map [setl, setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr] sum_rel
   13.92 +proof -
   13.93 +  show "sum_map id id = id" by (rule sum_map.id)
   13.94 +next
   13.95 +  fix f1 f2 g1 g2
   13.96 +  show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
   13.97 +    by (rule sum_map.comp[symmetric])
   13.98 +next
   13.99 +  fix x f1 f2 g1 g2
  13.100 +  assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
  13.101 +         a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
  13.102 +  thus "sum_map f1 f2 x = sum_map g1 g2 x"
  13.103 +  proof (cases x)
  13.104 +    case Inl thus ?thesis using a1 by (clarsimp simp: setl_def)
  13.105 +  next
  13.106 +    case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
  13.107 +  qed
  13.108 +next
  13.109 +  fix f1 f2
  13.110 +  show "setl o sum_map f1 f2 = image f1 o setl"
  13.111 +    by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
  13.112 +next
  13.113 +  fix f1 f2
  13.114 +  show "setr o sum_map f1 f2 = image f2 o setr"
  13.115 +    by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
  13.116 +next
  13.117 +  show "card_order natLeq" by (rule natLeq_card_order)
  13.118 +next
  13.119 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  13.120 +next
  13.121 +  fix x
  13.122 +  show "|setl x| \<le>o natLeq"
  13.123 +    apply (rule ordLess_imp_ordLeq)
  13.124 +    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
  13.125 +    by (simp add: setl_def split: sum.split)
  13.126 +next
  13.127 +  fix x
  13.128 +  show "|setr x| \<le>o natLeq"
  13.129 +    apply (rule ordLess_imp_ordLeq)
  13.130 +    apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
  13.131 +    by (simp add: setr_def split: sum.split)
  13.132 +next
  13.133 +  fix A1 :: "'a set" and A2 :: "'b set"
  13.134 +  have in_alt: "{x. (case x of Inl z => {z} | _ => {}) \<subseteq> A1 \<and>
  13.135 +    (case x of Inr z => {z} | _ => {}) \<subseteq> A2} = A1 <+> A2" (is "?L = ?R")
  13.136 +  proof safe
  13.137 +    fix x :: "'a + 'b"
  13.138 +    assume "(case x of Inl z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A1" "(case x of Inr z \<Rightarrow> {z} | _ \<Rightarrow> {}) \<subseteq> A2"
  13.139 +    hence "x \<in> Inl ` A1 \<or> x \<in> Inr ` A2" by (cases x) simp+
  13.140 +    thus "x \<in> A1 <+> A2" by blast
  13.141 +  qed (auto split: sum.split)
  13.142 +  show "|{x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}| \<le>o
  13.143 +    (( |A1| +c |A2| ) +c ctwo) ^c natLeq"
  13.144 +    apply (rule ordIso_ordLeq_trans)
  13.145 +    apply (rule card_of_ordIso_subst)
  13.146 +    apply (unfold sum_set_defs)
  13.147 +    apply (rule in_alt)
  13.148 +    apply (rule ordIso_ordLeq_trans)
  13.149 +    apply (rule Plus_csum)
  13.150 +    apply (rule ordLeq_transitive)
  13.151 +    apply (rule ordLeq_csum1)
  13.152 +    apply (rule Card_order_csum)
  13.153 +    apply (rule ordLeq_cexp1)
  13.154 +    apply (rule conjI)
  13.155 +    using Field_natLeq UNIV_not_empty czeroE apply fast
  13.156 +    apply (rule natLeq_Card_order)
  13.157 +    by (rule Card_order_csum)
  13.158 +next
  13.159 +  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
  13.160 +  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
  13.161 +  hence
  13.162 +    pull1: "\<And>b1 b2. \<lbrakk>b1 \<in> B11; b2 \<in> B21; f11 b1 = f21 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A1. p11 a = b1 \<and> p21 a = b2"
  13.163 +    and pull2: "\<And>b1 b2. \<lbrakk>b1 \<in> B12; b2 \<in> B22; f12 b1 = f22 b2\<rbrakk> \<Longrightarrow> \<exists>a \<in> A2. p12 a = b1 \<and> p22 a = b2"
  13.164 +    unfolding wpull_def by blast+
  13.165 +  show "wpull {x. setl x \<subseteq> A1 \<and> setr x \<subseteq> A2}
  13.166 +  {x. setl x \<subseteq> B11 \<and> setr x \<subseteq> B12} {x. setl x \<subseteq> B21 \<and> setr x \<subseteq> B22}
  13.167 +  (sum_map f11 f12) (sum_map f21 f22) (sum_map p11 p12) (sum_map p21 p22)"
  13.168 +    (is "wpull ?in ?in1 ?in2 ?mapf1 ?mapf2 ?mapp1 ?mapp2")
  13.169 +  proof (unfold wpull_def)
  13.170 +    { fix B1 B2
  13.171 +      assume *: "B1 \<in> ?in1" "B2 \<in> ?in2" "?mapf1 B1 = ?mapf2 B2"
  13.172 +      have "\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2"
  13.173 +      proof (cases B1)
  13.174 +        case (Inl b1)
  13.175 +        { fix b2 assume "B2 = Inr b2"
  13.176 +          with Inl *(3) have False by simp
  13.177 +        } then obtain b2 where Inl': "B2 = Inl b2" by (cases B2) (simp, blast)
  13.178 +        with Inl * have "b1 \<in> B11" "b2 \<in> B21" "f11 b1 = f21 b2"
  13.179 +        by (simp add: setl_def)+
  13.180 +        with pull1 obtain a where "a \<in> A1" "p11 a = b1" "p21 a = b2" by blast+
  13.181 +        with Inl Inl' have "Inl a \<in> ?in" "?mapp1 (Inl a) = B1 \<and> ?mapp2 (Inl a) = B2"
  13.182 +        by (simp add: sum_set_defs)+
  13.183 +        thus ?thesis by blast
  13.184 +      next
  13.185 +        case (Inr b1)
  13.186 +        { fix b2 assume "B2 = Inl b2"
  13.187 +          with Inr *(3) have False by simp
  13.188 +        } then obtain b2 where Inr': "B2 = Inr b2" by (cases B2) (simp, blast)
  13.189 +        with Inr * have "b1 \<in> B12" "b2 \<in> B22" "f12 b1 = f22 b2"
  13.190 +        by (simp add: sum_set_defs)+
  13.191 +        with pull2 obtain a where "a \<in> A2" "p12 a = b1" "p22 a = b2" by blast+
  13.192 +        with Inr Inr' have "Inr a \<in> ?in" "?mapp1 (Inr a) = B1 \<and> ?mapp2 (Inr a) = B2"
  13.193 +        by (simp add: sum_set_defs)+
  13.194 +        thus ?thesis by blast
  13.195 +      qed
  13.196 +    }
  13.197 +    thus "\<forall>B1 B2. B1 \<in> ?in1 \<and> B2 \<in> ?in2 \<and> ?mapf1 B1 = ?mapf2 B2 \<longrightarrow>
  13.198 +      (\<exists>A \<in> ?in. ?mapp1 A = B1 \<and> ?mapp2 A = B2)" by fastforce
  13.199 +  qed
  13.200 +next
  13.201 +  fix R S
  13.202 +  show "{p. sum_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
  13.203 +        (Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map fst fst))\<inverse> O
  13.204 +        Gr {x. setl x \<subseteq> R \<and> setr x \<subseteq> S} (sum_map snd snd)"
  13.205 +  unfolding setl_def setr_def sum_rel_def Gr_def relcomp_unfold converse_unfold
  13.206 +  by (fastforce split: sum.splits)
  13.207 +qed (auto simp: sum_set_defs)
  13.208 +
  13.209 +lemma singleton_ordLeq_ctwo_natLeq: "|{x}| \<le>o ctwo *c natLeq"
  13.210 +  apply (rule ordLeq_transitive)
  13.211 +  apply (rule ordLeq_cprod2)
  13.212 +  apply (rule ctwo_Cnotzero)
  13.213 +  apply (auto simp: Field_card_of intro: card_of_card_order_on)
  13.214 +  apply (rule cprod_mono2)
  13.215 +  apply (rule ordLess_imp_ordLeq)
  13.216 +  apply (unfold finite_iff_ordLess_natLeq[symmetric])
  13.217 +  by simp
  13.218 +
  13.219 +definition fsts :: "'a \<times> 'b \<Rightarrow> 'a set" where
  13.220 +"fsts x = {fst x}"
  13.221 +
  13.222 +definition snds :: "'a \<times> 'b \<Rightarrow> 'b set" where
  13.223 +"snds x = {snd x}"
  13.224 +
  13.225 +lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
  13.226 +
  13.227 +definition prod_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b \<times> 'd \<Rightarrow> bool" where
  13.228 +"prod_rel \<phi> \<psi> p1 p2 = (case p1 of (a1, b1) \<Rightarrow> case p2 of (a2, b2) \<Rightarrow> \<phi> a1 a2 \<and> \<psi> b1 b2)"
  13.229 +
  13.230 +bnf_def map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. ctwo *c natLeq" [Pair] prod_rel
  13.231 +proof (unfold prod_set_defs)
  13.232 +  show "map_pair id id = id" by (rule map_pair.id)
  13.233 +next
  13.234 +  fix f1 f2 g1 g2
  13.235 +  show "map_pair (g1 o f1) (g2 o f2) = map_pair g1 g2 o map_pair f1 f2"
  13.236 +    by (rule map_pair.comp[symmetric])
  13.237 +next
  13.238 +  fix x f1 f2 g1 g2
  13.239 +  assume "\<And>z. z \<in> {fst x} \<Longrightarrow> f1 z = g1 z" "\<And>z. z \<in> {snd x} \<Longrightarrow> f2 z = g2 z"
  13.240 +  thus "map_pair f1 f2 x = map_pair g1 g2 x" by (cases x) simp
  13.241 +next
  13.242 +  fix f1 f2
  13.243 +  show "(\<lambda>x. {fst x}) o map_pair f1 f2 = image f1 o (\<lambda>x. {fst x})"
  13.244 +    by (rule ext, unfold o_apply) simp
  13.245 +next
  13.246 +  fix f1 f2
  13.247 +  show "(\<lambda>x. {snd x}) o map_pair f1 f2 = image f2 o (\<lambda>x. {snd x})"
  13.248 +    by (rule ext, unfold o_apply) simp
  13.249 +next
  13.250 +  show "card_order (ctwo *c natLeq)"
  13.251 +    apply (rule card_order_cprod)
  13.252 +    apply (rule ctwo_card_order)
  13.253 +    by (rule natLeq_card_order)
  13.254 +next
  13.255 +  show "cinfinite (ctwo *c natLeq)"
  13.256 +    apply (rule cinfinite_cprod2)
  13.257 +    apply (rule ctwo_Cnotzero)
  13.258 +    apply (rule conjI[OF _ natLeq_Card_order])
  13.259 +    by (rule natLeq_cinfinite)
  13.260 +next
  13.261 +  fix x
  13.262 +  show "|{fst x}| \<le>o ctwo *c natLeq"
  13.263 +    by (rule singleton_ordLeq_ctwo_natLeq)
  13.264 +next
  13.265 +  fix x
  13.266 +  show "|{snd x}| \<le>o ctwo *c natLeq"
  13.267 +    by (rule singleton_ordLeq_ctwo_natLeq)
  13.268 +next
  13.269 +  fix A1 :: "'a set" and A2 :: "'b set"
  13.270 +  have in_alt: "{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2} = A1 \<times> A2" by auto
  13.271 +  show "|{x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}| \<le>o
  13.272 +    ( ( |A1| +c |A2| ) +c ctwo) ^c (ctwo *c natLeq)"
  13.273 +    apply (rule ordIso_ordLeq_trans)
  13.274 +    apply (rule card_of_ordIso_subst)
  13.275 +    apply (rule in_alt)
  13.276 +    apply (rule ordIso_ordLeq_trans)
  13.277 +    apply (rule Times_cprod)
  13.278 +    apply (rule ordLeq_transitive)
  13.279 +    apply (rule cprod_csum_cexp)
  13.280 +    apply (rule cexp_mono)
  13.281 +    apply (rule ordLeq_csum1)
  13.282 +    apply (rule Card_order_csum)
  13.283 +    apply (rule ordLeq_cprod1)
  13.284 +    apply (rule Card_order_ctwo)
  13.285 +    apply (rule Cinfinite_Cnotzero)
  13.286 +    apply (rule conjI[OF _ natLeq_Card_order])
  13.287 +    apply (rule natLeq_cinfinite)
  13.288 +    apply (rule disjI2)
  13.289 +    apply (rule cone_ordLeq_cexp)
  13.290 +    apply (rule ordLeq_transitive)
  13.291 +    apply (rule cone_ordLeq_ctwo)
  13.292 +    apply (rule ordLeq_csum2)
  13.293 +    apply (rule Card_order_ctwo)
  13.294 +    apply (rule notE)
  13.295 +    apply (rule ctwo_not_czero)
  13.296 +    apply assumption
  13.297 +    by (rule Card_order_ctwo)
  13.298 +next
  13.299 +  fix A1 A2 B11 B12 B21 B22 f11 f12 f21 f22 p11 p12 p21 p22
  13.300 +  assume "wpull A1 B11 B21 f11 f21 p11 p21" "wpull A2 B12 B22 f12 f22 p12 p22"
  13.301 +  thus "wpull {x. {fst x} \<subseteq> A1 \<and> {snd x} \<subseteq> A2}
  13.302 +    {x. {fst x} \<subseteq> B11 \<and> {snd x} \<subseteq> B12} {x. {fst x} \<subseteq> B21 \<and> {snd x} \<subseteq> B22}
  13.303 +   (map_pair f11 f12) (map_pair f21 f22) (map_pair p11 p12) (map_pair p21 p22)"
  13.304 +    unfolding wpull_def by simp fast
  13.305 +next
  13.306 +  fix R S
  13.307 +  show "{p. prod_rel (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) (fst p) (snd p)} =
  13.308 +        (Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair fst fst))\<inverse> O
  13.309 +        Gr {x. {fst x} \<subseteq> R \<and> {snd x} \<subseteq> S} (map_pair snd snd)"
  13.310 +  unfolding prod_set_defs prod_rel_def Gr_def relcomp_unfold converse_unfold
  13.311 +  by auto
  13.312 +qed simp+
  13.313 +
  13.314 +(* Categorical version of pullback: *)
  13.315 +lemma wpull_cat:
  13.316 +assumes p: "wpull A B1 B2 f1 f2 p1 p2"
  13.317 +and c: "f1 o q1 = f2 o q2"
  13.318 +and r: "range q1 \<subseteq> B1" "range q2 \<subseteq> B2"
  13.319 +obtains h where "range h \<subseteq> A \<and> q1 = p1 o h \<and> q2 = p2 o h"
  13.320 +proof-
  13.321 +  have *: "\<forall>d. \<exists>a \<in> A. p1 a = q1 d & p2 a = q2 d"
  13.322 +  proof safe
  13.323 +    fix d
  13.324 +    have "f1 (q1 d) = f2 (q2 d)" using c unfolding comp_def[abs_def] by (rule fun_cong)
  13.325 +    moreover
  13.326 +    have "q1 d : B1" "q2 d : B2" using r unfolding image_def by auto
  13.327 +    ultimately show "\<exists>a \<in> A. p1 a = q1 d \<and> p2 a = q2 d"
  13.328 +      using p unfolding wpull_def by auto
  13.329 +  qed
  13.330 +  then obtain h where "!! d. h d \<in> A & p1 (h d) = q1 d & p2 (h d) = q2 d" by metis
  13.331 +  thus ?thesis using that by fastforce
  13.332 +qed
  13.333 +
  13.334 +lemma card_of_bounded_range:
  13.335 +  "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
  13.336 +proof -
  13.337 +  let ?f = "\<lambda>f. %x. if f x \<in> B then Some (f x) else None"
  13.338 +  have "inj_on ?f ?LHS" unfolding inj_on_def
  13.339 +  proof (unfold fun_eq_iff, safe)
  13.340 +    fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
  13.341 +    assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
  13.342 +    hence "f x \<in> B" "g x \<in> B" by auto
  13.343 +    with eq have "Some (f x) = Some (g x)" by metis
  13.344 +    thus "f x = g x" by simp
  13.345 +  qed
  13.346 +  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
  13.347 +  ultimately show ?thesis using card_of_ordLeq by fast
  13.348 +qed
  13.349 +
  13.350 +definition fun_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b) \<Rightarrow> bool" where
  13.351 +"fun_rel \<phi> f g = (\<forall>x. \<phi> (f x) (g x))"
  13.352 +
  13.353 +bnf_def "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
  13.354 +  fun_rel
  13.355 +proof
  13.356 +  fix f show "id \<circ> f = id f" by simp
  13.357 +next
  13.358 +  fix f g show "op \<circ> (g \<circ> f) = op \<circ> g \<circ> op \<circ> f"
  13.359 +  unfolding comp_def[abs_def] ..
  13.360 +next
  13.361 +  fix x f g
  13.362 +  assume "\<And>z. z \<in> range x \<Longrightarrow> f z = g z"
  13.363 +  thus "f \<circ> x = g \<circ> x" by auto
  13.364 +next
  13.365 +  fix f show "range \<circ> op \<circ> f = op ` f \<circ> range"
  13.366 +  unfolding image_def comp_def[abs_def] by auto
  13.367 +next
  13.368 +  show "card_order (natLeq +c |UNIV| )" (is "_ (_ +c ?U)")
  13.369 +  apply (rule card_order_csum)
  13.370 +  apply (rule natLeq_card_order)
  13.371 +  by (rule card_of_card_order_on)
  13.372 +(*  *)
  13.373 +  show "cinfinite (natLeq +c ?U)"
  13.374 +    apply (rule cinfinite_csum)
  13.375 +    apply (rule disjI1)
  13.376 +    by (rule natLeq_cinfinite)
  13.377 +next
  13.378 +  fix f :: "'d => 'a"
  13.379 +  have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
  13.380 +  also have "?U \<le>o natLeq +c ?U"  by (rule ordLeq_csum2) (rule card_of_Card_order)
  13.381 +  finally show "|range f| \<le>o natLeq +c ?U" .
  13.382 +next
  13.383 +  fix B :: "'a set"
  13.384 +  have "|{f::'d => 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" by (rule card_of_bounded_range)
  13.385 +  also have "|Func (UNIV :: 'd set) B| =o |B| ^c |UNIV :: 'd set|"
  13.386 +    unfolding cexp_def Field_card_of by (rule card_of_refl)
  13.387 +  also have "|B| ^c |UNIV :: 'd set| \<le>o
  13.388 +             ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )"
  13.389 +    apply (rule cexp_mono)
  13.390 +     apply (rule ordLeq_csum1) apply (rule card_of_Card_order)
  13.391 +     apply (rule ordLeq_csum2) apply (rule card_of_Card_order)
  13.392 +     apply (rule disjI2) apply (rule cone_ordLeq_cexp)
  13.393 +      apply (rule ordLeq_transitive) apply (rule cone_ordLeq_ctwo) apply (rule ordLeq_csum2)
  13.394 +      apply (rule Card_order_ctwo)
  13.395 +     apply (rule notE) apply (rule conjunct1) apply (rule Cnotzero_UNIV) apply blast
  13.396 +     apply (rule card_of_Card_order)
  13.397 +  done
  13.398 +  finally
  13.399 +  show "|{f::'d => 'a. range f \<subseteq> B}| \<le>o
  13.400 +        ( |B| +c ctwo) ^c (natLeq +c |UNIV :: 'd set| )" .
  13.401 +next
  13.402 +  fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
  13.403 +  show "wpull {h. range h \<subseteq> A} {g1. range g1 \<subseteq> B1} {g2. range g2 \<subseteq> B2}
  13.404 +    (op \<circ> f1) (op \<circ> f2) (op \<circ> p1) (op \<circ> p2)"
  13.405 +  unfolding wpull_def
  13.406 +  proof safe
  13.407 +    fix g1 g2 assume r: "range g1 \<subseteq> B1" "range g2 \<subseteq> B2"
  13.408 +    and c: "f1 \<circ> g1 = f2 \<circ> g2"
  13.409 +    show "\<exists>h \<in> {h. range h \<subseteq> A}. p1 \<circ> h = g1 \<and> p2 \<circ> h = g2"
  13.410 +    using wpull_cat[OF p c r] by simp metis
  13.411 +  qed
  13.412 +next
  13.413 +  fix R
  13.414 +  show "{p. fun_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
  13.415 +        (Gr {x. range x \<subseteq> R} (op \<circ> fst))\<inverse> O Gr {x. range x \<subseteq> R} (op \<circ> snd)"
  13.416 +  unfolding fun_rel_def Gr_def relcomp_unfold converse_unfold
  13.417 +  by (auto intro!: exI dest!: in_mono)
  13.418 +qed auto
  13.419 +
  13.420 +end
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/BNF/Countable_Set.thy	Fri Sep 21 16:45:06 2012 +0200
    14.3 @@ -0,0 +1,366 @@
    14.4 +(*  Title:      HOL/BNF/Countable_Set.thy
    14.5 +    Author:     Andrei Popescu, TU Muenchen
    14.6 +    Copyright   2012
    14.7 +
    14.8 +(At most) countable sets.
    14.9 +*)
   14.10 +
   14.11 +header {* (At Most) Countable Sets *}
   14.12 +
   14.13 +theory Countable_Set
   14.14 +imports "../Cardinals/Cardinals" "~~/src/HOL/Library/Countable"
   14.15 +begin
   14.16 +
   14.17 +
   14.18 +subsection{* Basics  *}
   14.19 +
   14.20 +definition "countable A \<equiv> |A| \<le>o natLeq"
   14.21 +
   14.22 +lemma countable_card_of_nat:
   14.23 +"countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
   14.24 +unfolding countable_def using card_of_nat
   14.25 +using ordLeq_ordIso_trans ordIso_symmetric by blast
   14.26 +
   14.27 +lemma countable_ex_to_nat:
   14.28 +fixes A :: "'a set"
   14.29 +shows "countable A \<longleftrightarrow> (\<exists> f::'a\<Rightarrow>nat. inj_on f A)"
   14.30 +unfolding countable_card_of_nat card_of_ordLeq[symmetric] by auto
   14.31 +
   14.32 +lemma countable_or_card_of:
   14.33 +assumes "countable A"
   14.34 +shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
   14.35 +       (infinite A  \<and> |A| =o |UNIV::nat set| )"
   14.36 +apply (cases "finite A")
   14.37 +  apply(metis finite_iff_cardOf_nat)
   14.38 +  by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
   14.39 +
   14.40 +lemma countable_or:
   14.41 +assumes "countable A"
   14.42 +shows "(\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or>
   14.43 +       (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
   14.44 +using countable_or_card_of[OF assms]
   14.45 +by (metis assms card_of_ordIso countable_ex_to_nat)
   14.46 +
   14.47 +lemma countable_cases_card_of[elim, consumes 1, case_names Fin Inf]:
   14.48 +assumes "countable A"
   14.49 +and "\<lbrakk>finite A; |A| <o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
   14.50 +and "\<lbrakk>infinite A; |A| =o |UNIV::nat set|\<rbrakk> \<Longrightarrow> phi"
   14.51 +shows phi
   14.52 +using assms countable_or_card_of by blast
   14.53 +
   14.54 +lemma countable_cases[elim, consumes 1, case_names Fin Inf]:
   14.55 +assumes "countable A"
   14.56 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>finite A; inj_on f A\<rbrakk> \<Longrightarrow> phi"
   14.57 +and "\<And> f::'a\<Rightarrow>nat. \<lbrakk>infinite A; bij_betw f A UNIV\<rbrakk> \<Longrightarrow> phi"
   14.58 +shows phi
   14.59 +using assms countable_or by metis
   14.60 +
   14.61 +definition toNat_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool"
   14.62 +where
   14.63 +"toNat_pred (A::'a set) f \<equiv>
   14.64 + (finite A \<and> inj_on f A) \<or> (infinite A \<and> bij_betw f A UNIV)"
   14.65 +definition toNat where "toNat A \<equiv> SOME f. toNat_pred A f"
   14.66 +
   14.67 +lemma toNat_pred:
   14.68 +assumes "countable A"
   14.69 +shows "\<exists> f. toNat_pred A f"
   14.70 +using assms countable_ex_to_nat toNat_pred_def by (cases rule: countable_cases) auto
   14.71 +
   14.72 +lemma toNat_pred_toNat:
   14.73 +assumes "countable A"
   14.74 +shows "toNat_pred A (toNat A)"
   14.75 +unfolding toNat_def apply(rule someI_ex[of "toNat_pred A"])
   14.76 +using toNat_pred[OF assms] .
   14.77 +
   14.78 +lemma bij_betw_toNat:
   14.79 +assumes c: "countable A" and i: "infinite A"
   14.80 +shows "bij_betw (toNat A) A (UNIV::nat set)"
   14.81 +using toNat_pred_toNat[OF c] unfolding toNat_pred_def using i by auto
   14.82 +
   14.83 +lemma inj_on_toNat:
   14.84 +assumes c: "countable A"
   14.85 +shows "inj_on (toNat A) A"
   14.86 +using c apply(cases rule: countable_cases)
   14.87 +using bij_betw_toNat[OF c] toNat_pred_toNat[OF c]
   14.88 +unfolding toNat_pred_def unfolding bij_betw_def by auto
   14.89 +
   14.90 +lemma toNat_inj[simp]:
   14.91 +assumes c: "countable A" and a: "a \<in> A" and b: "b \<in> A"
   14.92 +shows "toNat A a = toNat A b \<longleftrightarrow> a = b"
   14.93 +using inj_on_toNat[OF c] using a b unfolding inj_on_def by auto
   14.94 +
   14.95 +lemma image_toNat:
   14.96 +assumes c: "countable A" and i: "infinite A"
   14.97 +shows "toNat A ` A = UNIV"
   14.98 +using bij_betw_toNat[OF assms] unfolding bij_betw_def by simp
   14.99 +
  14.100 +lemma toNat_surj:
  14.101 +assumes "countable A" and i: "infinite A"
  14.102 +shows "\<exists> a. a \<in> A \<and> toNat A a = n"
  14.103 +using image_toNat[OF assms]
  14.104 +by (metis (no_types) image_iff iso_tuple_UNIV_I)
  14.105 +
  14.106 +definition
  14.107 +"fromNat A n \<equiv>
  14.108 + if n \<in> toNat A ` A then inv_into A (toNat A) n
  14.109 + else (SOME a. a \<in> A)"
  14.110 +
  14.111 +lemma fromNat:
  14.112 +assumes "A \<noteq> {}"
  14.113 +shows "fromNat A n \<in> A"
  14.114 +unfolding fromNat_def by (metis assms equals0I inv_into_into someI_ex)
  14.115 +
  14.116 +lemma toNat_fromNat[simp]:
  14.117 +assumes "n \<in> toNat A ` A"
  14.118 +shows "toNat A (fromNat A n) = n"
  14.119 +by (metis assms f_inv_into_f fromNat_def)
  14.120 +
  14.121 +lemma infinite_toNat_fromNat[simp]:
  14.122 +assumes c: "countable A" and i: "infinite A"
  14.123 +shows "toNat A (fromNat A n) = n"
  14.124 +apply(rule toNat_fromNat) using toNat_surj[OF assms]
  14.125 +by (metis image_iff)
  14.126 +
  14.127 +lemma fromNat_toNat[simp]:
  14.128 +assumes c: "countable A" and a: "a \<in> A"
  14.129 +shows "fromNat A (toNat A a) = a"
  14.130 +by (metis a c equals0D fromNat imageI toNat_fromNat toNat_inj)
  14.131 +
  14.132 +lemma fromNat_inj:
  14.133 +assumes c: "countable A" and i: "infinite A"
  14.134 +shows "fromNat A m = fromNat A n \<longleftrightarrow> m = n" (is "?L = ?R \<longleftrightarrow> ?K")
  14.135 +proof-
  14.136 +  have "?L = ?R \<longleftrightarrow> toNat A ?L = toNat A ?R"
  14.137 +  unfolding toNat_inj[OF c fromNat[OF infinite_imp_nonempty[OF i]]
  14.138 +                           fromNat[OF infinite_imp_nonempty[OF i]]] ..
  14.139 +  also have "... \<longleftrightarrow> ?K" using c i by simp
  14.140 +  finally show ?thesis .
  14.141 +qed
  14.142 +
  14.143 +lemma fromNat_surj:
  14.144 +assumes c: "countable A" and a: "a \<in> A"
  14.145 +shows "\<exists> n. fromNat A n = a"
  14.146 +apply(rule exI[of _ "toNat A a"]) using assms by simp
  14.147 +
  14.148 +lemma fromNat_image_incl:
  14.149 +assumes "A \<noteq> {}"
  14.150 +shows "fromNat A ` UNIV \<subseteq> A"
  14.151 +using fromNat[OF assms] by auto
  14.152 +
  14.153 +lemma incl_fromNat_image:
  14.154 +assumes "countable A"
  14.155 +shows "A \<subseteq> fromNat A ` UNIV"
  14.156 +unfolding image_def using fromNat_surj[OF assms] by auto
  14.157 +
  14.158 +lemma fromNat_image[simp]:
  14.159 +assumes "A \<noteq> {}" and "countable A"
  14.160 +shows "fromNat A ` UNIV = A"
  14.161 +by (metis assms equalityI fromNat_image_incl incl_fromNat_image)
  14.162 +
  14.163 +lemma fromNat_inject[simp]:
  14.164 +assumes A: "A \<noteq> {}" "countable A" and B: "B \<noteq> {}" "countable B"
  14.165 +shows "fromNat A = fromNat B \<longleftrightarrow> A = B"
  14.166 +by (metis assms fromNat_image)
  14.167 +
  14.168 +lemma inj_on_fromNat:
  14.169 +"inj_on fromNat ({A. A \<noteq> {} \<and> countable A})"
  14.170 +unfolding inj_on_def by auto
  14.171 +
  14.172 +
  14.173 +subsection {* Preservation under the set theoretic operations *}
  14.174 +
  14.175 +lemma contable_empty[simp,intro]:
  14.176 +"countable {}"
  14.177 +by (metis countable_ex_to_nat inj_on_empty)
  14.178 +
  14.179 +lemma incl_countable:
  14.180 +assumes "A \<subseteq> B" and "countable B"
  14.181 +shows "countable A"
  14.182 +by (metis assms countable_ex_to_nat subset_inj_on)
  14.183 +
  14.184 +lemma countable_diff:
  14.185 +assumes "countable A"
  14.186 +shows "countable (A - B)"
  14.187 +by (metis Diff_subset assms incl_countable)
  14.188 +
  14.189 +lemma finite_countable[simp]:
  14.190 +assumes "finite A"
  14.191 +shows "countable A"
  14.192 +by (metis assms countable_ex_to_nat finite_imp_inj_to_nat_seg)
  14.193 +
  14.194 +lemma countable_singl[simp]:
  14.195 +"countable {a}"
  14.196 +by simp
  14.197 +
  14.198 +lemma countable_insert[simp]:
  14.199 +"countable (insert a A) \<longleftrightarrow> countable A"
  14.200 +proof
  14.201 +  assume c: "countable A"
  14.202 +  thus "countable (insert a A)"
  14.203 +  apply (cases rule: countable_cases_card_of)
  14.204 +    apply (metis finite_countable finite_insert)
  14.205 +    unfolding countable_card_of_nat
  14.206 +    by (metis infinite_card_of_insert ordIso_imp_ordLeq ordIso_transitive)
  14.207 +qed(insert incl_countable, metis incl_countable subset_insertI)
  14.208 +
  14.209 +lemma contable_IntL[simp]:
  14.210 +assumes "countable A"
  14.211 +shows "countable (A \<inter> B)"
  14.212 +by (metis Int_lower1 assms incl_countable)
  14.213 +
  14.214 +lemma contable_IntR[simp]:
  14.215 +assumes "countable B"
  14.216 +shows "countable (A \<inter> B)"
  14.217 +by (metis assms contable_IntL inf.commute)
  14.218 +
  14.219 +lemma countable_UN[simp]:
  14.220 +assumes cI: "countable I" and cA: "\<And> i. i \<in> I \<Longrightarrow> countable (A i)"
  14.221 +shows "countable (\<Union> i \<in> I. A i)"
  14.222 +using assms unfolding countable_card_of_nat
  14.223 +apply(intro card_of_UNION_ordLeq_infinite) by auto
  14.224 +
  14.225 +lemma contable_Un[simp]:
  14.226 +"countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
  14.227 +proof safe
  14.228 +  assume cA: "countable A" and cB: "countable B"
  14.229 +  let ?I = "{0,Suc 0}"  let ?As = "\<lambda> i. case i of 0 \<Rightarrow> A|Suc 0 \<Rightarrow> B"
  14.230 +  have AB: "A \<union> B = (\<Union> i \<in> ?I. ?As i)" by simp
  14.231 +  show "countable (A \<union> B)" unfolding AB apply(rule countable_UN)
  14.232 +  using cA cB by auto
  14.233 +qed (metis Un_upper1 incl_countable, metis Un_upper2 incl_countable)
  14.234 +
  14.235 +lemma countable_INT[simp]:
  14.236 +assumes "i \<in> I" and "countable (A i)"
  14.237 +shows "countable (\<Inter> i \<in> I. A i)"
  14.238 +by (metis INF_insert assms contable_IntL insert_absorb)
  14.239 +
  14.240 +lemma countable_class[simp]:
  14.241 +fixes A :: "('a::countable) set"
  14.242 +shows "countable A"
  14.243 +proof-
  14.244 +  have "inj_on to_nat A" by (metis inj_on_to_nat)
  14.245 +  thus ?thesis by (metis countable_ex_to_nat)
  14.246 +qed
  14.247 +
  14.248 +lemma countable_image[simp]:
  14.249 +assumes "countable A"
  14.250 +shows "countable (f ` A)"
  14.251 +using assms unfolding countable_card_of_nat
  14.252 +by (metis card_of_image ordLeq_transitive)
  14.253 +
  14.254 +lemma countable_ordLeq:
  14.255 +assumes "|A| \<le>o |B|" and "countable B"
  14.256 +shows "countable A"
  14.257 +using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
  14.258 +
  14.259 +lemma countable_ordLess:
  14.260 +assumes AB: "|A| <o |B|" and B: "countable B"
  14.261 +shows "countable A"
  14.262 +using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
  14.263 +
  14.264 +lemma countable_vimage:
  14.265 +assumes "B \<subseteq> range f" and "countable (f -` B)"
  14.266 +shows "countable B"
  14.267 +by (metis Int_absorb2 assms countable_image image_vimage_eq)
  14.268 +
  14.269 +lemma surj_countable_vimage:
  14.270 +assumes s: "surj f" and c: "countable (f -` B)"
  14.271 +shows "countable B"
  14.272 +apply(rule countable_vimage[OF _ c]) using s by auto
  14.273 +
  14.274 +lemma countable_Collect[simp]:
  14.275 +assumes "countable A"
  14.276 +shows "countable {a \<in> A. \<phi> a}"
  14.277 +by (metis Collect_conj_eq Int_absorb Int_commute Int_def assms contable_IntR)
  14.278 +
  14.279 +lemma countable_Plus[simp]:
  14.280 +assumes A: "countable A" and B: "countable B"
  14.281 +shows "countable (A <+> B)"
  14.282 +proof-
  14.283 +  let ?U = "UNIV::nat set"
  14.284 +  have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B 
  14.285 +  using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans 
  14.286 +  unfolding countable_def by blast+
  14.287 +  hence "|A <+> B| \<le>o |?U|" by (intro card_of_Plus_ordLeq_infinite) auto
  14.288 +  thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
  14.289 +qed
  14.290 +
  14.291 +lemma countable_Times[simp]:
  14.292 +assumes A: "countable A" and B: "countable B"
  14.293 +shows "countable (A \<times> B)"
  14.294 +proof-
  14.295 +  let ?U = "UNIV::nat set"
  14.296 +  have "|A| \<le>o |?U|" and "|B| \<le>o |?U|" using A B 
  14.297 +  using card_of_nat[THEN ordIso_symmetric] ordLeq_ordIso_trans 
  14.298 +  unfolding countable_def by blast+
  14.299 +  hence "|A \<times> B| \<le>o |?U|" by (intro card_of_Times_ordLeq_infinite) auto
  14.300 +  thus ?thesis using card_of_nat unfolding countable_def by(rule ordLeq_ordIso_trans)
  14.301 +qed
  14.302 +
  14.303 +lemma ordLeq_countable: 
  14.304 +assumes "|A| \<le>o |B|" and "countable B"
  14.305 +shows "countable A"
  14.306 +using assms unfolding countable_def by(rule ordLeq_transitive)
  14.307 +
  14.308 +lemma ordLess_countable: 
  14.309 +assumes A: "|A| <o |B|" and B: "countable B"
  14.310 +shows "countable A"
  14.311 +by (rule ordLeq_countable[OF ordLess_imp_ordLeq[OF A] B])
  14.312 +
  14.313 +lemma countable_def2: "countable A \<longleftrightarrow> |A| \<le>o |UNIV :: nat set|"
  14.314 +unfolding countable_def using card_of_nat[THEN ordIso_symmetric]
  14.315 +by (metis (lifting) Field_card_of Field_natLeq card_of_mono2 card_of_nat 
  14.316 +          countable_def ordIso_imp_ordLeq ordLeq_countable)
  14.317 +
  14.318 +
  14.319 +subsection{*  The type of countable sets *}
  14.320 +
  14.321 +typedef (open) 'a cset = "{A :: 'a set. countable A}"
  14.322 +apply(rule exI[of _ "{}"]) by simp
  14.323 +
  14.324 +abbreviation rcset where "rcset \<equiv> Rep_cset"
  14.325 +abbreviation acset where "acset \<equiv> Abs_cset"
  14.326 +
  14.327 +lemmas acset_rcset = Rep_cset_inverse
  14.328 +declare acset_rcset[simp]
  14.329 +
  14.330 +lemma acset_surj:
  14.331 +"\<exists> A. countable A \<and> acset A = C"
  14.332 +apply(cases rule: Abs_cset_cases[of C]) by auto
  14.333 +
  14.334 +lemma rcset_acset[simp]:
  14.335 +assumes "countable A"
  14.336 +shows "rcset (acset A) = A"
  14.337 +using Abs_cset_inverse assms by auto
  14.338 +
  14.339 +lemma acset_inj[simp]:
  14.340 +assumes "countable A" and "countable B"
  14.341 +shows "acset A = acset B \<longleftrightarrow> A = B"
  14.342 +using assms Abs_cset_inject by auto
  14.343 +
  14.344 +lemma rcset[simp]:
  14.345 +"countable (rcset C)"
  14.346 +using Rep_cset by simp
  14.347 +
  14.348 +lemma rcset_inj[simp]:
  14.349 +"rcset C = rcset D \<longleftrightarrow> C = D"
  14.350 +by (metis acset_rcset)
  14.351 +
  14.352 +lemma rcset_surj:
  14.353 +assumes "countable A"
  14.354 +shows "\<exists> C. rcset C = A"
  14.355 +apply(cases rule: Rep_cset_cases[of A])
  14.356 +using assms by auto
  14.357 +
  14.358 +definition "cIn a C \<equiv> (a \<in> rcset C)"
  14.359 +definition "cEmp \<equiv> acset {}"
  14.360 +definition "cIns a C \<equiv> acset (insert a (rcset C))"
  14.361 +abbreviation cSingl where "cSingl a \<equiv> cIns a cEmp"
  14.362 +definition "cUn C D \<equiv> acset (rcset C \<union> rcset D)"
  14.363 +definition "cInt C D \<equiv> acset (rcset C \<inter> rcset D)"
  14.364 +definition "cDif C D \<equiv> acset (rcset C - rcset D)"
  14.365 +definition "cIm f C \<equiv> acset (f ` rcset C)"
  14.366 +definition "cVim f D \<equiv> acset (f -` rcset D)"
  14.367 +(* TODO eventually: nice setup for these operations, copied from the set setup *)
  14.368 +
  14.369 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/BNF/Equiv_Relations_More.thy	Fri Sep 21 16:45:06 2012 +0200
    15.3 @@ -0,0 +1,161 @@
    15.4 +(*  Title:      HOL/BNF/Equiv_Relations_More.thy
    15.5 +    Author:     Andrei Popescu, TU Muenchen
    15.6 +    Copyright   2012
    15.7 +
    15.8 +Some preliminaries on equivalence relations and quotients.
    15.9 +*)
   15.10 +
   15.11 +header {* Some Preliminaries on Equivalence Relations and Quotients *}
   15.12 +
   15.13 +theory Equiv_Relations_More
   15.14 +imports Equiv_Relations Hilbert_Choice
   15.15 +begin
   15.16 +
   15.17 +
   15.18 +(* Recall the following constants and lemmas:
   15.19 +
   15.20 +term Eps
   15.21 +term "A//r"
   15.22 +lemmas equiv_def
   15.23 +lemmas refl_on_def
   15.24 + -- note that "reflexivity on" also assumes inclusion of the relation's field into r
   15.25 +
   15.26 +*)
   15.27 +
   15.28 +definition proj where "proj r x = r `` {x}"
   15.29 +
   15.30 +definition univ where "univ f X == f (Eps (%x. x \<in> X))"
   15.31 +
   15.32 +lemma proj_preserves:
   15.33 +"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
   15.34 +unfolding proj_def by (rule quotientI)
   15.35 +
   15.36 +lemma proj_in_iff:
   15.37 +assumes "equiv A r"
   15.38 +shows "(proj r x \<in> A//r) = (x \<in> A)"
   15.39 +apply(rule iffI, auto simp add: proj_preserves)
   15.40 +unfolding proj_def quotient_def proof clarsimp
   15.41 +  fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
   15.42 +  moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
   15.43 +  ultimately have "(x,y) \<in> r" by blast
   15.44 +  thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
   15.45 +qed
   15.46 +
   15.47 +lemma proj_iff:
   15.48 +"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
   15.49 +by (simp add: proj_def eq_equiv_class_iff)
   15.50 +
   15.51 +(*
   15.52 +lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
   15.53 +unfolding proj_def equiv_def refl_on_def by blast
   15.54 +*)
   15.55 +
   15.56 +lemma proj_image: "(proj r) ` A = A//r"
   15.57 +unfolding proj_def[abs_def] quotient_def by blast
   15.58 +
   15.59 +lemma in_quotient_imp_non_empty:
   15.60 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
   15.61 +unfolding quotient_def using equiv_class_self by fast
   15.62 +
   15.63 +lemma in_quotient_imp_in_rel:
   15.64 +"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
   15.65 +using quotient_eq_iff by fastforce
   15.66 +
   15.67 +lemma in_quotient_imp_closed:
   15.68 +"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
   15.69 +unfolding quotient_def equiv_def trans_def by blast
   15.70 +
   15.71 +lemma in_quotient_imp_subset:
   15.72 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
   15.73 +using assms in_quotient_imp_in_rel equiv_type by fastforce
   15.74 +
   15.75 +lemma equiv_Eps_in:
   15.76 +"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (%x. x \<in> X) \<in> X"
   15.77 +apply (rule someI2_ex)
   15.78 +using in_quotient_imp_non_empty by blast
   15.79 +
   15.80 +lemma equiv_Eps_preserves:
   15.81 +assumes ECH: "equiv A r" and X: "X \<in> A//r"
   15.82 +shows "Eps (%x. x \<in> X) \<in> A"
   15.83 +apply (rule in_mono[rule_format])
   15.84 + using assms apply (rule in_quotient_imp_subset)
   15.85 +by (rule equiv_Eps_in) (rule assms)+
   15.86 +
   15.87 +lemma proj_Eps:
   15.88 +assumes "equiv A r" and "X \<in> A//r"
   15.89 +shows "proj r (Eps (%x. x \<in> X)) = X"
   15.90 +unfolding proj_def proof auto
   15.91 +  fix x assume x: "x \<in> X"
   15.92 +  thus "(Eps (%x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
   15.93 +next
   15.94 +  fix x assume "(Eps (%x. x \<in> X),x) \<in> r"
   15.95 +  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
   15.96 +qed
   15.97 +
   15.98 +(*
   15.99 +lemma Eps_proj:
  15.100 +assumes "equiv A r" and "x \<in> A"
  15.101 +shows "(Eps (%y. y \<in> proj r x), x) \<in> r"
  15.102 +proof-
  15.103 +  have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
  15.104 +  hence "Eps(%y. y \<in> proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
  15.105 +  moreover have "x \<in> proj r x" using assms in_proj by fastforce
  15.106 +  ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
  15.107 +qed
  15.108 +
  15.109 +lemma equiv_Eps_iff:
  15.110 +assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
  15.111 +shows "((Eps (%x. x \<in> X),Eps (%y. y \<in> Y)) \<in> r) = (X = Y)"
  15.112 +proof-
  15.113 +  have "Eps (%x. x \<in> X) \<in> X \<and> Eps (%y. y \<in> Y) \<in> Y" using assms equiv_Eps_in by auto
  15.114 +  thus ?thesis using assms quotient_eq_iff by fastforce
  15.115 +qed
  15.116 +
  15.117 +lemma equiv_Eps_inj_on:
  15.118 +assumes "equiv A r"
  15.119 +shows "inj_on (%X. Eps (%x. x \<in> X)) (A//r)"
  15.120 +unfolding inj_on_def proof clarify
  15.121 +  fix X Y assume X: "X \<in> A//r" and Y: "Y \<in> A//r" and Eps: "Eps (%x. x \<in> X) = Eps (%y. y \<in> Y)"
  15.122 +  hence "Eps (%x. x \<in> X) \<in> A" using assms equiv_Eps_preserves by auto
  15.123 +  hence "(Eps (%x. x \<in> X), Eps (%y. y \<in> Y)) \<in> r"
  15.124 +  using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
  15.125 +  thus "X= Y" using X Y assms equiv_Eps_iff by auto
  15.126 +qed
  15.127 +*)
  15.128 +
  15.129 +lemma univ_commute:
  15.130 +assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
  15.131 +shows "(univ f) (proj r x) = f x"
  15.132 +unfolding univ_def proof -
  15.133 +  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
  15.134 +  hence "Eps (%y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
  15.135 +  moreover have "proj r (Eps (%y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
  15.136 +  ultimately have "(x, Eps (%y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
  15.137 +  thus "f (Eps (%y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
  15.138 +qed
  15.139 +
  15.140 +(*
  15.141 +lemma univ_unique:
  15.142 +assumes ECH: "equiv A r" and
  15.143 +        RES: "f respects r" and  COM: "\<forall> x \<in> A. G (proj r x) = f x"
  15.144 +shows "\<forall> X \<in> A//r. G X = univ f X"
  15.145 +proof
  15.146 +  fix X assume "X \<in> A//r"
  15.147 +  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  15.148 +  have "G X = f x" unfolding X using x COM by simp
  15.149 +  thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
  15.150 +qed
  15.151 +*)
  15.152 +
  15.153 +lemma univ_preserves:
  15.154 +assumes ECH: "equiv A r" and RES: "f respects r" and
  15.155 +        PRES: "\<forall> x \<in> A. f x \<in> B"
  15.156 +shows "\<forall> X \<in> A//r. univ f X \<in> B"
  15.157 +proof
  15.158 +  fix X assume "X \<in> A//r"
  15.159 +  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  15.160 +  hence "univ f X = f x" using assms univ_commute by fastforce
  15.161 +  thus "univ f X \<in> B" using x PRES by simp
  15.162 +qed
  15.163 +
  15.164 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/BNF/Examples/HFset.thy	Fri Sep 21 16:45:06 2012 +0200
    16.3 @@ -0,0 +1,60 @@
    16.4 +(*  Title:      HOL/BNF/Examples/HFset.thy
    16.5 +    Author:     Andrei Popescu, TU Muenchen
    16.6 +    Copyright   2012
    16.7 +
    16.8 +Hereditary sets.
    16.9 +*)
   16.10 +
   16.11 +header {* Hereditary Sets *}
   16.12 +
   16.13 +theory HFset
   16.14 +imports "../BNF"
   16.15 +begin
   16.16 +
   16.17 +
   16.18 +section {* Datatype definition *}
   16.19 +
   16.20 +data_raw hfset: 'hfset = "'hfset fset"
   16.21 +
   16.22 +
   16.23 +section {* Customization of terms *}
   16.24 +
   16.25 +subsection{* Constructors *}
   16.26 +
   16.27 +definition "Fold hs \<equiv> hfset_ctor hs"
   16.28 +
   16.29 +lemma hfset_simps[simp]:
   16.30 +"\<And>hs1 hs2. Fold hs1 = Fold hs2 \<longrightarrow> hs1 = hs2"
   16.31 +unfolding Fold_def hfset.ctor_inject by auto
   16.32 +
   16.33 +theorem hfset_cases[elim, case_names Fold]:
   16.34 +assumes Fold: "\<And> hs. h = Fold hs \<Longrightarrow> phi"
   16.35 +shows phi
   16.36 +using Fold unfolding Fold_def
   16.37 +by (cases rule: hfset.ctor_exhaust[of h]) simp
   16.38 +
   16.39 +lemma hfset_induct[case_names Fold, induct type: hfset]:
   16.40 +assumes Fold: "\<And> hs. (\<And> h. h |\<in>| hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
   16.41 +shows "phi t"
   16.42 +apply (induct rule: hfset.ctor_induct)
   16.43 +using Fold unfolding Fold_def fset_fset_member mem_Collect_eq ..
   16.44 +
   16.45 +(* alternative induction principle, using fset: *)
   16.46 +lemma hfset_induct_fset[case_names Fold, induct type: hfset]:
   16.47 +assumes Fold: "\<And> hs. (\<And> h. h \<in> fset hs \<Longrightarrow> phi h) \<Longrightarrow> phi (Fold hs)"
   16.48 +shows "phi t"
   16.49 +apply (induct rule: hfset_induct)
   16.50 +using Fold by (metis notin_fset)
   16.51 +
   16.52 +subsection{* Recursion and iteration (fold) *}
   16.53 +
   16.54 +lemma hfset_ctor_rec:
   16.55 +"hfset_ctor_rec R (Fold hs) = R (map_fset <id, hfset_ctor_rec R> hs)"
   16.56 +using hfset.ctor_recs unfolding Fold_def .
   16.57 +
   16.58 +(* The iterator has a simpler form: *)
   16.59 +lemma hfset_ctor_fold:
   16.60 +"hfset_ctor_fold R (Fold hs) = R (map_fset (hfset_ctor_fold R) hs)"
   16.61 +using hfset.ctor_folds unfolding Fold_def .
   16.62 +
   16.63 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy	Fri Sep 21 16:45:06 2012 +0200
    17.3 @@ -0,0 +1,1366 @@
    17.4 +(*  Title:      HOL/BNF/Examples/Infinite_Derivation_Trees/Gram_Lang.thy
    17.5 +    Author:     Andrei Popescu, TU Muenchen
    17.6 +    Copyright   2012
    17.7 +
    17.8 +Language of a grammar.
    17.9 +*)
   17.10 +
   17.11 +header {* Language of a Grammar *}
   17.12 +
   17.13 +theory Gram_Lang
   17.14 +imports Tree
   17.15 +begin 
   17.16 +
   17.17 +
   17.18 +consts P :: "(N \<times> (T + N) set) set"
   17.19 +axiomatization where 
   17.20 +    finite_N: "finite (UNIV::N set)"
   17.21 +and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
   17.22 +and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
   17.23 +
   17.24 +
   17.25 +subsection{* Tree basics: frontier, interior, etc. *}
   17.26 +
   17.27 +lemma Tree_cong: 
   17.28 +assumes "root tr = root tr'" and "cont tr = cont tr'"
   17.29 +shows "tr = tr'"
   17.30 +by (metis Node_root_cont assms)
   17.31 +
   17.32 +inductive finiteT where 
   17.33 +Node: "\<lbrakk>finite as; (finiteT^#) as\<rbrakk> \<Longrightarrow> finiteT (Node a as)"
   17.34 +monos lift_mono
   17.35 +
   17.36 +lemma finiteT_induct[consumes 1, case_names Node, induct pred: finiteT]:
   17.37 +assumes 1: "finiteT tr"
   17.38 +and IH: "\<And>as n. \<lbrakk>finite as; (\<phi>^#) as\<rbrakk> \<Longrightarrow> \<phi> (Node n as)"
   17.39 +shows "\<phi> tr"
   17.40 +using 1 apply(induct rule: finiteT.induct)
   17.41 +apply(rule IH) apply assumption apply(elim mono_lift) by simp
   17.42 +
   17.43 +
   17.44 +(* Frontier *)
   17.45 +
   17.46 +inductive inFr :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
   17.47 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
   17.48 +|
   17.49 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
   17.50 +
   17.51 +definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
   17.52 +
   17.53 +lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
   17.54 +by (metis inFr.simps)
   17.55 +
   17.56 +lemma inFr_mono: 
   17.57 +assumes "inFr ns tr t" and "ns \<subseteq> ns'"
   17.58 +shows "inFr ns' tr t"
   17.59 +using assms apply(induct arbitrary: ns' rule: inFr.induct)
   17.60 +using Base Ind by (metis inFr.simps set_mp)+
   17.61 +
   17.62 +lemma inFr_Ind_minus: 
   17.63 +assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
   17.64 +shows "inFr (insert (root tr) ns1) tr t"
   17.65 +using assms apply(induct rule: inFr.induct)
   17.66 +  apply (metis inFr.simps insert_iff)
   17.67 +  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
   17.68 +
   17.69 +(* alternative definition *)
   17.70 +inductive inFr2 :: "N set \<Rightarrow> Tree \<Rightarrow> T \<Rightarrow> bool" where 
   17.71 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
   17.72 +|
   17.73 +Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk> 
   17.74 +      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
   17.75 +
   17.76 +lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
   17.77 +apply(induct rule: inFr2.induct) by auto
   17.78 +
   17.79 +lemma inFr2_mono: 
   17.80 +assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
   17.81 +shows "inFr2 ns' tr t"
   17.82 +using assms apply(induct arbitrary: ns' rule: inFr2.induct)
   17.83 +using Base Ind
   17.84 +apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset) 
   17.85 +
   17.86 +lemma inFr2_Ind:
   17.87 +assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr" 
   17.88 +shows "inFr2 ns tr t"
   17.89 +using assms apply(induct rule: inFr2.induct)
   17.90 +  apply (metis inFr2.simps insert_absorb)
   17.91 +  by (metis inFr2.simps insert_absorb)  
   17.92 +
   17.93 +lemma inFr_inFr2:
   17.94 +"inFr = inFr2"
   17.95 +apply (rule ext)+  apply(safe)
   17.96 +  apply(erule inFr.induct)
   17.97 +    apply (metis (lifting) inFr2.Base)
   17.98 +    apply (metis (lifting) inFr2_Ind) 
   17.99 +  apply(erule inFr2.induct)
  17.100 +    apply (metis (lifting) inFr.Base)
  17.101 +    apply (metis (lifting) inFr_Ind_minus)
  17.102 +done  
  17.103 +
  17.104 +lemma not_root_inFr:
  17.105 +assumes "root tr \<notin> ns"
  17.106 +shows "\<not> inFr ns tr t"
  17.107 +by (metis assms inFr_root_in)
  17.108 +
  17.109 +theorem not_root_Fr:
  17.110 +assumes "root tr \<notin> ns"
  17.111 +shows "Fr ns tr = {}"
  17.112 +using not_root_inFr[OF assms] unfolding Fr_def by auto 
  17.113 +
  17.114 +
  17.115 +(* Interior *)
  17.116 +
  17.117 +inductive inItr :: "N set \<Rightarrow> Tree \<Rightarrow> N \<Rightarrow> bool" where 
  17.118 +Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
  17.119 +|
  17.120 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
  17.121 +
  17.122 +definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
  17.123 +
  17.124 +lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
  17.125 +by (metis inItr.simps) 
  17.126 +
  17.127 +lemma inItr_mono: 
  17.128 +assumes "inItr ns tr n" and "ns \<subseteq> ns'"
  17.129 +shows "inItr ns' tr n"
  17.130 +using assms apply(induct arbitrary: ns' rule: inItr.induct)
  17.131 +using Base Ind by (metis inItr.simps set_mp)+
  17.132 +
  17.133 +
  17.134 +(* The subtree relation *)  
  17.135 +
  17.136 +inductive subtr where 
  17.137 +Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
  17.138 +|
  17.139 +Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
  17.140 +
  17.141 +lemma subtr_rootL_in: 
  17.142 +assumes "subtr ns tr1 tr2"
  17.143 +shows "root tr1 \<in> ns"
  17.144 +using assms apply(induct rule: subtr.induct) by auto
  17.145 +
  17.146 +lemma subtr_rootR_in: 
  17.147 +assumes "subtr ns tr1 tr2"
  17.148 +shows "root tr2 \<in> ns"
  17.149 +using assms apply(induct rule: subtr.induct) by auto
  17.150 +
  17.151 +lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
  17.152 +
  17.153 +lemma subtr_mono: 
  17.154 +assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
  17.155 +shows "subtr ns' tr1 tr2"
  17.156 +using assms apply(induct arbitrary: ns' rule: subtr.induct)
  17.157 +using Refl Step by (metis subtr.simps set_mp)+
  17.158 +
  17.159 +lemma subtr_trans_Un:
  17.160 +assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
  17.161 +shows "subtr (ns12 \<union> ns23) tr1 tr3"
  17.162 +proof-
  17.163 +  have "subtr ns23 tr2 tr3  \<Longrightarrow> 
  17.164 +        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
  17.165 +  apply(induct  rule: subtr.induct, safe)
  17.166 +    apply (metis subtr_mono sup_commute sup_ge2)
  17.167 +    by (metis (lifting) Step UnI2) 
  17.168 +  thus ?thesis using assms by auto
  17.169 +qed
  17.170 +
  17.171 +lemma subtr_trans:
  17.172 +assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
  17.173 +shows "subtr ns tr1 tr3"
  17.174 +using subtr_trans_Un[OF assms] by simp
  17.175 +
  17.176 +lemma subtr_StepL: 
  17.177 +assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
  17.178 +shows "subtr ns tr1 tr3"
  17.179 +apply(rule subtr_trans[OF _ s]) apply(rule Step[of tr2 ns tr1 tr1])
  17.180 +by (metis assms subtr_rootL_in Refl)+
  17.181 +
  17.182 +(* alternative definition: *)
  17.183 +inductive subtr2 where 
  17.184 +Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
  17.185 +|
  17.186 +Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
  17.187 +
  17.188 +lemma subtr2_rootL_in: 
  17.189 +assumes "subtr2 ns tr1 tr2"
  17.190 +shows "root tr1 \<in> ns"
  17.191 +using assms apply(induct rule: subtr2.induct) by auto
  17.192 +
  17.193 +lemma subtr2_rootR_in: 
  17.194 +assumes "subtr2 ns tr1 tr2"
  17.195 +shows "root tr2 \<in> ns"
  17.196 +using assms apply(induct rule: subtr2.induct) by auto
  17.197 +
  17.198 +lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
  17.199 +
  17.200 +lemma subtr2_mono: 
  17.201 +assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
  17.202 +shows "subtr2 ns' tr1 tr2"
  17.203 +using assms apply(induct arbitrary: ns' rule: subtr2.induct)
  17.204 +using Refl Step by (metis subtr2.simps set_mp)+
  17.205 +
  17.206 +lemma subtr2_trans_Un:
  17.207 +assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
  17.208 +shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
  17.209 +proof-
  17.210 +  have "subtr2 ns12 tr1 tr2  \<Longrightarrow> 
  17.211 +        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
  17.212 +  apply(induct  rule: subtr2.induct, safe)
  17.213 +    apply (metis subtr2_mono sup_commute sup_ge2)
  17.214 +    by (metis Un_iff subtr2.simps)
  17.215 +  thus ?thesis using assms by auto
  17.216 +qed
  17.217 +
  17.218 +lemma subtr2_trans:
  17.219 +assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
  17.220 +shows "subtr2 ns tr1 tr3"
  17.221 +using subtr2_trans_Un[OF assms] by simp
  17.222 +
  17.223 +lemma subtr2_StepR: 
  17.224 +assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
  17.225 +shows "subtr2 ns tr1 tr3"
  17.226 +apply(rule subtr2_trans[OF s]) apply(rule Step[of _ _ tr3])
  17.227 +by (metis assms subtr2_rootR_in Refl)+
  17.228 +
  17.229 +lemma subtr_subtr2:
  17.230 +"subtr = subtr2"
  17.231 +apply (rule ext)+  apply(safe)
  17.232 +  apply(erule subtr.induct)
  17.233 +    apply (metis (lifting) subtr2.Refl)
  17.234 +    apply (metis (lifting) subtr2_StepR) 
  17.235 +  apply(erule subtr2.induct)
  17.236 +    apply (metis (lifting) subtr.Refl)
  17.237 +    apply (metis (lifting) subtr_StepL)
  17.238 +done
  17.239 +
  17.240 +lemma subtr_inductL[consumes 1, case_names Refl Step]:
  17.241 +assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
  17.242 +and Step: 
  17.243 +"\<And>ns tr1 tr2 tr3. 
  17.244 +   \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
  17.245 +shows "\<phi> ns tr1 tr2"
  17.246 +using s unfolding subtr_subtr2 apply(rule subtr2.induct)
  17.247 +using Refl Step unfolding subtr_subtr2 by auto
  17.248 +
  17.249 +lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
  17.250 +assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
  17.251 +and Step: 
  17.252 +"\<And>tr1 tr2 tr3. 
  17.253 +   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
  17.254 +shows "\<phi> tr1 tr2"
  17.255 +using s apply(induct rule: subtr_inductL)
  17.256 +apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
  17.257 +
  17.258 +(* Subtree versus frontier: *)
  17.259 +lemma subtr_inFr:
  17.260 +assumes "inFr ns tr t" and "subtr ns tr tr1" 
  17.261 +shows "inFr ns tr1 t"
  17.262 +proof-
  17.263 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
  17.264 +  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
  17.265 +  thus ?thesis using assms by auto
  17.266 +qed
  17.267 +
  17.268 +corollary Fr_subtr: 
  17.269 +"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
  17.270 +unfolding Fr_def proof safe
  17.271 +  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)  
  17.272 +  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
  17.273 +  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
  17.274 +qed(metis subtr_inFr)
  17.275 +
  17.276 +lemma inFr_subtr:
  17.277 +assumes "inFr ns tr t" 
  17.278 +shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
  17.279 +using assms apply(induct rule: inFr.induct) apply safe
  17.280 +  apply (metis subtr.Refl)
  17.281 +  by (metis (lifting) subtr.Step)
  17.282 +
  17.283 +corollary Fr_subtr_cont: 
  17.284 +"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
  17.285 +unfolding Fr_def
  17.286 +apply safe
  17.287 +apply (frule inFr_subtr)
  17.288 +apply auto
  17.289 +by (metis inFr.Base subtr_inFr subtr_rootL_in)
  17.290 +
  17.291 +(* Subtree versus interior: *)
  17.292 +lemma subtr_inItr:
  17.293 +assumes "inItr ns tr n" and "subtr ns tr tr1" 
  17.294 +shows "inItr ns tr1 n"
  17.295 +proof-
  17.296 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
  17.297 +  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
  17.298 +  thus ?thesis using assms by auto
  17.299 +qed
  17.300 +
  17.301 +corollary Itr_subtr: 
  17.302 +"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
  17.303 +unfolding Itr_def apply safe
  17.304 +apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
  17.305 +by (metis subtr_inItr)
  17.306 +
  17.307 +lemma inItr_subtr:
  17.308 +assumes "inItr ns tr n" 
  17.309 +shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
  17.310 +using assms apply(induct rule: inItr.induct) apply safe
  17.311 +  apply (metis subtr.Refl)
  17.312 +  by (metis (lifting) subtr.Step)
  17.313 +
  17.314 +corollary Itr_subtr_cont: 
  17.315 +"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
  17.316 +unfolding Itr_def apply safe
  17.317 +  apply (metis (lifting, mono_tags) UnionI inItr_subtr mem_Collect_eq vimageI2)
  17.318 +  by (metis inItr.Base subtr_inItr subtr_rootL_in)
  17.319 +
  17.320 +
  17.321 +subsection{* The immediate subtree function *}
  17.322 +
  17.323 +(* production of: *)
  17.324 +abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
  17.325 +(* subtree of: *)
  17.326 +definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
  17.327 +
  17.328 +lemma subtrOf: 
  17.329 +assumes n: "Inr n \<in> prodOf tr"
  17.330 +shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
  17.331 +proof-
  17.332 +  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
  17.333 +  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
  17.334 +  thus ?thesis unfolding subtrOf_def by(rule someI)
  17.335 +qed
  17.336 +
  17.337 +lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
  17.338 +lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
  17.339 +
  17.340 +lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
  17.341 +proof safe
  17.342 +  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
  17.343 +  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
  17.344 +next
  17.345 +  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
  17.346 +  by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
  17.347 +qed
  17.348 +
  17.349 +lemma root_prodOf:
  17.350 +assumes "Inr tr' \<in> cont tr"
  17.351 +shows "Inr (root tr') \<in> prodOf tr"
  17.352 +by (metis (lifting) assms image_iff sum_map.simps(2))
  17.353 +
  17.354 +
  17.355 +subsection{* Derivation trees *}  
  17.356 +
  17.357 +coinductive dtree where 
  17.358 +Tree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
  17.359 +        lift dtree (cont tr)\<rbrakk> \<Longrightarrow> dtree tr"
  17.360 +monos lift_mono
  17.361 +
  17.362 +(* destruction rules: *)
  17.363 +lemma dtree_P: 
  17.364 +assumes "dtree tr"
  17.365 +shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
  17.366 +using assms unfolding dtree.simps by auto
  17.367 +
  17.368 +lemma dtree_inj_on: 
  17.369 +assumes "dtree tr"
  17.370 +shows "inj_on root (Inr -` cont tr)"
  17.371 +using assms unfolding dtree.simps by auto
  17.372 +
  17.373 +lemma dtree_inj[simp]: 
  17.374 +assumes "dtree tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
  17.375 +shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
  17.376 +using assms dtree_inj_on unfolding inj_on_def by auto
  17.377 +
  17.378 +lemma dtree_lift: 
  17.379 +assumes "dtree tr"
  17.380 +shows "lift dtree (cont tr)"
  17.381 +using assms unfolding dtree.simps by auto
  17.382 +
  17.383 +
  17.384 +(* coinduction:*)
  17.385 +lemma dtree_coind[elim, consumes 1, case_names Hyp]: 
  17.386 +assumes phi: "\<phi> tr"
  17.387 +and Hyp: 
  17.388 +"\<And> tr. \<phi> tr \<Longrightarrow> 
  17.389 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and> 
  17.390 +       inj_on root (Inr -` cont tr) \<and> 
  17.391 +       lift (\<lambda> tr. \<phi> tr \<or> dtree tr) (cont tr)"
  17.392 +shows "dtree tr"
  17.393 +apply(rule dtree.coinduct[of \<phi> tr, OF phi]) 
  17.394 +using Hyp by blast
  17.395 +
  17.396 +lemma dtree_raw_coind[elim, consumes 1, case_names Hyp]: 
  17.397 +assumes phi: "\<phi> tr"
  17.398 +and Hyp: 
  17.399 +"\<And> tr. \<phi> tr \<Longrightarrow> 
  17.400 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  17.401 +       inj_on root (Inr -` cont tr) \<and> 
  17.402 +       lift \<phi> (cont tr)"
  17.403 +shows "dtree tr"
  17.404 +using phi apply(induct rule: dtree_coind)
  17.405 +using Hyp mono_lift 
  17.406 +by (metis (mono_tags) mono_lift)
  17.407 +
  17.408 +lemma dtree_subtr_inj_on: 
  17.409 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
  17.410 +shows "inj_on root (Inr -` cont tr)"
  17.411 +using s d apply(induct rule: subtr.induct)
  17.412 +apply (metis (lifting) dtree_inj_on) by (metis dtree_lift lift_def)
  17.413 +
  17.414 +lemma dtree_subtr_P: 
  17.415 +assumes d: "dtree tr1" and s: "subtr ns tr tr1"
  17.416 +shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
  17.417 +using s d apply(induct rule: subtr.induct)
  17.418 +apply (metis (lifting) dtree_P) by (metis dtree_lift lift_def)
  17.419 +
  17.420 +lemma subtrOf_root[simp]:
  17.421 +assumes tr: "dtree tr" and cont: "Inr tr' \<in> cont tr"
  17.422 +shows "subtrOf tr (root tr') = tr'"
  17.423 +proof-
  17.424 +  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
  17.425 +  by (metis (lifting) cont root_prodOf)
  17.426 +  have "root (subtrOf tr (root tr')) = root tr'"
  17.427 +  using root_subtrOf by (metis (lifting) cont root_prodOf)
  17.428 +  thus ?thesis unfolding dtree_inj[OF tr 0 cont] .
  17.429 +qed
  17.430 +
  17.431 +lemma surj_subtrOf: 
  17.432 +assumes "dtree tr" and 0: "Inr tr' \<in> cont tr"
  17.433 +shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
  17.434 +apply(rule exI[of _ "root tr'"]) 
  17.435 +using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
  17.436 +
  17.437 +lemma dtree_subtr: 
  17.438 +assumes "dtree tr1" and "subtr ns tr tr1"
  17.439 +shows "dtree tr" 
  17.440 +proof-
  17.441 +  have "(\<exists> ns tr1. dtree tr1 \<and> subtr ns tr tr1) \<Longrightarrow> dtree tr"
  17.442 +  proof (induct rule: dtree_raw_coind)
  17.443 +    case (Hyp tr)
  17.444 +    then obtain ns tr1 where tr1: "dtree tr1" and tr_tr1: "subtr ns tr tr1" by auto
  17.445 +    show ?case unfolding lift_def proof safe
  17.446 +      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using dtree_subtr_P[OF tr1 tr_tr1] .
  17.447 +    next 
  17.448 +      show "inj_on root (Inr -` cont tr)" using dtree_subtr_inj_on[OF tr1 tr_tr1] .
  17.449 +    next
  17.450 +      fix tr' assume tr': "Inr tr' \<in> cont tr"
  17.451 +      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
  17.452 +      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
  17.453 +      thus "\<exists>ns' tr1. dtree tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
  17.454 +    qed
  17.455 +  qed
  17.456 +  thus ?thesis using assms by auto
  17.457 +qed
  17.458 +
  17.459 +
  17.460 +subsection{* Default trees *}
  17.461 +
  17.462 +(* Pick a left-hand side of a production for each nonterminal *)
  17.463 +definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
  17.464 +
  17.465 +lemma S_P: "(n, S n) \<in> P"
  17.466 +using used unfolding S_def by(rule someI_ex)
  17.467 +
  17.468 +lemma finite_S: "finite (S n)"
  17.469 +using S_P finite_in_P by auto 
  17.470 +
  17.471 +
  17.472 +(* The default tree of a nonterminal *)
  17.473 +definition deftr :: "N \<Rightarrow> Tree" where  
  17.474 +"deftr \<equiv> unfold id S"
  17.475 +
  17.476 +lemma deftr_simps[simp]:
  17.477 +"root (deftr n) = n" 
  17.478 +"cont (deftr n) = image (id \<oplus> deftr) (S n)"
  17.479 +using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S] 
  17.480 +unfolding deftr_def by simp_all
  17.481 +
  17.482 +lemmas root_deftr = deftr_simps(1)
  17.483 +lemmas cont_deftr = deftr_simps(2)
  17.484 +
  17.485 +lemma root_o_deftr[simp]: "root o deftr = id"
  17.486 +by (rule ext, auto)
  17.487 +
  17.488 +lemma dtree_deftr: "dtree (deftr n)"
  17.489 +proof-
  17.490 +  {fix tr assume "\<exists> n. tr = deftr n" hence "dtree tr"
  17.491 +   apply(induct rule: dtree_raw_coind) apply safe
  17.492 +   unfolding deftr_simps image_compose[symmetric] sum_map.comp id_o
  17.493 +   root_o_deftr sum_map.id image_id id_apply apply(rule S_P) 
  17.494 +   unfolding inj_on_def lift_def by auto   
  17.495 +  }
  17.496 +  thus ?thesis by auto
  17.497 +qed
  17.498 +
  17.499 +
  17.500 +subsection{* Hereditary substitution *}
  17.501 +
  17.502 +(* Auxiliary concept: The root-ommiting frontier: *)
  17.503 +definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
  17.504 +definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
  17.505 +
  17.506 +context 
  17.507 +fixes tr0 :: Tree 
  17.508 +begin
  17.509 +
  17.510 +definition "hsubst_r tr \<equiv> root tr"
  17.511 +definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
  17.512 +
  17.513 +(* Hereditary substitution: *)
  17.514 +definition hsubst :: "Tree \<Rightarrow> Tree" where  
  17.515 +"hsubst \<equiv> unfold hsubst_r hsubst_c"
  17.516 +
  17.517 +lemma finite_hsubst_c: "finite (hsubst_c n)"
  17.518 +unfolding hsubst_c_def by (metis finite_cont) 
  17.519 +
  17.520 +lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
  17.521 +using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
  17.522 +
  17.523 +lemma root_o_subst[simp]: "root o hsubst = root"
  17.524 +unfolding comp_def root_hsubst ..
  17.525 +
  17.526 +lemma cont_hsubst_eq[simp]:
  17.527 +assumes "root tr = root tr0"
  17.528 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
  17.529 +apply(subst id_o[symmetric, of id]) unfolding id_o
  17.530 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
  17.531 +unfolding hsubst_def hsubst_c_def using assms by simp
  17.532 +
  17.533 +lemma hsubst_eq:
  17.534 +assumes "root tr = root tr0"
  17.535 +shows "hsubst tr = hsubst tr0" 
  17.536 +apply(rule Tree_cong) using assms cont_hsubst_eq by auto
  17.537 +
  17.538 +lemma cont_hsubst_neq[simp]:
  17.539 +assumes "root tr \<noteq> root tr0"
  17.540 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
  17.541 +apply(subst id_o[symmetric, of id]) unfolding id_o
  17.542 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c] 
  17.543 +unfolding hsubst_def hsubst_c_def using assms by simp
  17.544 +
  17.545 +lemma Inl_cont_hsubst_eq[simp]:
  17.546 +assumes "root tr = root tr0"
  17.547 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
  17.548 +unfolding cont_hsubst_eq[OF assms] by simp
  17.549 +
  17.550 +lemma Inr_cont_hsubst_eq[simp]:
  17.551 +assumes "root tr = root tr0"
  17.552 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
  17.553 +unfolding cont_hsubst_eq[OF assms] by simp
  17.554 +
  17.555 +lemma Inl_cont_hsubst_neq[simp]:
  17.556 +assumes "root tr \<noteq> root tr0"
  17.557 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
  17.558 +unfolding cont_hsubst_neq[OF assms] by simp
  17.559 +
  17.560 +lemma Inr_cont_hsubst_neq[simp]:
  17.561 +assumes "root tr \<noteq> root tr0"
  17.562 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
  17.563 +unfolding cont_hsubst_neq[OF assms] by simp  
  17.564 +
  17.565 +lemma dtree_hsubst:
  17.566 +assumes tr0: "dtree tr0" and tr: "dtree tr"
  17.567 +shows "dtree (hsubst tr)"
  17.568 +proof-
  17.569 +  {fix tr1 have "(\<exists> tr. dtree tr \<and> tr1 = hsubst tr) \<Longrightarrow> dtree tr1" 
  17.570 +   proof (induct rule: dtree_raw_coind)
  17.571 +     case (Hyp tr1) then obtain tr 
  17.572 +     where dtr: "dtree tr" and tr1: "tr1 = hsubst tr" by auto
  17.573 +     show ?case unfolding lift_def tr1 proof safe
  17.574 +       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
  17.575 +       unfolding tr1 apply(cases "root tr = root tr0") 
  17.576 +       using  dtree_P[OF dtr] dtree_P[OF tr0] 
  17.577 +       by (auto simp add: image_compose[symmetric] sum_map.comp)
  17.578 +       show "inj_on root (Inr -` cont (hsubst tr))" 
  17.579 +       apply(cases "root tr = root tr0") using dtree_inj_on[OF dtr] dtree_inj_on[OF tr0] 
  17.580 +       unfolding inj_on_def by (auto, blast)
  17.581 +       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
  17.582 +       thus "\<exists>tra. dtree tra \<and> tr' = hsubst tra"
  17.583 +       apply(cases "root tr = root tr0", simp_all)
  17.584 +         apply (metis dtree_lift lift_def tr0)
  17.585 +         by (metis dtr dtree_lift lift_def)
  17.586 +     qed
  17.587 +   qed
  17.588 +  }
  17.589 +  thus ?thesis using assms by blast
  17.590 +qed 
  17.591 +
  17.592 +lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
  17.593 +unfolding inFrr_def Frr_def Fr_def by auto
  17.594 +
  17.595 +lemma inFr_hsubst_imp: 
  17.596 +assumes "inFr ns (hsubst tr) t"
  17.597 +shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
  17.598 +       inFr (ns - {root tr0}) tr t"
  17.599 +proof-
  17.600 +  {fix tr1 
  17.601 +   have "inFr ns tr1 t \<Longrightarrow> 
  17.602 +   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or> 
  17.603 +                              inFr (ns - {root tr0}) tr t))"
  17.604 +   proof(induct rule: inFr.induct)
  17.605 +     case (Base tr1 ns t tr)
  17.606 +     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
  17.607 +     by auto
  17.608 +     show ?case
  17.609 +     proof(cases "root tr1 = root tr0")
  17.610 +       case True
  17.611 +       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
  17.612 +       thus ?thesis by simp
  17.613 +     next
  17.614 +       case False
  17.615 +       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
  17.616 +       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
  17.617 +       thus ?thesis by simp
  17.618 +     qed
  17.619 +   next
  17.620 +     case (Ind tr1 ns tr1' t) note IH = Ind(4)
  17.621 +     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
  17.622 +     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
  17.623 +     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
  17.624 +     show ?case
  17.625 +     proof(cases "root tr1 = root tr0")
  17.626 +       case True
  17.627 +       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
  17.628 +       using tr1'_tr1 unfolding tr1 by auto
  17.629 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  17.630 +         assume "inFr (ns - {root tr0}) tr' t"         
  17.631 +         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
  17.632 +       qed auto
  17.633 +     next
  17.634 +       case False 
  17.635 +       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
  17.636 +       using tr1'_tr1 unfolding tr1 by auto
  17.637 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  17.638 +         assume "inFr (ns - {root tr0}) tr' t"         
  17.639 +         thus ?thesis using tr'_tr unfolding inFrr_def
  17.640 +         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1) 
  17.641 +       qed auto
  17.642 +     qed
  17.643 +   qed
  17.644 +  }
  17.645 +  thus ?thesis using assms by auto
  17.646 +qed 
  17.647 +
  17.648 +lemma inFr_hsubst_notin:
  17.649 +assumes "inFr ns tr t" and "root tr0 \<notin> ns" 
  17.650 +shows "inFr ns (hsubst tr) t"
  17.651 +using assms apply(induct rule: inFr.induct)
  17.652 +apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
  17.653 +by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
  17.654 +
  17.655 +lemma inFr_hsubst_minus:
  17.656 +assumes "inFr (ns - {root tr0}) tr t"
  17.657 +shows "inFr ns (hsubst tr) t"
  17.658 +proof-
  17.659 +  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
  17.660 +  using inFr_hsubst_notin[OF assms] by simp
  17.661 +  show ?thesis using inFr_mono[OF 1] by auto
  17.662 +qed
  17.663 +
  17.664 +lemma inFr_self_hsubst: 
  17.665 +assumes "root tr0 \<in> ns"
  17.666 +shows 
  17.667 +"inFr ns (hsubst tr0) t \<longleftrightarrow> 
  17.668 + t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
  17.669 +(is "?A \<longleftrightarrow> ?B \<or> ?C")
  17.670 +apply(intro iffI)
  17.671 +apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
  17.672 +  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
  17.673 +next
  17.674 +  assume ?C then obtain tr where 
  17.675 +  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"  
  17.676 +  unfolding inFrr_def by auto
  17.677 +  def tr1 \<equiv> "hsubst tr"
  17.678 +  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
  17.679 +  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
  17.680 +  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
  17.681 +qed
  17.682 +
  17.683 +theorem Fr_self_hsubst: 
  17.684 +assumes "root tr0 \<in> ns"
  17.685 +shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
  17.686 +using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
  17.687 +
  17.688 +end (* context *)
  17.689 +  
  17.690 +
  17.691 +subsection{* Regular trees *}
  17.692 +
  17.693 +hide_const regular
  17.694 +
  17.695 +definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
  17.696 +definition "regular tr \<equiv> \<exists> f. reg f tr"
  17.697 +
  17.698 +lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
  17.699 +unfolding reg_def using subtr_mono by (metis subset_UNIV) 
  17.700 +
  17.701 +lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
  17.702 +unfolding regular_def proof safe
  17.703 +  fix f assume f: "reg f tr"
  17.704 +  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
  17.705 +  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
  17.706 +  apply(rule exI[of _ g])
  17.707 +  using f deftr_simps(1) unfolding g_def reg_def apply safe
  17.708 +    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
  17.709 +    by (metis (full_types) inItr_subtr subtr_subtr2)
  17.710 +qed auto
  17.711 +
  17.712 +lemma reg_root: 
  17.713 +assumes "reg f tr"
  17.714 +shows "f (root tr) = tr"
  17.715 +using assms unfolding reg_def
  17.716 +by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
  17.717 +
  17.718 +
  17.719 +lemma reg_Inr_cont: 
  17.720 +assumes "reg f tr" and "Inr tr' \<in> cont tr"
  17.721 +shows "reg f tr'"
  17.722 +by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
  17.723 +
  17.724 +lemma reg_subtr: 
  17.725 +assumes "reg f tr" and "subtr ns tr' tr"
  17.726 +shows "reg f tr'"
  17.727 +using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
  17.728 +by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
  17.729 +
  17.730 +lemma regular_subtr: 
  17.731 +assumes r: "regular tr" and s: "subtr ns tr' tr"
  17.732 +shows "regular tr'"
  17.733 +using r reg_subtr[OF _ s] unfolding regular_def by auto
  17.734 +
  17.735 +lemma subtr_deftr: 
  17.736 +assumes "subtr ns tr' (deftr n)"
  17.737 +shows "tr' = deftr (root tr')"
  17.738 +proof-
  17.739 +  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
  17.740 +   apply (induct rule: subtr.induct)
  17.741 +   proof(metis (lifting) deftr_simps(1), safe) 
  17.742 +     fix tr3 ns tr1 tr2 n
  17.743 +     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
  17.744 +     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)" 
  17.745 +     and 3: "Inr tr2 \<in> cont (deftr n)"
  17.746 +     have "tr2 \<in> deftr ` UNIV" 
  17.747 +     using 3 unfolding deftr_simps image_def
  17.748 +     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr 
  17.749 +         iso_tuple_UNIV_I)
  17.750 +     then obtain n where "tr2 = deftr n" by auto
  17.751 +     thus "tr1 = deftr (root tr1)" using IH by auto
  17.752 +   qed 
  17.753 +  }
  17.754 +  thus ?thesis using assms by auto
  17.755 +qed
  17.756 +
  17.757 +lemma reg_deftr: "reg deftr (deftr n)"
  17.758 +unfolding reg_def using subtr_deftr by auto
  17.759 +
  17.760 +lemma dtree_subtrOf_Union: 
  17.761 +assumes "dtree tr" 
  17.762 +shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
  17.763 +       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
  17.764 +unfolding Union_eq Bex_def mem_Collect_eq proof safe
  17.765 +  fix x xa tr'
  17.766 +  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
  17.767 +  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
  17.768 +  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
  17.769 +    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
  17.770 +    by (metis (lifting) assms subtrOf_root tr'_tr x)
  17.771 +next
  17.772 +  fix x X n ttr
  17.773 +  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
  17.774 +  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
  17.775 +  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
  17.776 +    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
  17.777 +    using x .
  17.778 +qed
  17.779 +
  17.780 +
  17.781 +
  17.782 +
  17.783 +subsection {* Paths in a regular tree *}
  17.784 +
  17.785 +inductive path :: "(N \<Rightarrow> Tree) \<Rightarrow> N list \<Rightarrow> bool" for f where 
  17.786 +Base: "path f [n]"
  17.787 +|
  17.788 +Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk> 
  17.789 +      \<Longrightarrow> path f (n # n1 # nl)"
  17.790 +
  17.791 +lemma path_NE: 
  17.792 +assumes "path f nl"  
  17.793 +shows "nl \<noteq> Nil" 
  17.794 +using assms apply(induct rule: path.induct) by auto
  17.795 +
  17.796 +lemma path_post: 
  17.797 +assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
  17.798 +shows "path f nl"
  17.799 +proof-
  17.800 +  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
  17.801 +  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject) 
  17.802 +qed
  17.803 +
  17.804 +lemma path_post_concat: 
  17.805 +assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
  17.806 +shows "path f nl2"
  17.807 +using assms apply (induct nl1)
  17.808 +apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
  17.809 +
  17.810 +lemma path_concat: 
  17.811 +assumes "path f nl1" and "path f ((last nl1) # nl2)"
  17.812 +shows "path f (nl1 @ nl2)"
  17.813 +using assms apply(induct rule: path.induct) apply simp
  17.814 +by (metis append_Cons last.simps list.simps(3) path.Ind) 
  17.815 +
  17.816 +lemma path_distinct:
  17.817 +assumes "path f nl"
  17.818 +shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and> 
  17.819 +              set nl' \<subseteq> set nl \<and> distinct nl'"
  17.820 +using assms proof(induct rule: length_induct)
  17.821 +  case (1 nl)  hence p_nl: "path f nl" by simp
  17.822 +  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE) 
  17.823 +  show ?case
  17.824 +  proof(cases nl1)
  17.825 +    case Nil
  17.826 +    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
  17.827 +  next
  17.828 +    case (Cons n1 nl2)  
  17.829 +    hence p1: "path f nl1" by (metis list.simps nl p_nl path_post)
  17.830 +    show ?thesis
  17.831 +    proof(cases "n \<in> set nl1")
  17.832 +      case False
  17.833 +      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and 
  17.834 +      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'" 
  17.835 +      and s_nl1': "set nl1' \<subseteq> set nl1"
  17.836 +      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
  17.837 +      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
  17.838 +      unfolding Cons by(cases nl1', auto)
  17.839 +      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
  17.840 +        show "path f (n # nl1')" unfolding nl1' 
  17.841 +        apply(rule path.Ind, metis nl1' p1')
  17.842 +        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
  17.843 +      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
  17.844 +    next
  17.845 +      case True
  17.846 +      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12" 
  17.847 +      by (metis split_list) 
  17.848 +      have p12: "path f (n # nl12)" 
  17.849 +      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
  17.850 +      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and 
  17.851 +      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'" 
  17.852 +      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
  17.853 +      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
  17.854 +      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
  17.855 +    qed
  17.856 +  qed
  17.857 +qed
  17.858 +
  17.859 +lemma path_subtr: 
  17.860 +assumes f: "\<And> n. root (f n) = n"
  17.861 +and p: "path f nl"
  17.862 +shows "subtr (set nl) (f (last nl)) (f (hd nl))"
  17.863 +using p proof (induct rule: path.induct)
  17.864 +  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
  17.865 +  have "path f (n1 # nl)"
  17.866 +  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
  17.867 +  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
  17.868 +  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
  17.869 +  by (metis subset_insertI subtr_mono) 
  17.870 +  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
  17.871 +  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)" 
  17.872 +  using f subtr.Step[OF _ fn1_flast fn1] by auto 
  17.873 +  thus ?case unfolding 1 by simp 
  17.874 +qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
  17.875 +
  17.876 +lemma reg_subtr_path_aux:
  17.877 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  17.878 +shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  17.879 +using n f proof(induct rule: subtr.induct)
  17.880 +  case (Refl tr ns)
  17.881 +  thus ?case
  17.882 +  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
  17.883 +next
  17.884 +  case (Step tr ns tr2 tr1)
  17.885 +  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr" 
  17.886 +  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
  17.887 +  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
  17.888 +  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
  17.889 +  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1" 
  17.890 +  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
  17.891 +  have 0: "path f (root tr # nl)" apply (subst path.simps)
  17.892 +  using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv) 
  17.893 +  show ?case apply(rule exI[of _ "(root tr) # nl"])
  17.894 +  using 0 reg_root tr last_nl nl path_NE rtr set by auto
  17.895 +qed 
  17.896 +
  17.897 +lemma reg_subtr_path:
  17.898 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  17.899 +shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  17.900 +using reg_subtr_path_aux[OF assms] path_distinct[of f]
  17.901 +by (metis (lifting) order_trans)
  17.902 +
  17.903 +lemma subtr_iff_path:
  17.904 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  17.905 +shows "subtr ns tr1 tr \<longleftrightarrow> 
  17.906 +       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
  17.907 +proof safe
  17.908 +  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
  17.909 +  have "subtr (set nl) (f (last nl)) (f (hd nl))"
  17.910 +  apply(rule path_subtr) using p f by simp_all
  17.911 +  thus "subtr ns (f (last nl)) (f (hd nl))"
  17.912 +  using subtr_mono nl by auto
  17.913 +qed(insert reg_subtr_path[OF r], auto)
  17.914 +
  17.915 +lemma inFr_iff_path:
  17.916 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  17.917 +shows 
  17.918 +"inFr ns tr t \<longleftrightarrow> 
  17.919 + (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> 
  17.920 +            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)" 
  17.921 +apply safe
  17.922 +apply (metis (no_types) inFr_subtr r reg_subtr_path)
  17.923 +by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
  17.924 +
  17.925 +
  17.926 +
  17.927 +subsection{* The regular cut of a tree *}
  17.928 +
  17.929 +context fixes tr0 :: Tree
  17.930 +begin
  17.931 +
  17.932 +(* Picking a subtree of a certain root: *)
  17.933 +definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n" 
  17.934 +
  17.935 +lemma pick:
  17.936 +assumes "inItr UNIV tr0 n"
  17.937 +shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
  17.938 +proof-
  17.939 +  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n" 
  17.940 +  using assms by (metis (lifting) inItr_subtr)
  17.941 +  thus ?thesis unfolding pick_def by(rule someI_ex)
  17.942 +qed 
  17.943 +
  17.944 +lemmas subtr_pick = pick[THEN conjunct1]
  17.945 +lemmas root_pick = pick[THEN conjunct2]
  17.946 +
  17.947 +lemma dtree_pick:
  17.948 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
  17.949 +shows "dtree (pick n)"
  17.950 +using dtree_subtr[OF tr0 subtr_pick[OF n]] .
  17.951 +
  17.952 +definition "regOf_r n \<equiv> root (pick n)"
  17.953 +definition "regOf_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
  17.954 +
  17.955 +(* The regular tree of a function: *)
  17.956 +definition regOf :: "N \<Rightarrow> Tree" where  
  17.957 +"regOf \<equiv> unfold regOf_r regOf_c"
  17.958 +
  17.959 +lemma finite_regOf_c: "finite (regOf_c n)"
  17.960 +unfolding regOf_c_def by (metis finite_cont finite_imageI) 
  17.961 +
  17.962 +lemma root_regOf_pick: "root (regOf n) = root (pick n)"
  17.963 +using unfold(1)[of regOf_r regOf_c n] unfolding regOf_def regOf_r_def by simp
  17.964 +
  17.965 +lemma root_regOf[simp]: 
  17.966 +assumes "inItr UNIV tr0 n"
  17.967 +shows "root (regOf n) = n"
  17.968 +unfolding root_regOf_pick root_pick[OF assms] ..
  17.969 +
  17.970 +lemma cont_regOf[simp]: 
  17.971 +"cont (regOf n) = (id \<oplus> (regOf o root)) ` cont (pick n)"
  17.972 +apply(subst id_o[symmetric, of id]) unfolding sum_map.comp[symmetric]
  17.973 +unfolding image_compose unfolding regOf_c_def[symmetric]
  17.974 +using unfold(2)[of regOf_c n regOf_r, OF finite_regOf_c] 
  17.975 +unfolding regOf_def ..
  17.976 +
  17.977 +lemma Inl_cont_regOf[simp]:
  17.978 +"Inl -` (cont (regOf n)) = Inl -` (cont (pick n))" 
  17.979 +unfolding cont_regOf by simp
  17.980 +
  17.981 +lemma Inr_cont_regOf:
  17.982 +"Inr -` (cont (regOf n)) = (regOf \<circ> root) ` (Inr -` cont (pick n))"
  17.983 +unfolding cont_regOf by simp
  17.984 +
  17.985 +lemma subtr_regOf: 
  17.986 +assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (regOf n)"
  17.987 +shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1"
  17.988 +proof-
  17.989 +  {fix tr ns assume "subtr UNIV tr1 tr"
  17.990 +   hence "tr = regOf n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = regOf n1)"
  17.991 +   proof (induct rule: subtr_UNIV_inductL) 
  17.992 +     case (Step tr2 tr1 tr) 
  17.993 +     show ?case proof
  17.994 +       assume "tr = regOf n"
  17.995 +       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
  17.996 +       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = regOf n1"
  17.997 +       using Step by auto
  17.998 +       obtain tr2' where tr2: "tr2 = regOf (root tr2')" 
  17.999 +       and tr2': "Inr tr2' \<in> cont (pick n1)"
 17.1000 +       using tr2 Inr_cont_regOf[of n1] 
 17.1001 +       unfolding tr1 image_def o_def using vimage_eq by auto
 17.1002 +       have "inItr UNIV tr0 (root tr2')" 
 17.1003 +       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
 17.1004 +       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = regOf n2" using tr2 by blast
 17.1005 +     qed
 17.1006 +   qed(insert n, auto)
 17.1007 +  }
 17.1008 +  thus ?thesis using assms by auto
 17.1009 +qed
 17.1010 +
 17.1011 +lemma root_regOf_root: 
 17.1012 +assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
 17.1013 +shows "(id \<oplus> (root \<circ> regOf \<circ> root)) t_tr = (id \<oplus> root) t_tr"
 17.1014 +using assms apply(cases t_tr)
 17.1015 +  apply (metis (lifting) sum_map.simps(1))
 17.1016 +  using pick regOf_def regOf_r_def unfold(1) 
 17.1017 +      inItr.Base o_apply subtr_StepL subtr_inItr sum_map.simps(2)
 17.1018 +  by (metis UNIV_I)
 17.1019 +
 17.1020 +lemma regOf_P: 
 17.1021 +assumes tr0: "dtree tr0" and n: "inItr UNIV tr0 n" 
 17.1022 +shows "(n, (id \<oplus> root) ` cont (regOf n)) \<in> P" (is "?L \<in> P")
 17.1023 +proof- 
 17.1024 +  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
 17.1025 +  unfolding cont_regOf image_compose[symmetric] sum_map.comp id_o o_assoc
 17.1026 +  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
 17.1027 +  by(rule root_regOf_root[OF n])
 17.1028 +  moreover have "... \<in> P" by (metis (lifting) dtree_pick root_pick dtree_P n tr0) 
 17.1029 +  ultimately show ?thesis by simp
 17.1030 +qed
 17.1031 +
 17.1032 +lemma dtree_regOf:
 17.1033 +assumes tr0: "dtree tr0" and "inItr UNIV tr0 n" 
 17.1034 +shows "dtree (regOf n)"
 17.1035 +proof-
 17.1036 +  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = regOf n \<Longrightarrow> dtree tr" 
 17.1037 +   proof (induct rule: dtree_raw_coind)
 17.1038 +     case (Hyp tr) 
 17.1039 +     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" by auto
 17.1040 +     show ?case unfolding lift_def apply safe
 17.1041 +     apply (metis (lifting) regOf_P root_regOf n tr tr0)
 17.1042 +     unfolding tr Inr_cont_regOf unfolding inj_on_def apply clarsimp using root_regOf 
 17.1043 +     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
 17.1044 +     by (metis n subtr.Refl subtr_StepL subtr_regOf tr UNIV_I)
 17.1045 +   qed   
 17.1046 +  }
 17.1047 +  thus ?thesis using assms by blast
 17.1048 +qed
 17.1049 +
 17.1050 +(* The regular cut of a tree: *)   
 17.1051 +definition "rcut \<equiv> regOf (root tr0)"
 17.1052 +
 17.1053 +theorem reg_rcut: "reg regOf rcut"
 17.1054 +unfolding reg_def rcut_def 
 17.1055 +by (metis inItr.Base root_regOf subtr_regOf UNIV_I) 
 17.1056 +
 17.1057 +lemma rcut_reg:
 17.1058 +assumes "reg regOf tr0" 
 17.1059 +shows "rcut = tr0"
 17.1060 +using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
 17.1061 +
 17.1062 +theorem rcut_eq: "rcut = tr0 \<longleftrightarrow> reg regOf tr0"
 17.1063 +using reg_rcut rcut_reg by metis
 17.1064 +
 17.1065 +theorem regular_rcut: "regular rcut"
 17.1066 +using reg_rcut unfolding regular_def by blast
 17.1067 +
 17.1068 +theorem Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
 17.1069 +proof safe
 17.1070 +  fix t assume "t \<in> Fr UNIV rcut"
 17.1071 +  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (regOf (root tr0))"
 17.1072 +  using Fr_subtr[of UNIV "regOf (root tr0)"] unfolding rcut_def
 17.1073 +  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq) 
 17.1074 +  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = regOf n" using tr
 17.1075 +  by (metis (lifting) inItr.Base subtr_regOf UNIV_I)
 17.1076 +  have "Inl t \<in> cont (pick n)" using t using Inl_cont_regOf[of n] unfolding tr
 17.1077 +  by (metis (lifting) vimageD vimageI2) 
 17.1078 +  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
 17.1079 +  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
 17.1080 +qed
 17.1081 +
 17.1082 +theorem dtree_rcut: 
 17.1083 +assumes "dtree tr0"
 17.1084 +shows "dtree rcut" 
 17.1085 +unfolding rcut_def using dtree_regOf[OF assms inItr.Base] by simp
 17.1086 +
 17.1087 +theorem root_rcut[simp]: "root rcut = root tr0" 
 17.1088 +unfolding rcut_def
 17.1089 +by (metis (lifting) root_regOf inItr.Base reg_def reg_root subtr_rootR_in) 
 17.1090 +
 17.1091 +end (* context *)
 17.1092 +
 17.1093 +
 17.1094 +subsection{* Recursive description of the regular tree frontiers *} 
 17.1095 +
 17.1096 +lemma regular_inFr:
 17.1097 +assumes r: "regular tr" and In: "root tr \<in> ns"
 17.1098 +and t: "inFr ns tr t"
 17.1099 +shows "t \<in> Inl -` (cont tr) \<or> 
 17.1100 +       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
 17.1101 +(is "?L \<or> ?R")
 17.1102 +proof-
 17.1103 +  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n" 
 17.1104 +  using r unfolding regular_def2 by auto
 17.1105 +  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr" 
 17.1106 +  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1" 
 17.1107 +  using t unfolding inFr_iff_path[OF r f] by auto
 17.1108 +  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps) 
 17.1109 +  hence f_n: "f n = tr" using hd_nl by simp
 17.1110 +  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
 17.1111 +  show ?thesis
 17.1112 +  proof(cases nl1)
 17.1113 +    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
 17.1114 +    hence ?L using t_tr1 by simp thus ?thesis by simp
 17.1115 +  next
 17.1116 +    case (Cons n1 nl2) note nl1 = Cons
 17.1117 +    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
 17.1118 +    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr" 
 17.1119 +    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
 17.1120 +    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
 17.1121 +    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
 17.1122 +    apply(intro exI[of _ nl1], intro exI[of _ tr1])
 17.1123 +    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
 17.1124 +    have root_tr: "root tr = n" by (metis f f_n) 
 17.1125 +    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
 17.1126 +    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
 17.1127 +    thus ?thesis using n1_tr by auto
 17.1128 +  qed
 17.1129 +qed
 17.1130 + 
 17.1131 +theorem regular_Fr: 
 17.1132 +assumes r: "regular tr" and In: "root tr \<in> ns"
 17.1133 +shows "Fr ns tr = 
 17.1134 +       Inl -` (cont tr) \<union> 
 17.1135 +       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
 17.1136 +unfolding Fr_def 
 17.1137 +using In inFr.Base regular_inFr[OF assms] apply safe
 17.1138 +apply (simp, metis (full_types) UnionI mem_Collect_eq)
 17.1139 +apply simp
 17.1140 +by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
 17.1141 +
 17.1142 +
 17.1143 +subsection{* The generated languages *} 
 17.1144 +
 17.1145 +(* The (possibly inifinite tree) generated language *)
 17.1146 +definition "L ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n}"
 17.1147 +
 17.1148 +(* The regular-tree generated language *)
 17.1149 +definition "Lr ns n \<equiv> {Fr ns tr | tr. dtree tr \<and> root tr = n \<and> regular tr}"
 17.1150 +
 17.1151 +theorem L_rec_notin:
 17.1152 +assumes "n \<notin> ns"
 17.1153 +shows "L ns n = {{}}"
 17.1154 +using assms unfolding L_def apply safe 
 17.1155 +  using not_root_Fr apply force
 17.1156 +  apply(rule exI[of _ "deftr n"])
 17.1157 +  by (metis (no_types) dtree_deftr not_root_Fr root_deftr)
 17.1158 +
 17.1159 +theorem Lr_rec_notin:
 17.1160 +assumes "n \<notin> ns"
 17.1161 +shows "Lr ns n = {{}}"
 17.1162 +using assms unfolding Lr_def apply safe
 17.1163 +  using not_root_Fr apply force
 17.1164 +  apply(rule exI[of _ "deftr n"])
 17.1165 +  by (metis (no_types) regular_def dtree_deftr not_root_Fr reg_deftr root_deftr)
 17.1166 +
 17.1167 +lemma dtree_subtrOf: 
 17.1168 +assumes "dtree tr" and "Inr n \<in> prodOf tr"
 17.1169 +shows "dtree (subtrOf tr n)"
 17.1170 +by (metis assms dtree_lift lift_def subtrOf) 
 17.1171 +  
 17.1172 +theorem Lr_rec_in: 
 17.1173 +assumes n: "n \<in> ns"
 17.1174 +shows "Lr ns n \<subseteq> 
 17.1175 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 17.1176 +    (n,tns) \<in> P \<and> 
 17.1177 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
 17.1178 +(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
 17.1179 +proof safe
 17.1180 +  fix ts assume "ts \<in> Lr ns n"
 17.1181 +  then obtain tr where dtr: "dtree tr" and r: "root tr = n" and tr: "regular tr"
 17.1182 +  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
 17.1183 +  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
 17.1184 +  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
 17.1185 +  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
 17.1186 +  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
 17.1187 +    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
 17.1188 +    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
 17.1189 +    unfolding tns_def K_def r[symmetric]
 17.1190 +    unfolding Inl_prodOf dtree_subtrOf_Union[OF dtr] ..
 17.1191 +    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using dtree_P[OF dtr] .
 17.1192 +    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
 17.1193 +    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
 17.1194 +    using dtr tr apply(intro conjI refl)  unfolding tns_def
 17.1195 +      apply(erule dtree_subtrOf[OF dtr])
 17.1196 +      apply (metis subtrOf)
 17.1197 +      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
 17.1198 +  qed
 17.1199 +qed 
 17.1200 +
 17.1201 +lemma hsubst_aux: 
 17.1202 +fixes n ftr tns
 17.1203 +assumes n: "n \<in> ns" and tns: "finite tns" and 
 17.1204 +1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> dtree (ftr n')"
 17.1205 +defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
 17.1206 +shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 17.1207 +(is "_ = ?B") proof-
 17.1208 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 17.1209 +  unfolding tr_def using tns by auto
 17.1210 +  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 17.1211 +  unfolding Frr_def ctr by auto
 17.1212 +  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
 17.1213 +  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
 17.1214 +  also have "... = ?B" unfolding ctr Frr by simp
 17.1215 +  finally show ?thesis .
 17.1216 +qed
 17.1217 +
 17.1218 +theorem L_rec_in: 
 17.1219 +assumes n: "n \<in> ns"
 17.1220 +shows "
 17.1221 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 17.1222 +    (n,tns) \<in> P \<and> 
 17.1223 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')} 
 17.1224 + \<subseteq> L ns n"
 17.1225 +proof safe
 17.1226 +  fix tns K
 17.1227 +  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
 17.1228 +  {fix n' assume "Inr n' \<in> tns"
 17.1229 +   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
 17.1230 +   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> dtree tr' \<and> root tr' = n'"
 17.1231 +   unfolding L_def mem_Collect_eq by auto
 17.1232 +  }
 17.1233 +  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>  
 17.1234 +  K n' = Fr (ns - {n}) (ftr n') \<and> dtree (ftr n') \<and> root (ftr n') = n'"
 17.1235 +  by metis
 17.1236 +  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
 17.1237 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 17.1238 +  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
 17.1239 +  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong) 
 17.1240 +  unfolding ctr apply simp apply simp apply safe 
 17.1241 +  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)     
 17.1242 +  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 17.1243 +  using 0 by auto
 17.1244 +  have dtr: "dtree tr" apply(rule dtree.Tree)
 17.1245 +    apply (metis (lifting) P prtr rtr) 
 17.1246 +    unfolding inj_on_def ctr lift_def using 0 by auto
 17.1247 +  hence dtr': "dtree tr'" unfolding tr'_def by (metis dtree_hsubst)
 17.1248 +  have tns: "finite tns" using finite_in_P P by simp
 17.1249 +  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
 17.1250 +  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
 17.1251 +  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
 17.1252 +  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
 17.1253 +qed
 17.1254 +
 17.1255 +lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns" 
 17.1256 +by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
 17.1257 +
 17.1258 +function LL where 
 17.1259 +"LL ns n = 
 17.1260 + (if n \<notin> ns then {{}} else 
 17.1261 + {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K. 
 17.1262 +    (n,tns) \<in> P \<and> 
 17.1263 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
 17.1264 +by(pat_completeness, auto)
 17.1265 +termination apply(relation "inv_image (measure card) fst") 
 17.1266 +using card_N by auto
 17.1267 +
 17.1268 +declare LL.simps[code]  (* TODO: Does code generation for LL work? *)
 17.1269 +declare LL.simps[simp del]
 17.1270 +
 17.1271 +theorem Lr_LL: "Lr ns n \<subseteq> LL ns n" 
 17.1272 +proof (induct ns arbitrary: n rule: measure_induct[of card]) 
 17.1273 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 17.1274 +    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
 17.1275 +  next
 17.1276 +    case True show ?thesis apply(rule subset_trans)
 17.1277 +    using Lr_rec_in[OF True] apply assumption 
 17.1278 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 17.1279 +      fix tns K
 17.1280 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 17.1281 +      assume "(n, tns) \<in> P" 
 17.1282 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
 17.1283 +      thus "\<exists>tnsa Ka.
 17.1284 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 17.1285 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 17.1286 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
 17.1287 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 17.1288 +    qed
 17.1289 +  qed
 17.1290 +qed
 17.1291 +
 17.1292 +theorem LL_L: "LL ns n \<subseteq> L ns n" 
 17.1293 +proof (induct ns arbitrary: n rule: measure_induct[of card]) 
 17.1294 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 17.1295 +    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
 17.1296 +  next
 17.1297 +    case True show ?thesis apply(rule subset_trans)
 17.1298 +    prefer 2 using L_rec_in[OF True] apply assumption 
 17.1299 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 17.1300 +      fix tns K
 17.1301 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 17.1302 +      assume "(n, tns) \<in> P" 
 17.1303 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
 17.1304 +      thus "\<exists>tnsa Ka.
 17.1305 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 17.1306 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 17.1307 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
 17.1308 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 17.1309 +    qed
 17.1310 +  qed
 17.1311 +qed
 17.1312 +
 17.1313 +(* The subsumpsion relation between languages *)
 17.1314 +definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
 17.1315 +
 17.1316 +lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
 17.1317 +unfolding subs_def by auto
 17.1318 +
 17.1319 +lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
 17.1320 +
 17.1321 +lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3" 
 17.1322 +unfolding subs_def by (metis subset_trans) 
 17.1323 +
 17.1324 +(* Language equivalence *)
 17.1325 +definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
 17.1326 +
 17.1327 +lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
 17.1328 +unfolding leqv_def by auto
 17.1329 +
 17.1330 +lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
 17.1331 +unfolding leqv_def by auto
 17.1332 +
 17.1333 +lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
 17.1334 +
 17.1335 +lemma leqv_trans: 
 17.1336 +assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
 17.1337 +shows "leqv L1 L3"
 17.1338 +using assms unfolding leqv_def by (metis (lifting) subs_trans) 
 17.1339 +
 17.1340 +lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
 17.1341 +unfolding leqv_def by auto
 17.1342 +
 17.1343 +lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
 17.1344 +unfolding leqv_def by auto
 17.1345 +
 17.1346 +lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
 17.1347 +unfolding Lr_def L_def by auto
 17.1348 +
 17.1349 +lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
 17.1350 +unfolding subs_def proof safe
 17.1351 +  fix ts2 assume "ts2 \<in> L UNIV ts"
 17.1352 +  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "dtree tr" and rtr: "root tr = ts" 
 17.1353 +  unfolding L_def by auto
 17.1354 +  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
 17.1355 +  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
 17.1356 +  unfolding Lr_def L_def using Fr_rcut dtree_rcut root_rcut regular_rcut by auto
 17.1357 +qed
 17.1358 +
 17.1359 +theorem Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
 17.1360 +using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
 17.1361 +
 17.1362 +theorem LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
 17.1363 +by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
 17.1364 +
 17.1365 +theorem LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
 17.1366 +using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
 17.1367 +
 17.1368 +
 17.1369 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy	Fri Sep 21 16:45:06 2012 +0200
    18.3 @@ -0,0 +1,152 @@
    18.4 +(*  Title:      HOL/BNF/Examples/Infinite_Derivation_Trees/Parallel.thy
    18.5 +    Author:     Andrei Popescu, TU Muenchen
    18.6 +    Copyright   2012
    18.7 +
    18.8 +Parallel composition.
    18.9 +*)
   18.10 +
   18.11 +header {* Parallel Composition *}
   18.12 +
   18.13 +theory Parallel 
   18.14 +imports Tree
   18.15 +begin
   18.16 +
   18.17 +
   18.18 +consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
   18.19 +
   18.20 +axiomatization where 
   18.21 +    Nplus_comm: "(a::N) + b = b + (a::N)"
   18.22 +and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
   18.23 +
   18.24 +
   18.25 +
   18.26 +section{* Parallel composition *} 
   18.27 +
   18.28 +fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
   18.29 +fun par_c where 
   18.30 +"par_c (tr1,tr2) = 
   18.31 + Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union> 
   18.32 + Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   18.33 +
   18.34 +declare par_r.simps[simp del]  declare par_c.simps[simp del]
   18.35 +
   18.36 +definition par :: "Tree \<times> Tree \<Rightarrow> Tree" where  
   18.37 +"par \<equiv> unfold par_r par_c"
   18.38 +
   18.39 +abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
   18.40 +
   18.41 +lemma finite_par_c: "finite (par_c (tr1, tr2))"
   18.42 +unfolding par_c.simps apply(rule finite_UnI)
   18.43 +  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
   18.44 +  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
   18.45 +  using finite_cont by auto
   18.46 +
   18.47 +lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
   18.48 +using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
   18.49 +
   18.50 +lemma cont_par: 
   18.51 +"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
   18.52 +using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
   18.53 +unfolding par_def ..
   18.54 +
   18.55 +lemma Inl_cont_par[simp]:
   18.56 +"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)" 
   18.57 +unfolding cont_par par_c.simps by auto
   18.58 +
   18.59 +lemma Inr_cont_par[simp]:
   18.60 +"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)" 
   18.61 +unfolding cont_par par_c.simps by auto
   18.62 +
   18.63 +lemma Inl_in_cont_par:
   18.64 +"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
   18.65 +using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
   18.66 +
   18.67 +lemma Inr_in_cont_par:
   18.68 +"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
   18.69 +using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
   18.70 +
   18.71 +
   18.72 +section{* =-coinductive proofs *}
   18.73 +
   18.74 +(* Detailed proofs of commutativity and associativity: *)
   18.75 +theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
   18.76 +proof-
   18.77 +  let ?\<phi> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
   18.78 +  {fix trA trB
   18.79 +   assume "?\<phi> trA trB" hence "trA = trB"
   18.80 +   proof (induct rule: Tree_coind, safe)
   18.81 +     fix tr1 tr2 
   18.82 +     show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)" 
   18.83 +     unfolding root_par by (rule Nplus_comm)
   18.84 +   next
   18.85 +     fix tr1 tr2 :: Tree
   18.86 +     let ?trA = "tr1 \<parallel> tr2"  let ?trB = "tr2 \<parallel> tr1"
   18.87 +     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
   18.88 +     unfolding lift2_def proof(intro conjI allI impI)
   18.89 +       fix n show "Inl n \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> Inl n \<in> cont (tr2 \<parallel> tr1)"
   18.90 +       unfolding Inl_in_cont_par by auto
   18.91 +     next
   18.92 +       fix trA' assume "Inr trA' \<in> cont ?trA"
   18.93 +       then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
   18.94 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   18.95 +       unfolding Inr_in_cont_par by auto
   18.96 +       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
   18.97 +       apply(intro exI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   18.98 +     next
   18.99 +       fix trB' assume "Inr trB' \<in> cont ?trB"
  18.100 +       then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
  18.101 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  18.102 +       unfolding Inr_in_cont_par by auto
  18.103 +       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
  18.104 +       apply(intro exI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
  18.105 +     qed
  18.106 +   qed
  18.107 +  }
  18.108 +  thus ?thesis by blast
  18.109 +qed
  18.110 +
  18.111 +theorem par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
  18.112 +proof-
  18.113 +  let ?\<phi> = 
  18.114 +  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> 
  18.115 +                             trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  18.116 +  {fix trA trB
  18.117 +   assume "?\<phi> trA trB" hence "trA = trB"
  18.118 +   proof (induct rule: Tree_coind, safe)
  18.119 +     fix tr1 tr2 tr3 
  18.120 +     show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))" 
  18.121 +     unfolding root_par by (rule Nplus_assoc)
  18.122 +   next
  18.123 +     fix tr1 tr2 tr3 
  18.124 +     let ?trA = "(tr1 \<parallel> tr2) \<parallel> tr3"  let ?trB = "tr1 \<parallel> (tr2 \<parallel> tr3)"
  18.125 +     show "(?\<phi> ^#2) (cont ?trA) (cont ?trB)"
  18.126 +     unfolding lift2_def proof(intro conjI allI impI)
  18.127 +       fix n show "Inl n \<in> (cont ?trA) \<longleftrightarrow> Inl n \<in> (cont ?trB)"
  18.128 +       unfolding Inl_in_cont_par by simp
  18.129 +     next
  18.130 +       fix trA' assume "Inr trA' \<in> cont ?trA"
  18.131 +       then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
  18.132 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  18.133 +       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  18.134 +       thus "\<exists> trB'. Inr trB' \<in> cont ?trB \<and> ?\<phi> trA' trB'"
  18.135 +       apply(intro exI[of _ "tr1' \<parallel> (tr2' \<parallel> tr3')"]) 
  18.136 +       unfolding Inr_in_cont_par by auto
  18.137 +     next
  18.138 +       fix trB' assume "Inr trB' \<in> cont ?trB"
  18.139 +       then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
  18.140 +       and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  18.141 +       and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  18.142 +       thus "\<exists> trA'. Inr trA' \<in> cont ?trA \<and> ?\<phi> trA' trB'"
  18.143 +       apply(intro exI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"]) 
  18.144 +       unfolding Inr_in_cont_par by auto
  18.145 +     qed
  18.146 +   qed
  18.147 +  }
  18.148 +  thus ?thesis by blast
  18.149 +qed
  18.150 +
  18.151 +
  18.152 +
  18.153 +
  18.154 +
  18.155 +end
  18.156 \ No newline at end of file
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy	Fri Sep 21 16:45:06 2012 +0200
    19.3 @@ -0,0 +1,67 @@
    19.4 +(*  Title:      HOL/BNF/Examples/Infinite_Derivation_Trees/Prelim.thy
    19.5 +    Author:     Andrei Popescu, TU Muenchen
    19.6 +    Copyright   2012
    19.7 +
    19.8 +Preliminaries.
    19.9 +*)
   19.10 +
   19.11 +header {* Preliminaries *}
   19.12 +
   19.13 +theory Prelim
   19.14 +imports "../../BNF"
   19.15 +begin
   19.16 +
   19.17 +declare fset_to_fset[simp]
   19.18 +
   19.19 +lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
   19.20 +apply(rule ext) by (simp add: convol_def)
   19.21 +
   19.22 +abbreviation sm_abbrev (infix "\<oplus>" 60) 
   19.23 +where "f \<oplus> g \<equiv> Sum_Type.sum_map f g" 
   19.24 +
   19.25 +lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
   19.26 +by (cases z) auto
   19.27 +
   19.28 +lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
   19.29 +by (cases z) auto
   19.30 +
   19.31 +abbreviation sum_case_abbrev ("[[_,_]]" 800)
   19.32 +where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
   19.33 +
   19.34 +lemma inj_Inl[simp]: "inj Inl" unfolding inj_on_def by auto
   19.35 +lemma inj_Inr[simp]: "inj Inr" unfolding inj_on_def by auto
   19.36 +
   19.37 +lemma Inl_oplus_elim:
   19.38 +assumes "Inl tr \<in> (id \<oplus> f) ` tns"
   19.39 +shows "Inl tr \<in> tns"
   19.40 +using assms apply clarify by (case_tac x, auto)
   19.41 +
   19.42 +lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
   19.43 +using Inl_oplus_elim
   19.44 +by (metis id_def image_iff sum_map.simps(1))
   19.45 +
   19.46 +lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
   19.47 +using Inl_oplus_iff unfolding vimage_def by auto
   19.48 +
   19.49 +lemma Inr_oplus_elim:
   19.50 +assumes "Inr tr \<in> (id \<oplus> f) ` tns"
   19.51 +shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
   19.52 +using assms apply clarify by (case_tac x, auto)
   19.53 +
   19.54 +lemma Inr_oplus_iff[simp]: 
   19.55 +"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
   19.56 +apply (rule iffI)
   19.57 + apply (metis Inr_oplus_elim)
   19.58 +by (metis image_iff sum_map.simps(2))
   19.59 +
   19.60 +lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
   19.61 +using Inr_oplus_iff unfolding vimage_def by auto
   19.62 +
   19.63 +lemma Inl_Inr_image_cong:
   19.64 +assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
   19.65 +shows "A = B"
   19.66 +apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
   19.67 +
   19.68 +
   19.69 +
   19.70 +end
   19.71 \ No newline at end of file
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy	Fri Sep 21 16:45:06 2012 +0200
    20.3 @@ -0,0 +1,326 @@
    20.4 +(*  Title:      HOL/BNF/Examples/Infinite_Derivation_Trees/Tree.thy
    20.5 +    Author:     Andrei Popescu, TU Muenchen
    20.6 +    Copyright   2012
    20.7 +
    20.8 +Trees with nonterminal internal nodes and terminal leaves.
    20.9 +*)
   20.10 +
   20.11 +header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
   20.12 +
   20.13 +theory Tree
   20.14 +imports Prelim
   20.15 +begin
   20.16 +
   20.17 +hide_fact (open) Quotient_Product.prod_rel_def
   20.18 +
   20.19 +typedecl N  typedecl T
   20.20 +
   20.21 +codata_raw Tree: 'Tree = "N \<times> (T + 'Tree) fset"
   20.22 +
   20.23 +
   20.24 +section {* Sugar notations for Tree *}
   20.25 +
   20.26 +subsection{* Setup for map, set, rel *}
   20.27 +
   20.28 +(* These should be eventually inferred from compositionality *)
   20.29 +
   20.30 +lemma pre_Tree_map:
   20.31 +"pre_Tree_map f (n, as) = (n, map_fset (id \<oplus> f) as)"
   20.32 +unfolding pre_Tree_map_def id_apply
   20.33 +sum_map_def by simp
   20.34 +
   20.35 +lemma pre_Tree_map':
   20.36 +"pre_Tree_map f n_as = (fst n_as, map_fset (id \<oplus> f) (snd n_as))"
   20.37 +using pre_Tree_map by(cases n_as, simp)
   20.38 +
   20.39 +
   20.40 +definition
   20.41 +"llift2 \<phi> as1 as2 \<longleftrightarrow>
   20.42 + (\<forall> n. Inl n \<in> fset as1 \<longleftrightarrow> Inl n \<in> fset as2) \<and>
   20.43 + (\<forall> tr1. Inr tr1 \<in> fset as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> fset as2 \<and> \<phi> tr1 tr2)) \<and>
   20.44 + (\<forall> tr2. Inr tr2 \<in> fset as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> fset as1 \<and> \<phi> tr1 tr2))"
   20.45 +
   20.46 +lemma pre_Tree_rel: "pre_Tree_rel \<phi> (n1,as1) (n2,as2) \<longleftrightarrow> n1 = n2 \<and> llift2 \<phi> as1 as2"
   20.47 +unfolding llift2_def pre_Tree_rel_def sum_rel_def[abs_def] prod_rel_def fset_rel_def split_conv
   20.48 +apply (auto split: sum.splits)
   20.49 +apply (metis sumE)
   20.50 +apply (metis sumE)
   20.51 +apply (metis sumE)
   20.52 +apply (metis sumE)
   20.53 +apply (metis sumE sum.simps(1,2,4))
   20.54 +apply (metis sumE sum.simps(1,2,4))
   20.55 +done
   20.56 +
   20.57 +
   20.58 +subsection{* Constructors *}
   20.59 +
   20.60 +definition NNode :: "N \<Rightarrow> (T + Tree)fset \<Rightarrow> Tree"
   20.61 +where "NNode n as \<equiv> Tree_ctor (n,as)"
   20.62 +
   20.63 +lemmas ctor_defs = NNode_def
   20.64 +
   20.65 +
   20.66 +subsection {* Pre-selectors *}
   20.67 +
   20.68 +(* These are mere auxiliaries *)
   20.69 +
   20.70 +definition "asNNode tr \<equiv> SOME n_as. NNode (fst n_as) (snd n_as) = tr"
   20.71 +lemmas pre_sel_defs = asNNode_def
   20.72 +
   20.73 +
   20.74 +subsection {* Selectors *}
   20.75 +
   20.76 +(* One for each pair (constructor, constructor argument) *)
   20.77 +
   20.78 +(* For NNode: *)
   20.79 +definition root :: "Tree \<Rightarrow> N" where "root tr = fst (asNNode tr)"
   20.80 +definition ccont :: "Tree \<Rightarrow> (T + Tree)fset" where "ccont tr = snd (asNNode tr)"
   20.81 +
   20.82 +lemmas sel_defs = root_def ccont_def
   20.83 +
   20.84 +
   20.85 +subsection {* Basic properties *}
   20.86 +
   20.87 +(* Constructors versus selectors *)
   20.88 +lemma NNode_surj: "\<exists> n as. NNode n as = tr"
   20.89 +unfolding NNode_def
   20.90 +by (metis Tree.ctor_dtor pair_collapse)
   20.91 +
   20.92 +lemma NNode_asNNode:
   20.93 +"NNode (fst (asNNode tr)) (snd (asNNode tr)) = tr"
   20.94 +proof-
   20.95 +  obtain n as where "NNode n as = tr" using NNode_surj[of tr] by blast
   20.96 +  hence "NNode (fst (n,as)) (snd (n,as)) = tr" by simp
   20.97 +  thus ?thesis unfolding asNNode_def by(rule someI)
   20.98 +qed
   20.99 +
  20.100 +theorem NNode_root_ccont[simp]:
  20.101 +"NNode (root tr) (ccont tr) = tr"
  20.102 +using NNode_asNNode unfolding root_def ccont_def .
  20.103 +
  20.104 +(* Constructors *)
  20.105 +theorem TTree_simps[simp]:
  20.106 +"NNode n as = NNode n' as' \<longleftrightarrow> n = n' \<and> as = as'"
  20.107 +unfolding ctor_defs Tree.ctor_inject by auto
  20.108 +
  20.109 +theorem TTree_cases[elim, case_names NNode Choice]:
  20.110 +assumes NNode: "\<And> n as. tr = NNode n as \<Longrightarrow> phi"
  20.111 +shows phi
  20.112 +proof(cases rule: Tree.ctor_exhaust[of tr])
  20.113 +  fix x assume "tr = Tree_ctor x"
  20.114 +  thus ?thesis
  20.115 +  apply(cases x)
  20.116 +    using NNode unfolding ctor_defs apply blast
  20.117 +  done
  20.118 +qed
  20.119 +
  20.120 +(* Constructors versus selectors *)
  20.121 +theorem TTree_sel_ctor[simp]:
  20.122 +"root (NNode n as) = n"
  20.123 +"ccont (NNode n as) = as"
  20.124 +unfolding root_def ccont_def
  20.125 +by (metis (no_types) NNode_asNNode TTree_simps)+
  20.126 +
  20.127 +
  20.128 +subsection{* Coinduction *}
  20.129 +
  20.130 +theorem TTree_coind_Node[elim, consumes 1, case_names NNode, induct pred: "HOL.eq"]:
  20.131 +assumes phi: "\<phi> tr1 tr2" and
  20.132 +NNode: "\<And> n1 n2 as1 as2.
  20.133 +          \<lbrakk>\<phi> (NNode n1 as1) (NNode n2 as2)\<rbrakk> \<Longrightarrow>
  20.134 +          n1 = n2 \<and> llift2 \<phi> as1 as2"
  20.135 +shows "tr1 = tr2"
  20.136 +apply(rule mp[OF Tree.rel_coinduct[of \<phi> tr1 tr2] phi]) proof clarify
  20.137 +  fix tr1 tr2  assume \<phi>: "\<phi> tr1 tr2"
  20.138 +  show "pre_Tree_rel \<phi> (Tree_dtor tr1) (Tree_dtor tr2)"
  20.139 +  apply(cases rule: Tree.ctor_exhaust[of tr1], cases rule: Tree.ctor_exhaust[of tr2])
  20.140 +  apply (simp add: Tree.dtor_ctor)
  20.141 +  apply(case_tac x, case_tac xa, simp)
  20.142 +  unfolding pre_Tree_rel apply(rule NNode) using \<phi> unfolding NNode_def by simp
  20.143 +qed
  20.144 +
  20.145 +theorem TTree_coind[elim, consumes 1, case_names LLift]:
  20.146 +assumes phi: "\<phi> tr1 tr2" and
  20.147 +LLift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
  20.148 +                   root tr1 = root tr2 \<and> llift2 \<phi> (ccont tr1) (ccont tr2)"
  20.149 +shows "tr1 = tr2"
  20.150 +using phi apply(induct rule: TTree_coind_Node)
  20.151 +using LLift by (metis TTree_sel_ctor)
  20.152 +
  20.153 +
  20.154 +
  20.155 +subsection {* Coiteration *}
  20.156 +
  20.157 +(* Preliminaries: *)
  20.158 +declare Tree.dtor_ctor[simp]
  20.159 +declare Tree.ctor_dtor[simp]
  20.160 +
  20.161 +lemma Tree_dtor_NNode[simp]:
  20.162 +"Tree_dtor (NNode n as) = (n,as)"
  20.163 +unfolding NNode_def Tree.dtor_ctor ..
  20.164 +
  20.165 +lemma Tree_dtor_root_ccont:
  20.166 +"Tree_dtor tr = (root tr, ccont tr)"
  20.167 +unfolding root_def ccont_def
  20.168 +by (metis (lifting) NNode_asNNode Tree_dtor_NNode)
  20.169 +
  20.170 +(* Coiteration *)
  20.171 +definition TTree_unfold ::
  20.172 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + 'b) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
  20.173 +where "TTree_unfold rt ct \<equiv> Tree_dtor_unfold <rt,ct>"
  20.174 +
  20.175 +lemma Tree_unfold_unfold:
  20.176 +"Tree_dtor_unfold s = TTree_unfold (fst o s) (snd o s)"
  20.177 +apply(rule ext)
  20.178 +unfolding TTree_unfold_def by simp
  20.179 +
  20.180 +theorem TTree_unfold:
  20.181 +"root (TTree_unfold rt ct b) = rt b"
  20.182 +"ccont (TTree_unfold rt ct b) = map_fset (id \<oplus> TTree_unfold rt ct) (ct b)"
  20.183 +using Tree.dtor_unfolds[of "<rt,ct>" b] unfolding Tree_unfold_unfold fst_convol snd_convol
  20.184 +unfolding pre_Tree_map' fst_convol' snd_convol'
  20.185 +unfolding Tree_dtor_root_ccont by simp_all
  20.186 +
  20.187 +(* Corecursion, stronger than coiteration (unfold) *)
  20.188 +definition TTree_corec ::
  20.189 +"('b \<Rightarrow> N) \<Rightarrow> ('b \<Rightarrow> (T + (Tree + 'b)) fset) \<Rightarrow> 'b \<Rightarrow> Tree"
  20.190 +where "TTree_corec rt ct \<equiv> Tree_dtor_corec <rt,ct>"
  20.191 +
  20.192 +lemma Tree_dtor_corec_corec:
  20.193 +"Tree_dtor_corec s = TTree_corec (fst o s) (snd o s)"
  20.194 +apply(rule ext)
  20.195 +unfolding TTree_corec_def by simp
  20.196 +
  20.197 +theorem TTree_corec:
  20.198 +"root (TTree_corec rt ct b) = rt b"
  20.199 +"ccont (TTree_corec rt ct b) = map_fset (id \<oplus> ([[id, TTree_corec rt ct]]) ) (ct b)"
  20.200 +using Tree.dtor_corecs[of "<rt,ct>" b] unfolding Tree_dtor_corec_corec fst_convol snd_convol
  20.201 +unfolding pre_Tree_map' fst_convol' snd_convol'
  20.202 +unfolding Tree_dtor_root_ccont by simp_all
  20.203 +
  20.204 +
  20.205 +subsection{* The characteristic theorems transported from fset to set *}
  20.206 +
  20.207 +definition "Node n as \<equiv> NNode n (the_inv fset as)"
  20.208 +definition "cont \<equiv> fset o ccont"
  20.209 +definition "unfold rt ct \<equiv> TTree_unfold rt (the_inv fset o ct)"
  20.210 +definition "corec rt ct \<equiv> TTree_corec rt (the_inv fset o ct)"
  20.211 +
  20.212 +definition lift ("_ ^#" 200) where
  20.213 +"lift \<phi> as \<longleftrightarrow> (\<forall> tr. Inr tr \<in> as \<longrightarrow> \<phi> tr)"
  20.214 +
  20.215 +definition lift2 ("_ ^#2" 200) where
  20.216 +"lift2 \<phi> as1 as2 \<longleftrightarrow>
  20.217 + (\<forall> n. Inl n \<in> as1 \<longleftrightarrow> Inl n \<in> as2) \<and>
  20.218 + (\<forall> tr1. Inr tr1 \<in> as1 \<longrightarrow> (\<exists> tr2. Inr tr2 \<in> as2 \<and> \<phi> tr1 tr2)) \<and>
  20.219 + (\<forall> tr2. Inr tr2 \<in> as2 \<longrightarrow> (\<exists> tr1. Inr tr1 \<in> as1 \<and> \<phi> tr1 tr2))"
  20.220 +
  20.221 +definition liftS ("_ ^#s" 200) where
  20.222 +"liftS trs = {as. Inr -` as \<subseteq> trs}"
  20.223 +
  20.224 +lemma lift2_llift2:
  20.225 +"\<lbrakk>finite as1; finite as2\<rbrakk> \<Longrightarrow>
  20.226 + lift2 \<phi> as1 as2 \<longleftrightarrow> llift2 \<phi> (the_inv fset as1) (the_inv fset as2)"
  20.227 +unfolding lift2_def llift2_def by auto
  20.228 +
  20.229 +lemma llift2_lift2:
  20.230 +"llift2 \<phi> as1 as2 \<longleftrightarrow> lift2 \<phi> (fset as1) (fset as2)"
  20.231 +using lift2_llift2 by (metis finite_fset fset_cong fset_to_fset)
  20.232 +
  20.233 +lemma mono_lift:
  20.234 +assumes "(\<phi>^#) as"
  20.235 +and "\<And> tr. \<phi> tr \<Longrightarrow> \<phi>' tr"
  20.236 +shows "(\<phi>'^#) as"
  20.237 +using assms unfolding lift_def[abs_def] by blast
  20.238 +
  20.239 +lemma mono_liftS:
  20.240 +assumes "trs1 \<subseteq> trs2 "
  20.241 +shows "(trs1 ^#s) \<subseteq> (trs2 ^#s)"
  20.242 +using assms unfolding liftS_def[abs_def] by blast
  20.243 +
  20.244 +lemma lift_mono:
  20.245 +assumes "\<phi> \<le> \<phi>'"
  20.246 +shows "(\<phi>^#) \<le> (\<phi>'^#)"
  20.247 +using assms unfolding lift_def[abs_def] by blast
  20.248 +
  20.249 +lemma mono_lift2:
  20.250 +assumes "(\<phi>^#2) as1 as2"
  20.251 +and "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow> \<phi>' tr1 tr2"
  20.252 +shows "(\<phi>'^#2) as1 as2"
  20.253 +using assms unfolding lift2_def[abs_def] by blast
  20.254 +
  20.255 +lemma lift2_mono:
  20.256 +assumes "\<phi> \<le> \<phi>'"
  20.257 +shows "(\<phi>^#2) \<le> (\<phi>'^#2)"
  20.258 +using assms unfolding lift2_def[abs_def] by blast
  20.259 +
  20.260 +lemma finite_cont[simp]: "finite (cont tr)"
  20.261 +unfolding cont_def by auto
  20.262 +
  20.263 +theorem Node_root_cont[simp]:
  20.264 +"Node (root tr) (cont tr) = tr"
  20.265 +using NNode_root_ccont unfolding Node_def cont_def
  20.266 +by (metis cont_def finite_cont fset_cong fset_to_fset o_def)
  20.267 +
  20.268 +theorem Tree_simps[simp]:
  20.269 +assumes "finite as" and "finite as'"
  20.270 +shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
  20.271 +using assms TTree_simps unfolding Node_def
  20.272 +by (metis fset_to_fset)
  20.273 +
  20.274 +theorem Tree_cases[elim, case_names Node Choice]:
  20.275 +assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
  20.276 +shows phi
  20.277 +apply(cases rule: TTree_cases[of tr])
  20.278 +using Node unfolding Node_def
  20.279 +by (metis Node Node_root_cont finite_cont)
  20.280 +
  20.281 +theorem Tree_sel_ctor[simp]:
  20.282 +"root (Node n as) = n"
  20.283 +"finite as \<Longrightarrow> cont (Node n as) = as"
  20.284 +unfolding Node_def cont_def by auto
  20.285 +
  20.286 +theorems root_Node = Tree_sel_ctor(1)
  20.287 +theorems cont_Node = Tree_sel_ctor(2)
  20.288 +
  20.289 +theorem Tree_coind_Node[elim, consumes 1, case_names Node]:
  20.290 +assumes phi: "\<phi> tr1 tr2" and
  20.291 +Node:
  20.292 +"\<And> n1 n2 as1 as2.
  20.293 +   \<lbrakk>finite as1; finite as2; \<phi> (Node n1 as1) (Node n2 as2)\<rbrakk>
  20.294 +   \<Longrightarrow> n1 = n2 \<and> (\<phi>^#2) as1 as2"
  20.295 +shows "tr1 = tr2"
  20.296 +using phi apply(induct rule: TTree_coind_Node)
  20.297 +unfolding llift2_lift2 apply(rule Node)
  20.298 +unfolding Node_def
  20.299 +apply (metis finite_fset)
  20.300 +apply (metis finite_fset)
  20.301 +by (metis finite_fset fset_cong fset_to_fset)
  20.302 +
  20.303 +theorem Tree_coind[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
  20.304 +assumes phi: "\<phi> tr1 tr2" and
  20.305 +Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
  20.306 +                  root tr1 = root tr2 \<and> (\<phi>^#2) (cont tr1) (cont tr2)"
  20.307 +shows "tr1 = tr2"
  20.308 +using phi apply(induct rule: TTree_coind)
  20.309 +unfolding llift2_lift2 apply(rule Lift[unfolded cont_def comp_def]) .
  20.310 +
  20.311 +theorem unfold:
  20.312 +"root (unfold rt ct b) = rt b"
  20.313 +"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
  20.314 +using TTree_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
  20.315 +apply - apply metis
  20.316 +unfolding cont_def comp_def
  20.317 +by (metis (no_types) fset_to_fset map_fset_image)
  20.318 +
  20.319 +
  20.320 +theorem corec:
  20.321 +"root (corec rt ct b) = rt b"
  20.322 +"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
  20.323 +using TTree_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
  20.324 +apply - apply metis
  20.325 +unfolding cont_def comp_def
  20.326 +by (metis (no_types) fset_to_fset map_fset_image)
  20.327 +
  20.328 +
  20.329 +end
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/BNF/Examples/Lambda_Term.thy	Fri Sep 21 16:45:06 2012 +0200
    21.3 @@ -0,0 +1,259 @@
    21.4 +(*  Title:      HOL/BNF/Examples/Lambda_Term.thy
    21.5 +    Author:     Dmitriy Traytel, TU Muenchen
    21.6 +    Author:     Andrei Popescu, TU Muenchen
    21.7 +    Copyright   2012
    21.8 +
    21.9 +Lambda-terms.
   21.10 +*)
   21.11 +
   21.12 +header {* Lambda-Terms *}
   21.13 +
   21.14 +theory Lambda_Term
   21.15 +imports "../BNF"
   21.16 +begin
   21.17 +
   21.18 +
   21.19 +section {* Datatype definition *}
   21.20 +
   21.21 +data_raw trm: 'trm = "'a + 'trm \<times> 'trm + 'a \<times> 'trm + ('a \<times> 'trm) fset \<times> 'trm"
   21.22 +
   21.23 +
   21.24 +section {* Customization of terms *}
   21.25 +
   21.26 +subsection{* Set and map *}
   21.27 +
   21.28 +lemma pre_trm_set2_Lt: "pre_trm_set2 (Inr (Inr (Inr (xts, t)))) = snd ` (fset xts) \<union> {t}"
   21.29 +unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
   21.30 +by auto
   21.31 +
   21.32 +lemma pre_trm_set2_Var: "\<And>x. pre_trm_set2 (Inl x) = {}"
   21.33 +and pre_trm_set2_App:
   21.34 +"\<And>t1 t2. pre_trm_set2 (Inr (Inl t1t2)) = {fst t1t2, snd t1t2}"
   21.35 +and pre_trm_set2_Lam:
   21.36 +"\<And>x t. pre_trm_set2 (Inr (Inr (Inl (x, t)))) = {t}"
   21.37 +unfolding pre_trm_set2_def sum_set_defs prod_set_defs collect_def[abs_def]
   21.38 +by auto
   21.39 +
   21.40 +lemma pre_trm_map:
   21.41 +"\<And> a1. pre_trm_map f1 f2 (Inl a1) = Inl (f1 a1)"
   21.42 +"\<And> a2 b2. pre_trm_map f1 f2 (Inr (Inl (a2,b2))) = Inr (Inl (f2 a2, f2 b2))"
   21.43 +"\<And> a1 a2. pre_trm_map f1 f2 (Inr (Inr (Inl (a1,a2)))) = Inr (Inr (Inl (f1 a1, f2 a2)))"
   21.44 +"\<And> a1a2s a2.
   21.45 +   pre_trm_map f1 f2 (Inr (Inr (Inr (a1a2s, a2)))) =
   21.46 +   Inr (Inr (Inr (map_fset (\<lambda> (a1', a2'). (f1 a1', f2 a2')) a1a2s, f2 a2)))"
   21.47 +unfolding pre_trm_map_def collect_def[abs_def] map_pair_def by auto
   21.48 +
   21.49 +
   21.50 +subsection{* Constructors *}
   21.51 +
   21.52 +definition "Var x \<equiv> trm_ctor (Inl x)"
   21.53 +definition "App t1 t2 \<equiv> trm_ctor (Inr (Inl (t1,t2)))"
   21.54 +definition "Lam x t \<equiv> trm_ctor (Inr (Inr (Inl (x,t))))"
   21.55 +definition "Lt xts t \<equiv> trm_ctor (Inr (Inr (Inr (xts,t))))"
   21.56 +
   21.57 +lemmas ctor_defs = Var_def App_def Lam_def Lt_def
   21.58 +
   21.59 +theorem trm_simps[simp]:
   21.60 +"\<And>x y. Var x = Var y \<longleftrightarrow> x = y"
   21.61 +"\<And>t1 t2 t1' t2'. App t1 t2 = App t1' t2' \<longleftrightarrow> t1 = t1' \<and> t2 = t2'"
   21.62 +"\<And>x x' t t'. Lam x t = Lam x' t' \<longleftrightarrow> x = x' \<and> t = t'"
   21.63 +"\<And> xts xts' t t'. Lt xts t = Lt xts' t' \<longleftrightarrow> xts = xts' \<and> t = t'"
   21.64 +(*  *)
   21.65 +"\<And> x t1 t2. Var x \<noteq> App t1 t2"  "\<And>x y t. Var x \<noteq> Lam y t"  "\<And> x xts t. Var x \<noteq> Lt xts t"
   21.66 +"\<And> t1 t2 x t. App t1 t2 \<noteq> Lam x t"  "\<And> t1 t2 xts t. App t1 t2 \<noteq> Lt xts t"
   21.67 +"\<And>x t xts t1. Lam x t \<noteq> Lt xts t1"
   21.68 +unfolding ctor_defs trm.ctor_inject by auto
   21.69 +
   21.70 +theorem trm_cases[elim, case_names Var App Lam Lt]:
   21.71 +assumes Var: "\<And> x. t = Var x \<Longrightarrow> phi"
   21.72 +and App: "\<And> t1 t2. t = App t1 t2 \<Longrightarrow> phi"
   21.73 +and Lam: "\<And> x t1. t = Lam x t1 \<Longrightarrow> phi"
   21.74 +and Lt: "\<And> xts t1. t = Lt xts t1 \<Longrightarrow> phi"
   21.75 +shows phi
   21.76 +proof(cases rule: trm.ctor_exhaust[of t])
   21.77 +  fix x assume "t = trm_ctor x"
   21.78 +  thus ?thesis
   21.79 +  apply(cases x) using Var unfolding ctor_defs apply blast
   21.80 +  apply(case_tac b) using App unfolding ctor_defs apply(case_tac a, blast)
   21.81 +  apply(case_tac ba) using Lam unfolding ctor_defs apply(case_tac a, blast)
   21.82 +  apply(case_tac bb) using Lt unfolding ctor_defs by blast
   21.83 +qed
   21.84 +
   21.85 +lemma trm_induct[case_names Var App Lam Lt, induct type: trm]:
   21.86 +assumes Var: "\<And> (x::'a). phi (Var x)"
   21.87 +and App: "\<And> t1 t2. \<lbrakk>phi t1; phi t2\<rbrakk> \<Longrightarrow> phi (App t1 t2)"
   21.88 +and Lam: "\<And> x t. phi t \<Longrightarrow> phi (Lam x t)"
   21.89 +and Lt: "\<And> xts t. \<lbrakk>\<And> x1 t1. (x1,t1) |\<in>| xts \<Longrightarrow> phi t1; phi t\<rbrakk> \<Longrightarrow> phi (Lt xts t)"
   21.90 +shows "phi t"
   21.91 +proof(induct rule: trm.ctor_induct)
   21.92 +  fix u :: "'a + 'a trm \<times> 'a trm + 'a \<times> 'a trm + ('a \<times> 'a trm) fset \<times> 'a trm"
   21.93 +  assume IH: "\<And>t. t \<in> pre_trm_set2 u \<Longrightarrow> phi t"
   21.94 +  show "phi (trm_ctor u)"
   21.95 +  proof(cases u)
   21.96 +    case (Inl x)
   21.97 +    show ?thesis using Var unfolding Var_def Inl .
   21.98 +  next
   21.99 +    case (Inr uu) note Inr1 = Inr
  21.100 +    show ?thesis
  21.101 +    proof(cases uu)
  21.102 +      case (Inl t1t2)
  21.103 +      obtain t1 t2 where t1t2: "t1t2 = (t1,t2)" by (cases t1t2, blast)
  21.104 +      show ?thesis unfolding Inr1 Inl t1t2 App_def[symmetric] apply(rule App)
  21.105 +      using IH unfolding Inr1 Inl pre_trm_set2_App t1t2 fst_conv snd_conv by blast+
  21.106 +    next
  21.107 +      case (Inr uuu) note Inr2 = Inr
  21.108 +      show ?thesis
  21.109 +      proof(cases uuu)
  21.110 +        case (Inl xt)
  21.111 +        obtain x t where xt: "xt = (x,t)" by (cases xt, blast)
  21.112 +        show ?thesis unfolding Inr1 Inr2 Inl xt Lam_def[symmetric] apply(rule Lam)
  21.113 +        using IH unfolding Inr1 Inr2 Inl pre_trm_set2_Lam xt by blast
  21.114 +      next
  21.115 +        case (Inr xts_t)
  21.116 +        obtain xts t where xts_t: "xts_t = (xts,t)" by (cases xts_t, blast)
  21.117 +        show ?thesis unfolding Inr1 Inr2 Inr xts_t Lt_def[symmetric] apply(rule Lt) using IH
  21.118 +        unfolding Inr1 Inr2 Inr pre_trm_set2_Lt xts_t fset_fset_member image_def by auto
  21.119 +      qed
  21.120 +    qed
  21.121 +  qed
  21.122 +qed
  21.123 +
  21.124 +
  21.125 +subsection{* Recursion and iteration (fold) *}
  21.126 +
  21.127 +definition
  21.128 +"sumJoin4 f1 f2 f3 f4 \<equiv>
  21.129 +\<lambda> k. (case k of
  21.130 + Inl x1 \<Rightarrow> f1 x1
  21.131 +|Inr k1 \<Rightarrow> (case k1 of
  21.132 + Inl ((s2,a2),(t2,b2)) \<Rightarrow> f2 s2 a2 t2 b2
  21.133 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,(t3,b3)) \<Rightarrow> f3 x3 t3 b3
  21.134 +|Inr (xts,(t4,b4)) \<Rightarrow> f4 xts t4 b4)))"
  21.135 +
  21.136 +lemma sumJoin4_simps[simp]:
  21.137 +"\<And>x. sumJoin4 var app lam lt (Inl x) = var x"
  21.138 +"\<And> t1 a1 t2 a2. sumJoin4 var app lam lt (Inr (Inl ((t1,a1),(t2,a2)))) = app t1 a1 t2 a2"
  21.139 +"\<And> x t a. sumJoin4 var app lam lt (Inr (Inr (Inl (x,(t,a))))) = lam x t a"
  21.140 +"\<And> xtas t a. sumJoin4 var app lam lt (Inr (Inr (Inr (xtas,(t,a))))) = lt xtas t a"
  21.141 +unfolding sumJoin4_def by auto
  21.142 +
  21.143 +definition "trmrec var app lam lt \<equiv> trm_ctor_rec (sumJoin4 var app lam lt)"
  21.144 +
  21.145 +lemma trmrec_Var[simp]:
  21.146 +"trmrec var app lam lt (Var x) = var x"
  21.147 +unfolding trmrec_def Var_def trm.ctor_recs pre_trm_map(1) by simp
  21.148 +
  21.149 +lemma trmrec_App[simp]:
  21.150 +"trmrec var app lam lt (App t1 t2) =
  21.151 + app t1 (trmrec var app lam lt t1) t2 (trmrec var app lam lt t2)"
  21.152 +unfolding trmrec_def App_def trm.ctor_recs pre_trm_map(2) convol_def by simp
  21.153 +
  21.154 +lemma trmrec_Lam[simp]:
  21.155 +"trmrec var app lam lt (Lam x t) = lam x t (trmrec var app lam lt t)"
  21.156 +unfolding trmrec_def Lam_def trm.ctor_recs pre_trm_map(3) convol_def by simp
  21.157 +
  21.158 +lemma trmrec_Lt[simp]:
  21.159 +"trmrec var app lam lt (Lt xts t) =
  21.160 + lt (map_fset (\<lambda> (x,t). (x,t,trmrec var app lam lt t)) xts) t (trmrec var app lam lt t)"
  21.161 +unfolding trmrec_def Lt_def trm.ctor_recs pre_trm_map(4) convol_def by simp
  21.162 +
  21.163 +definition
  21.164 +"sumJoinI4 f1 f2 f3 f4 \<equiv>
  21.165 +\<lambda> k. (case k of
  21.166 + Inl x1 \<Rightarrow> f1 x1
  21.167 +|Inr k1 \<Rightarrow> (case k1 of
  21.168 + Inl (a2,b2) \<Rightarrow> f2 a2 b2
  21.169 +|Inr k2 \<Rightarrow> (case k2 of Inl (x3,b3) \<Rightarrow> f3 x3 b3
  21.170 +|Inr (xts,b4) \<Rightarrow> f4 xts b4)))"
  21.171 +
  21.172 +lemma sumJoinI4_simps[simp]:
  21.173 +"\<And>x. sumJoinI4 var app lam lt (Inl x) = var x"
  21.174 +"\<And> a1 a2. sumJoinI4 var app lam lt (Inr (Inl (a1,a2))) = app a1 a2"
  21.175 +"\<And> x a. sumJoinI4 var app lam lt (Inr (Inr (Inl (x,a)))) = lam x a"
  21.176 +"\<And> xtas a. sumJoinI4 var app lam lt (Inr (Inr (Inr (xtas,a)))) = lt xtas a"
  21.177 +unfolding sumJoinI4_def by auto
  21.178 +
  21.179 +(* The iterator has a simpler, hence more manageable type. *)
  21.180 +definition "trmfold var app lam lt \<equiv> trm_ctor_fold (sumJoinI4 var app lam lt)"
  21.181 +
  21.182 +lemma trmfold_Var[simp]:
  21.183 +"trmfold var app lam lt (Var x) = var x"
  21.184 +unfolding trmfold_def Var_def trm.ctor_folds pre_trm_map(1) by simp
  21.185 +
  21.186 +lemma trmfold_App[simp]:
  21.187 +"trmfold var app lam lt (App t1 t2) =
  21.188 + app (trmfold var app lam lt t1) (trmfold var app lam lt t2)"
  21.189 +unfolding trmfold_def App_def trm.ctor_folds pre_trm_map(2) by simp
  21.190 +
  21.191 +lemma trmfold_Lam[simp]:
  21.192 +"trmfold var app lam lt (Lam x t) = lam x (trmfold var app lam lt t)"
  21.193 +unfolding trmfold_def Lam_def trm.ctor_folds pre_trm_map(3) by simp
  21.194 +
  21.195 +lemma trmfold_Lt[simp]:
  21.196 +"trmfold var app lam lt (Lt xts t) =
  21.197 + lt (map_fset (\<lambda> (x,t). (x,trmfold var app lam lt t)) xts) (trmfold var app lam lt t)"
  21.198 +unfolding trmfold_def Lt_def trm.ctor_folds pre_trm_map(4) by simp
  21.199 +
  21.200 +
  21.201 +subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
  21.202 +
  21.203 +definition "varsOf = trmfold
  21.204 +(\<lambda> x. {x})
  21.205 +(\<lambda> X1 X2. X1 \<union> X2)
  21.206 +(\<lambda> x X. X \<union> {x})
  21.207 +(\<lambda> xXs Y. Y \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| xXs}))"
  21.208 +
  21.209 +lemma varsOf_simps[simp]:
  21.210 +"varsOf (Var x) = {x}"
  21.211 +"varsOf (App t1 t2) = varsOf t1 \<union> varsOf t2"
  21.212 +"varsOf (Lam x t) = varsOf t \<union> {x}"
  21.213 +"varsOf (Lt xts t) =
  21.214 + varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,varsOf t1)) xts})"
  21.215 +unfolding varsOf_def by simp_all
  21.216 +
  21.217 +definition "fvarsOf = trmfold
  21.218 +(\<lambda> x. {x})
  21.219 +(\<lambda> X1 X2. X1 \<union> X2)
  21.220 +(\<lambda> x X. X - {x})
  21.221 +(\<lambda> xtXs Y. Y - {x | x X. (x,X) |\<in>| xtXs} \<union> (\<Union> {X | x X. (x,X) |\<in>| xtXs}))"
  21.222 +
  21.223 +lemma fvarsOf_simps[simp]:
  21.224 +"fvarsOf (Var x) = {x}"
  21.225 +"fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
  21.226 +"fvarsOf (Lam x t) = fvarsOf t - {x}"
  21.227 +"fvarsOf (Lt xts t) =
  21.228 + fvarsOf t
  21.229 + - {x | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts}
  21.230 + \<union> (\<Union> {X | x X. (x,X) |\<in>| map_fset (\<lambda> (x,t1). (x,fvarsOf t1)) xts})"
  21.231 +unfolding fvarsOf_def by simp_all
  21.232 +
  21.233 +lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
  21.234 +
  21.235 +lemma in_map_fset_iff:
  21.236 +"(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, f t1)) xts \<longleftrightarrow>
  21.237 + (\<exists> t1. (x,t1) |\<in>| xts \<and> X = f t1)"
  21.238 +unfolding map_fset_def2_raw in_fset fset_afset unfolding fset_def2_raw by auto
  21.239 +
  21.240 +lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
  21.241 +proof induct
  21.242 +  case (Lt xts t)
  21.243 +  thus ?case unfolding fvarsOf_simps varsOf_simps
  21.244 +  proof (elim diff_Un_incl_triv)
  21.245 +    show
  21.246 +    "\<Union>{X | x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts}
  21.247 +     \<subseteq> \<Union>{{x} \<union> X |x X. (x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts}"
  21.248 +     (is "_ \<subseteq> \<Union> ?L")
  21.249 +    proof(rule Sup_mono, safe)
  21.250 +      fix a x X
  21.251 +      assume "(x, X) |\<in>| map_fset (\<lambda>(x, t1). (x, fvarsOf t1)) xts"
  21.252 +      then obtain t1 where x_t1: "(x,t1) |\<in>| xts" and X: "X = fvarsOf t1"
  21.253 +      unfolding in_map_fset_iff by auto
  21.254 +      let ?Y = "varsOf t1"
  21.255 +      have x_Y: "(x,?Y) |\<in>| map_fset (\<lambda>(x, t1). (x, varsOf t1)) xts"
  21.256 +      using x_t1 unfolding in_map_fset_iff by auto
  21.257 +      show "\<exists> Y \<in> ?L. X \<subseteq> Y" unfolding X using Lt(1) x_Y x_t1 by auto
  21.258 +    qed
  21.259 +  qed
  21.260 +qed auto
  21.261 +
  21.262 +end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/BNF/Examples/ListF.thy	Fri Sep 21 16:45:06 2012 +0200
    22.3 @@ -0,0 +1,171 @@
    22.4 +(*  Title:      HOL/BNF/Examples/ListF.thy
    22.5 +    Author:     Dmitriy Traytel, TU Muenchen
    22.6 +    Author:     Andrei Popescu, TU Muenchen
    22.7 +    Copyright   2012
    22.8 +
    22.9 +Finite lists.
   22.10 +*)
   22.11 +
   22.12 +header {* Finite Lists *}
   22.13 +
   22.14 +theory ListF
   22.15 +imports "../BNF"
   22.16 +begin
   22.17 +
   22.18 +data_raw listF: 'list = "unit + 'a \<times> 'list"
   22.19 +
   22.20 +definition "NilF = listF_ctor (Inl ())"
   22.21 +definition "Conss a as \<equiv> listF_ctor (Inr (a, as))"
   22.22 +
   22.23 +lemma listF_map_NilF[simp]: "listF_map f NilF = NilF"
   22.24 +unfolding listF_map_def pre_listF_map_def NilF_def listF.ctor_folds by simp
   22.25 +
   22.26 +lemma listF_map_Conss[simp]:
   22.27 +  "listF_map f (Conss x xs) = Conss (f x) (listF_map f xs)"
   22.28 +unfolding listF_map_def pre_listF_map_def Conss_def listF.ctor_folds by simp
   22.29 +
   22.30 +lemma listF_set_NilF[simp]: "listF_set NilF = {}"
   22.31 +unfolding listF_set_def NilF_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
   22.32 +  sum_set_defs pre_listF_map_def collect_def[abs_def] by simp
   22.33 +
   22.34 +lemma listF_set_Conss[simp]: "listF_set (Conss x xs) = {x} \<union> listF_set xs"
   22.35 +unfolding listF_set_def Conss_def listF.ctor_folds pre_listF_set1_def pre_listF_set2_def
   22.36 +  sum_set_defs prod_set_defs pre_listF_map_def collect_def[abs_def] by simp
   22.37 +
   22.38 +lemma fold_sum_case_NilF: "listF_ctor_fold (sum_case f g) NilF = f ()"
   22.39 +unfolding NilF_def listF.ctor_folds pre_listF_map_def by simp
   22.40 +
   22.41 +
   22.42 +lemma fold_sum_case_Conss:
   22.43 +  "listF_ctor_fold (sum_case f g) (Conss y ys) = g (y, listF_ctor_fold (sum_case f g) ys)"
   22.44 +unfolding Conss_def listF.ctor_folds pre_listF_map_def by simp
   22.45 +
   22.46 +(* familiar induction principle *)
   22.47 +lemma listF_induct:
   22.48 +  fixes xs :: "'a listF"
   22.49 +  assumes IB: "P NilF" and IH: "\<And>x xs. P xs \<Longrightarrow> P (Conss x xs)"
   22.50 +  shows "P xs"
   22.51 +proof (rule listF.ctor_induct)
   22.52 +  fix xs :: "unit + 'a \<times> 'a listF"
   22.53 +  assume raw_IH: "\<And>a. a \<in> pre_listF_set2 xs \<Longrightarrow> P a"
   22.54 +  show "P (listF_ctor xs)"
   22.55 +  proof (cases xs)
   22.56 +    case (Inl a) with IB show ?thesis unfolding NilF_def by simp
   22.57 +  next
   22.58 +    case (Inr b)
   22.59 +    then obtain y ys where yys: "listF_ctor xs = Conss y ys"
   22.60 +      unfolding Conss_def listF.ctor_inject by (blast intro: prod.exhaust)
   22.61 +    hence "ys \<in> pre_listF_set2 xs"
   22.62 +      unfolding pre_listF_set2_def Conss_def listF.ctor_inject sum_set_defs prod_set_defs
   22.63 +        collect_def[abs_def] by simp
   22.64 +    with raw_IH have "P ys" by blast
   22.65 +    with IH have "P (Conss y ys)" by blast
   22.66 +    with yys show ?thesis by simp
   22.67 +  qed
   22.68 +qed
   22.69 +
   22.70 +rep_datatype NilF Conss
   22.71 +by (blast intro: listF_induct) (auto simp add: NilF_def Conss_def listF.ctor_inject)
   22.72 +
   22.73 +definition Singll ("[[_]]") where
   22.74 +  [simp]: "Singll a \<equiv> Conss a NilF"
   22.75 +
   22.76 +definition appendd (infixr "@@" 65) where
   22.77 +  "appendd \<equiv> listF_ctor_fold (sum_case (\<lambda> _. id) (\<lambda> (a,f) bs. Conss a (f bs)))"
   22.78 +
   22.79 +definition "lrev \<equiv> listF_ctor_fold (sum_case (\<lambda> _. NilF) (\<lambda> (b,bs). bs @@ [[b]]))"
   22.80 +
   22.81 +lemma lrev_NilF[simp]: "lrev NilF = NilF"
   22.82 +unfolding lrev_def by (simp add: fold_sum_case_NilF)
   22.83 +
   22.84 +lemma lrev_Conss[simp]: "lrev (Conss y ys) = lrev ys @@ [[y]]"
   22.85 +unfolding lrev_def by (simp add: fold_sum_case_Conss)
   22.86 +
   22.87 +lemma NilF_appendd[simp]: "NilF @@ ys = ys"
   22.88 +unfolding appendd_def by (simp add: fold_sum_case_NilF)
   22.89 +
   22.90 +lemma Conss_append[simp]: "Conss x xs @@ ys = Conss x (xs @@ ys)"
   22.91 +unfolding appendd_def by (simp add: fold_sum_case_Conss)
   22.92 +
   22.93 +lemma appendd_NilF[simp]: "xs @@ NilF = xs"
   22.94 +by (rule listF_induct) auto
   22.95 +
   22.96 +lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
   22.97 +by (rule listF_induct) auto
   22.98 +
   22.99 +lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
  22.100 +by (rule listF_induct[of _ xs]) auto
  22.101 +
  22.102 +lemma listF_map_appendd[simp]:
  22.103 +  "listF_map f (xs @@ ys) = listF_map f xs @@ listF_map f ys"
  22.104 +by (rule listF_induct[of _ xs]) auto
  22.105 +
  22.106 +lemma lrev_listF_map[simp]: "lrev (listF_map f xs) = listF_map f (lrev xs)"
  22.107 +by (rule listF_induct[of _ xs]) auto
  22.108 +
  22.109 +lemma lrev_lrev[simp]: "lrev (lrev as) = as"
  22.110 +by (rule listF_induct) auto
  22.111 +
  22.112 +fun lengthh where
  22.113 +  "lengthh NilF = 0"
  22.114 +| "lengthh (Conss x xs) = Suc (lengthh xs)"
  22.115 +
  22.116 +fun nthh where
  22.117 +  "nthh (Conss x xs) 0 = x"
  22.118 +| "nthh (Conss x xs) (Suc n) = nthh xs n"
  22.119 +| "nthh xs i = undefined"
  22.120 +
  22.121 +lemma lengthh_listF_map[simp]: "lengthh (listF_map f xs) = lengthh xs"
  22.122 +by (rule listF_induct[of _ xs]) auto
  22.123 +
  22.124 +lemma nthh_listF_map[simp]:
  22.125 +  "i < lengthh xs \<Longrightarrow> nthh (listF_map f xs) i = f (nthh xs i)"
  22.126 +by (induct rule: nthh.induct) auto
  22.127 +
  22.128 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
  22.129 +by (induct rule: nthh.induct) auto
  22.130 +
  22.131 +lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
  22.132 +by (induct xs) auto
  22.133 +
  22.134 +lemma Conss_iff[iff]:
  22.135 +  "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
  22.136 +by (induct xs) auto
  22.137 +
  22.138 +lemma Conss_iff'[iff]:
  22.139 +  "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
  22.140 +by (induct xs) (simp, simp, blast)
  22.141 +
  22.142 +lemma listF_induct2: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
  22.143 +    \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
  22.144 +by (induct xs arbitrary: ys rule: listF_induct) auto
  22.145 +
  22.146 +fun zipp where
  22.147 +  "zipp NilF NilF = NilF"
  22.148 +| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
  22.149 +| "zipp xs ys = undefined"
  22.150 +
  22.151 +lemma listF_map_fst_zip[simp]:
  22.152 +  "lengthh xs = lengthh ys \<Longrightarrow> listF_map fst (zipp xs ys) = xs"
  22.153 +by (erule listF_induct2) auto
  22.154 +
  22.155 +lemma listF_map_snd_zip[simp]:
  22.156 +  "lengthh xs = lengthh ys \<Longrightarrow> listF_map snd (zipp xs ys) = ys"
  22.157 +by (erule listF_induct2) auto
  22.158 +
  22.159 +lemma lengthh_zip[simp]:
  22.160 +  "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
  22.161 +by (erule listF_induct2) auto
  22.162 +
  22.163 +lemma nthh_zip[simp]:
  22.164 +  assumes *: "lengthh xs = lengthh ys"
  22.165 +  shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
  22.166 +proof (induct arbitrary: i rule: listF_induct2[OF *])
  22.167 +  case (2 x xs y ys) thus ?case by (induct i) auto
  22.168 +qed simp
  22.169 +
  22.170 +lemma list_set_nthh[simp]:
  22.171 +  "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
  22.172 +by (induct xs) (auto, induct rule: nthh.induct, auto)
  22.173 +
  22.174 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/BNF/Examples/Misc_Codata.thy	Fri Sep 21 16:45:06 2012 +0200
    23.3 @@ -0,0 +1,110 @@
    23.4 +(*  Title:      HOL/BNF/Examples/Misc_Data.thy
    23.5 +    Author:     Dmitriy Traytel, TU Muenchen
    23.6 +    Author:     Andrei Popescu, TU Muenchen
    23.7 +    Copyright   2012
    23.8 +
    23.9 +Miscellaneous codatatype declarations.
   23.10 +*)
   23.11 +
   23.12 +header {* Miscellaneous Codatatype Declarations *}
   23.13 +
   23.14 +theory Misc_Codata
   23.15 +imports "../BNF"
   23.16 +begin
   23.17 +
   23.18 +codata simple = X1 | X2 | X3 | X4
   23.19 +
   23.20 +codata simple' = X1' unit | X2' unit | X3' unit | X4' unit
   23.21 +
   23.22 +codata 'a stream = Stream 'a "'a stream"
   23.23 +
   23.24 +codata 'a mylist = MyNil | MyCons 'a "'a mylist"
   23.25 +
   23.26 +codata ('b, 'c, 'd, 'e) some_passive =
   23.27 +  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   23.28 +
   23.29 +codata lambda =
   23.30 +  Var string |
   23.31 +  App lambda lambda |
   23.32 +  Abs string lambda |
   23.33 +  Let "(string \<times> lambda) fset" lambda
   23.34 +
   23.35 +codata 'a par_lambda =
   23.36 +  PVar 'a |
   23.37 +  PApp "'a par_lambda" "'a par_lambda" |
   23.38 +  PAbs 'a "'a par_lambda" |
   23.39 +  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   23.40 +
   23.41 +(*
   23.42 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   23.43 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   23.44 +*)
   23.45 +
   23.46 +codata 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
   23.47 +   and 'a J2 = J21 | J22 "'a J1" "'a J2"
   23.48 +
   23.49 +codata 'a tree = TEmpty | TNode 'a "'a forest"
   23.50 +   and 'a forest = FNil | FCons "'a tree" "'a forest"
   23.51 +
   23.52 +codata 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   23.53 +   and 'a branch = Branch 'a "'a tree'"
   23.54 +
   23.55 +codata ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   23.56 +   and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   23.57 +   and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   23.58 +
   23.59 +codata ('a, 'b, 'c) some_killing =
   23.60 +  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   23.61 +   and ('a, 'b, 'c) in_here =
   23.62 +  IH1 'b 'a | IH2 'c
   23.63 +
   23.64 +codata_raw some_killing': 'a = "'b \<Rightarrow> 'd \<Rightarrow> ('a + 'c)"
   23.65 +and in_here': 'c = "'d + 'e"
   23.66 +
   23.67 +codata_raw some_killing'': 'a = "'b \<Rightarrow> 'c"
   23.68 +and in_here'': 'c = "'d \<times> 'b + 'e"
   23.69 +
   23.70 +codata ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
   23.71 +
   23.72 +codata 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
   23.73 +
   23.74 +codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
   23.75 +  FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
   23.76 +      ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
   23.77 +
   23.78 +codata ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   23.79 +        'b18, 'b19, 'b20) fun_rhs' =
   23.80 +  FR' "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow> 'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow>
   23.81 +       'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
   23.82 +       ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   23.83 +        'b18, 'b19, 'b20) fun_rhs'"
   23.84 +
   23.85 +codata ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
   23.86 +   and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
   23.87 +   and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
   23.88 +
   23.89 +codata ('c, 'e, 'g) coind_wit1 =
   23.90 +       CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
   23.91 +   and ('c, 'e, 'g) coind_wit2 =
   23.92 +       CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
   23.93 +   and ('c, 'e, 'g) ind_wit =
   23.94 +       IW1 | IW2 'c
   23.95 +
   23.96 +codata ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
   23.97 +codata ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
   23.98 +
   23.99 +codata 'a dead_foo = A
  23.100 +codata ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  23.101 +
  23.102 +(* SLOW, MEMORY-HUNGRY
  23.103 +codata ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  23.104 +   and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  23.105 +   and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  23.106 +   and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  23.107 +   and ('a, 'c) D5 = A5 "('a, 'c) D6"
  23.108 +   and ('a, 'c) D6 = A6 "('a, 'c) D7"
  23.109 +   and ('a, 'c) D7 = A7 "('a, 'c) D8"
  23.110 +   and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  23.111 +*)
  23.112 +
  23.113 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/BNF/Examples/Misc_Data.thy	Fri Sep 21 16:45:06 2012 +0200
    24.3 @@ -0,0 +1,154 @@
    24.4 +(*  Title:      HOL/BNF/Examples/Misc_Data.thy
    24.5 +    Author:     Dmitriy Traytel, TU Muenchen
    24.6 +    Author:     Andrei Popescu, TU Muenchen
    24.7 +    Copyright   2012
    24.8 +
    24.9 +Miscellaneous datatype declarations.
   24.10 +*)
   24.11 +
   24.12 +header {* Miscellaneous Datatype Declarations *}
   24.13 +
   24.14 +theory Misc_Data
   24.15 +imports "../BNF"
   24.16 +begin
   24.17 +
   24.18 +data simple = X1 | X2 | X3 | X4
   24.19 +
   24.20 +data simple' = X1' unit | X2' unit | X3' unit | X4' unit
   24.21 +
   24.22 +data 'a mylist = MyNil | MyCons 'a "'a mylist"
   24.23 +
   24.24 +data ('b, 'c, 'd, 'e) some_passive =
   24.25 +  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   24.26 +
   24.27 +data lambda =
   24.28 +  Var string |
   24.29 +  App lambda lambda |
   24.30 +  Abs string lambda |
   24.31 +  Let "(string \<times> lambda) fset" lambda
   24.32 +
   24.33 +data 'a par_lambda =
   24.34 +  PVar 'a |
   24.35 +  PApp "'a par_lambda" "'a par_lambda" |
   24.36 +  PAbs 'a "'a par_lambda" |
   24.37 +  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   24.38 +
   24.39 +(*
   24.40 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   24.41 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   24.42 +*)
   24.43 +
   24.44 +data 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
   24.45 + and 'a I2 = I21 | I22 "'a I1" "'a I2"
   24.46 +
   24.47 +data 'a tree = TEmpty | TNode 'a "'a forest"
   24.48 + and 'a forest = FNil | FCons "'a tree" "'a forest"
   24.49 +
   24.50 +data 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   24.51 + and 'a branch = Branch 'a "'a tree'"
   24.52 +
   24.53 +data ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   24.54 + and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   24.55 + and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   24.56 +
   24.57 +data ('a, 'b, 'c) some_killing =
   24.58 +  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   24.59 + and ('a, 'b, 'c) in_here =
   24.60 +  IH1 'b 'a | IH2 'c
   24.61 +
   24.62 +data 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
   24.63 +data 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
   24.64 +data 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
   24.65 +data 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
   24.66 +
   24.67 +(*
   24.68 +data 'b fail = F "'b fail" 'b "'b fail" "'b list"
   24.69 +data 'b fail = F "'b fail" 'b "'b fail" 'b
   24.70 +data 'b fail = F1 "'b fail" 'b | F2 "'b fail"
   24.71 +data 'b fail = F "'b fail" 'b
   24.72 +*)
   24.73 +
   24.74 +data l1 = L1 "l2 list"
   24.75 + and l2 = L21 "l1 fset" | L22 l2
   24.76 +
   24.77 +data kk1 = KK1 kk2
   24.78 + and kk2 = KK2 kk3
   24.79 + and kk3 = KK3 "kk1 list"
   24.80 +
   24.81 +data t1 = T11 t3 | T12 t2
   24.82 + and t2 = T2 t1
   24.83 + and t3 = T3
   24.84 +
   24.85 +data t1' = T11' t2' | T12' t3'
   24.86 + and t2' = T2' t1'
   24.87 + and t3' = T3'
   24.88 +
   24.89 +(*
   24.90 +data fail1 = F1 fail2
   24.91 + and fail2 = F2 fail3
   24.92 + and fail3 = F3 fail1
   24.93 +
   24.94 +data fail1 = F1 "fail2 list" fail2
   24.95 + and fail2 = F2 "fail2 fset" fail3
   24.96 + and fail3 = F3 fail1
   24.97 +
   24.98 +data fail1 = F1 "fail2 list" fail2
   24.99 + and fail2 = F2 "fail1 fset" fail1
  24.100 +*)
  24.101 +
  24.102 +(* SLOW
  24.103 +data ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  24.104 + and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  24.105 + and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  24.106 + and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  24.107 + and ('a, 'c) D5 = A5 "('a, 'c) D6"
  24.108 + and ('a, 'c) D6 = A6 "('a, 'c) D7"
  24.109 + and ('a, 'c) D7 = A7 "('a, 'c) D8"
  24.110 + and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  24.111 +
  24.112 +(*time comparison*)
  24.113 +datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
  24.114 +     and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
  24.115 +     and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
  24.116 +     and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
  24.117 +     and ('a, 'c) D5' = A5' "('a, 'c) D6'"
  24.118 +     and ('a, 'c) D6' = A6' "('a, 'c) D7'"
  24.119 +     and ('a, 'c) D7' = A7' "('a, 'c) D8'"
  24.120 +     and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
  24.121 +*)
  24.122 +
  24.123 +(* fail:
  24.124 +data tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
  24.125 + and tt2 = TT2
  24.126 + and tt3 = TT3 tt4
  24.127 + and tt4 = TT4 tt1
  24.128 +*)
  24.129 +
  24.130 +data k1 = K11 k2 k3 | K12 k2 k4
  24.131 + and k2 = K2
  24.132 + and k3 = K3 k4
  24.133 + and k4 = K4
  24.134 +
  24.135 +data tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
  24.136 + and tt2 = TT2
  24.137 + and tt3 = TT3 tt1
  24.138 + and tt4 = TT4
  24.139 +
  24.140 +(* SLOW
  24.141 +data s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
  24.142 + and s2 = S21 s7 s5 | S22 s5 s4 s6
  24.143 + and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
  24.144 + and s4 = S4 s5
  24.145 + and s5 = S5
  24.146 + and s6 = S61 s6 | S62 s1 s2 | S63 s6
  24.147 + and s7 = S71 s8 | S72 s5
  24.148 + and s8 = S8 nat
  24.149 +*)
  24.150 +
  24.151 +data ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
  24.152 +data ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
  24.153 +
  24.154 +data 'a dead_foo = A
  24.155 +data ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  24.156 +
  24.157 +end
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/BNF/Examples/Process.thy	Fri Sep 21 16:45:06 2012 +0200
    25.3 @@ -0,0 +1,367 @@
    25.4 +(*  Title:      HOL/BNF/Examples/Process.thy
    25.5 +    Author:     Andrei Popescu, TU Muenchen
    25.6 +    Copyright   2012
    25.7 +
    25.8 +Processes.
    25.9 +*)
   25.10 +
   25.11 +header {* Processes *}
   25.12 +
   25.13 +theory Process
   25.14 +imports "../BNF"
   25.15 +begin
   25.16 +
   25.17 +hide_fact (open) Quotient_Product.prod_rel_def
   25.18 +
   25.19 +codata 'a process =
   25.20 +  isAction: Action (prefOf: 'a) (contOf: "'a process") |
   25.21 +  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
   25.22 +
   25.23 +(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
   25.24 +
   25.25 +section {* Customization *}
   25.26 +
   25.27 +subsection {* Basic properties *}
   25.28 +
   25.29 +declare
   25.30 +  pre_process_rel_def[simp]
   25.31 +  sum_rel_def[simp]
   25.32 +  prod_rel_def[simp]
   25.33 +
   25.34 +(* Constructors versus discriminators *)
   25.35 +theorem isAction_isChoice:
   25.36 +"isAction p \<or> isChoice p"
   25.37 +by (rule process.disc_exhaust) auto
   25.38 +
   25.39 +theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
   25.40 +by (cases rule: process.exhaust[of p]) auto
   25.41 +
   25.42 +
   25.43 +subsection{* Coinduction *}
   25.44 +
   25.45 +theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
   25.46 +assumes phi: "\<phi> p p'" and
   25.47 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   25.48 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
   25.49 +Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
   25.50 +shows "p = p'"
   25.51 +proof(intro mp[OF process.rel_coinduct, of \<phi>, OF _ phi], clarify)
   25.52 +  fix p p'  assume \<phi>: "\<phi> p p'"
   25.53 +  show "pre_process_rel (op =) \<phi> (process_dtor p) (process_dtor p')"
   25.54 +  proof(cases rule: process.exhaust[of p])
   25.55 +    case (Action a q) note p = Action
   25.56 +    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
   25.57 +    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
   25.58 +    have 0: "a = a' \<and> \<phi> q q'" using Act[OF \<phi>[unfolded p p']] .
   25.59 +    have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
   25.60 +    unfolding p p' Action_def process.dtor_ctor by simp_all
   25.61 +    show ?thesis using 0 unfolding dtor by simp
   25.62 +  next
   25.63 +    case (Choice p1 p2) note p = Choice
   25.64 +    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
   25.65 +    then obtain p1' p2' where p': "p' = Choice p1' p2'"
   25.66 +    by (cases rule: process.exhaust[of p'], auto)
   25.67 +    have 0: "\<phi> p1 p1' \<and> \<phi> p2 p2'" using Ch[OF \<phi>[unfolded p p']] .
   25.68 +    have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
   25.69 +    unfolding p p' Choice_def process.dtor_ctor by simp_all
   25.70 +    show ?thesis using 0 unfolding dtor by simp
   25.71 +  qed
   25.72 +qed
   25.73 +
   25.74 +(* Stronger coinduction, up to equality: *)
   25.75 +theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
   25.76 +assumes phi: "\<phi> p p'" and
   25.77 +iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   25.78 +Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
   25.79 +Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
   25.80 +shows "p = p'"
   25.81 +proof(intro mp[OF process.rel_strong_coinduct, of \<phi>, OF _ phi], clarify)
   25.82 +  fix p p'  assume \<phi>: "\<phi> p p'"
   25.83 +  show "pre_process_rel (op =) (\<lambda>a b. \<phi> a b \<or> a = b) (process_dtor p) (process_dtor p')"
   25.84 +  proof(cases rule: process.exhaust[of p])
   25.85 +    case (Action a q) note p = Action
   25.86 +    hence "isAction p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
   25.87 +    then obtain a' q' where p': "p' = Action a' q'" by (cases rule: process.exhaust[of p'], auto)
   25.88 +    have 0: "a = a' \<and> (\<phi> q q' \<or> q = q')" using Act[OF \<phi>[unfolded p p']] .
   25.89 +    have dtor: "process_dtor p = Inl (a,q)" "process_dtor p' = Inl (a',q')"
   25.90 +    unfolding p p' Action_def process.dtor_ctor by simp_all
   25.91 +    show ?thesis using 0 unfolding dtor by simp
   25.92 +  next
   25.93 +    case (Choice p1 p2) note p = Choice
   25.94 +    hence "isChoice p'" using iss[OF \<phi>] by (cases rule: process.exhaust[of p'], auto)
   25.95 +    then obtain p1' p2' where p': "p' = Choice p1' p2'"
   25.96 +    by (cases rule: process.exhaust[of p'], auto)
   25.97 +    have 0: "(\<phi> p1 p1' \<or> p1 = p1') \<and> (\<phi> p2 p2' \<or> p2 = p2')" using Ch[OF \<phi>[unfolded p p']] .
   25.98 +    have dtor: "process_dtor p = Inr (p1,p2)" "process_dtor p' = Inr (p1',p2')"
   25.99 +    unfolding p p' Choice_def process.dtor_ctor by simp_all
  25.100 +    show ?thesis using 0 unfolding dtor by simp
  25.101 +  qed
  25.102 +qed
  25.103 +
  25.104 +
  25.105 +subsection {* Coiteration (unfold) *}
  25.106 +
  25.107 +
  25.108 +section{* Coinductive definition of the notion of trace *}
  25.109 +
  25.110 +(* Say we have a type of streams: *)
  25.111 +
  25.112 +typedecl 'a stream
  25.113 +
  25.114 +consts Ccons :: "'a \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
  25.115 +
  25.116 +(* Use the existing coinductive package (distinct from our
  25.117 +new codatatype package, but highly compatible with it): *)
  25.118 +
  25.119 +coinductive trace where
  25.120 +"trace p as \<Longrightarrow> trace (Action a p) (Ccons a as)"
  25.121 +|
  25.122 +"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
  25.123 +
  25.124 +
  25.125 +section{* Examples of corecursive definitions: *}
  25.126 +
  25.127 +subsection{* Single-guard fixpoint definition *}
  25.128 +
  25.129 +definition
  25.130 +"BX \<equiv>
  25.131 + process_unfold
  25.132 +   (\<lambda> P. True)
  25.133 +   (\<lambda> P. ''a'')
  25.134 +   (\<lambda> P. P)
  25.135 +   undefined
  25.136 +   undefined
  25.137 +   ()"
  25.138 +
  25.139 +lemma BX: "BX = Action ''a'' BX"
  25.140 +unfolding BX_def
  25.141 +using process.unfolds(1)[of "\<lambda> P. True" "()"  "\<lambda> P. ''a''" "\<lambda> P. P"] by simp
  25.142 +
  25.143 +
  25.144 +subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
  25.145 +
  25.146 +datatype x_y_ax = x | y | ax
  25.147 +
  25.148 +definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False     |y \<Rightarrow> True  |ax \<Rightarrow> True"
  25.149 +definition "pr  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
  25.150 +definition "co  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x    |ax \<Rightarrow> x"
  25.151 +lemmas Action_defs = isA_def pr_def co_def
  25.152 +
  25.153 +definition "c1  \<equiv> \<lambda> K. case K of x \<Rightarrow> ax   |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
  25.154 +definition "c2  \<equiv> \<lambda> K. case K of x \<Rightarrow> y    |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
  25.155 +lemmas Choice_defs = c1_def c2_def
  25.156 +
  25.157 +definition "F \<equiv> process_unfold isA pr co c1 c2"
  25.158 +definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
  25.159 +
  25.160 +lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
  25.161 +unfolding X_def Y_def AX_def F_def
  25.162 +using process.unfolds(2)[of isA x "pr" co c1 c2]
  25.163 +      process.unfolds(1)[of isA y "pr" co c1 c2]
  25.164 +      process.unfolds(1)[of isA ax "pr" co c1 c2]
  25.165 +unfolding Action_defs Choice_defs by simp_all
  25.166 +
  25.167 +(* end product: *)
  25.168 +lemma X_AX:
  25.169 +"X = Choice AX (Action ''b'' X)"
  25.170 +"AX = Action ''a'' X"
  25.171 +using X_Y_AX by simp_all
  25.172 +
  25.173 +
  25.174 +
  25.175 +section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
  25.176 +
  25.177 +hide_const x y ax X Y AX
  25.178 +
  25.179 +(* Process terms *)
  25.180 +datatype ('a,'pvar) process_term =
  25.181 + VAR 'pvar |
  25.182 + PROC "'a process" |
  25.183 + ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
  25.184 +
  25.185 +(* below, sys represents a system of equations *)
  25.186 +fun isACT where
  25.187 +"isACT sys (VAR X) =
  25.188 + (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
  25.189 +|
  25.190 +"isACT sys (PROC p) = isAction p"
  25.191 +|
  25.192 +"isACT sys (ACT a T) = True"
  25.193 +|
  25.194 +"isACT sys (CH T1 T2) = False"
  25.195 +
  25.196 +fun PREF where
  25.197 +"PREF sys (VAR X) =
  25.198 + (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
  25.199 +|
  25.200 +"PREF sys (PROC p) = prefOf p"
  25.201 +|
  25.202 +"PREF sys (ACT a T) = a"
  25.203 +
  25.204 +fun CONT where
  25.205 +"CONT sys (VAR X) =
  25.206 + (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
  25.207 +|
  25.208 +"CONT sys (PROC p) = PROC (contOf p)"
  25.209 +|
  25.210 +"CONT sys (ACT a T) = T"
  25.211 +
  25.212 +fun CH1 where
  25.213 +"CH1 sys (VAR X) =
  25.214 + (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
  25.215 +|
  25.216 +"CH1 sys (PROC p) = PROC (ch1Of p)"
  25.217 +|
  25.218 +"CH1 sys (CH T1 T2) = T1"
  25.219 +
  25.220 +fun CH2 where
  25.221 +"CH2 sys (VAR X) =
  25.222 + (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
  25.223 +|
  25.224 +"CH2 sys (PROC p) = PROC (ch2Of p)"
  25.225 +|
  25.226 +"CH2 sys (CH T1 T2) = T2"
  25.227 +
  25.228 +definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
  25.229 +
  25.230 +definition
  25.231 +"solution sys \<equiv>
  25.232 + process_unfold
  25.233 +   (isACT sys)
  25.234 +   (PREF sys)
  25.235 +   (CONT sys)
  25.236 +   (CH1 sys)
  25.237 +   (CH2 sys)"
  25.238 +
  25.239 +lemma solution_Action:
  25.240 +assumes "isACT sys T"
  25.241 +shows "solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
  25.242 +unfolding solution_def
  25.243 +using process.unfolds(1)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
  25.244 +  assms by simp
  25.245 +
  25.246 +lemma solution_Choice:
  25.247 +assumes "\<not> isACT sys T"
  25.248 +shows "solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
  25.249 +unfolding solution_def
  25.250 +using process.unfolds(2)[of "isACT sys" T "PREF sys" "CONT sys" "CH1 sys" "CH2 sys"]
  25.251 +  assms by simp
  25.252 +
  25.253 +lemma isACT_VAR:
  25.254 +assumes g: "guarded sys"
  25.255 +shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
  25.256 +using g unfolding guarded_def by (cases "sys X") auto
  25.257 +
  25.258 +lemma solution_VAR:
  25.259 +assumes g: "guarded sys"
  25.260 +shows "solution sys (VAR X) = solution sys (sys X)"
  25.261 +proof(cases "isACT sys (VAR X)")
  25.262 +  case True
  25.263 +  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  25.264 +  show ?thesis
  25.265 +  unfolding solution_Action[OF T] using solution_Action[of sys "VAR X"] True g
  25.266 +  unfolding guarded_def by (cases "sys X", auto)
  25.267 +next
  25.268 +  case False note FFalse = False
  25.269 +  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  25.270 +  show ?thesis
  25.271 +  unfolding solution_Choice[OF TT] using solution_Choice[of sys "VAR X"] FFalse g
  25.272 +  unfolding guarded_def by (cases "sys X", auto)
  25.273 +qed
  25.274 +
  25.275 +lemma solution_PROC[simp]:
  25.276 +"solution sys (PROC p) = p"
  25.277 +proof-
  25.278 +  {fix q assume "q = solution sys (PROC p)"
  25.279 +   hence "p = q"
  25.280 +   proof(induct rule: process_coind)
  25.281 +     case (iss p p')
  25.282 +     from isAction_isChoice[of p] show ?case
  25.283 +     proof
  25.284 +       assume p: "isAction p"
  25.285 +       hence 0: "isACT sys (PROC p)" by simp
  25.286 +       thus ?thesis using iss not_isAction_isChoice
  25.287 +       unfolding solution_Action[OF 0] by auto
  25.288 +     next
  25.289 +       assume "isChoice p"
  25.290 +       hence 0: "\<not> isACT sys (PROC p)"
  25.291 +       using not_isAction_isChoice by auto
  25.292 +       thus ?thesis using iss isAction_isChoice
  25.293 +       unfolding solution_Choice[OF 0] by auto
  25.294 +     qed
  25.295 +   next
  25.296 +     case (Action a a' p p')
  25.297 +     hence 0: "isACT sys (PROC (Action a p))" by simp
  25.298 +     show ?case using Action unfolding solution_Action[OF 0] by simp
  25.299 +   next
  25.300 +     case (Choice p q p' q')
  25.301 +     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
  25.302 +     show ?case using Choice unfolding solution_Choice[OF 0] by simp
  25.303 +   qed
  25.304 +  }
  25.305 +  thus ?thesis by metis
  25.306 +qed
  25.307 +
  25.308 +lemma solution_ACT[simp]:
  25.309 +"solution sys (ACT a T) = Action a (solution sys T)"
  25.310 +by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution_Action)
  25.311 +
  25.312 +lemma solution_CH[simp]:
  25.313 +"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
  25.314 +by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution_Choice)
  25.315 +
  25.316 +
  25.317 +(* Example: *)
  25.318 +
  25.319 +fun sys where
  25.320 +"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
  25.321 +|
  25.322 +"sys (Suc 0) = ACT ''a'' (VAR 0)"
  25.323 +| (* dummy guarded term for variables outside the system: *)
  25.324 +"sys X = ACT ''a'' (VAR 0)"
  25.325 +
  25.326 +lemma guarded_sys:
  25.327 +"guarded sys"
  25.328 +unfolding guarded_def proof (intro allI)
  25.329 +  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  25.330 +qed
  25.331 +
  25.332 +(* the actual processes: *)
  25.333 +definition "x \<equiv> solution sys (VAR 0)"
  25.334 +definition "ax \<equiv> solution sys (VAR (Suc 0))"
  25.335 +
  25.336 +(* end product: *)
  25.337 +lemma x_ax:
  25.338 +"x = Choice ax (Action ''b'' x)"
  25.339 +"ax = Action ''a'' x"
  25.340 +unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
  25.341 +
  25.342 +
  25.343 +(* Thanks to the inclusion of processes as process terms, one can
  25.344 +also consider parametrized systems of equations---here, x is a (semantic)
  25.345 +process parameter: *)
  25.346 +
  25.347 +fun sys' where
  25.348 +"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
  25.349 +|
  25.350 +"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
  25.351 +| (* dummy guarded term : *)
  25.352 +"sys' X = ACT ''a'' (VAR 0)"
  25.353 +
  25.354 +lemma guarded_sys':
  25.355 +"guarded sys'"
  25.356 +unfolding guarded_def proof (intro allI)
  25.357 +  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  25.358 +qed
  25.359 +
  25.360 +(* the actual processes: *)
  25.361 +definition "y \<equiv> solution sys' (VAR 0)"
  25.362 +definition "ay \<equiv> solution sys' (VAR (Suc 0))"
  25.363 +
  25.364 +(* end product: *)
  25.365 +lemma y_ay:
  25.366 +"y = Choice x (Action ''b'' y)"
  25.367 +"ay = Choice (Action ''a'' y) x"
  25.368 +unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
  25.369 +
  25.370 +end
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/BNF/Examples/Stream.thy	Fri Sep 21 16:45:06 2012 +0200
    26.3 @@ -0,0 +1,157 @@
    26.4 +(*  Title:      HOL/BNF/Examples/Stream.thy
    26.5 +    Author:     Dmitriy Traytel, TU Muenchen
    26.6 +    Author:     Andrei Popescu, TU Muenchen
    26.7 +    Copyright   2012
    26.8 +
    26.9 +Infinite streams.
   26.10 +*)
   26.11 +
   26.12 +header {* Infinite Streams *}
   26.13 +
   26.14 +theory Stream
   26.15 +imports TreeFI
   26.16 +begin
   26.17 +
   26.18 +hide_const (open) Quotient_Product.prod_rel
   26.19 +hide_fact (open) Quotient_Product.prod_rel_def
   26.20 +
   26.21 +codata_raw stream: 's = "'a \<times> 's"
   26.22 +
   26.23 +(* selectors for streams *)
   26.24 +definition "hdd as \<equiv> fst (stream_dtor as)"
   26.25 +definition "tll as \<equiv> snd (stream_dtor as)"
   26.26 +
   26.27 +lemma unfold_pair_fun_hdd[simp]: "hdd (stream_dtor_unfold (f \<odot> g) t) = f t"
   26.28 +unfolding hdd_def pair_fun_def stream.dtor_unfolds by simp
   26.29 +
   26.30 +lemma unfold_pair_fun_tll[simp]: "tll (stream_dtor_unfold (f \<odot> g) t) =
   26.31 + stream_dtor_unfold (f \<odot> g) (g t)"
   26.32 +unfolding tll_def pair_fun_def stream.dtor_unfolds by simp
   26.33 +
   26.34 +(* infinite trees: *)
   26.35 +coinductive infiniteTr where
   26.36 +"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   26.37 +
   26.38 +lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
   26.39 +assumes *: "phi tr" and
   26.40 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
   26.41 +shows "infiniteTr tr"
   26.42 +using assms by (elim infiniteTr.coinduct) blast
   26.43 +
   26.44 +lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   26.45 +assumes *: "phi tr" and
   26.46 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
   26.47 +shows "infiniteTr tr"
   26.48 +using assms by (elim infiniteTr.coinduct) blast
   26.49 +
   26.50 +lemma infiniteTr_sub[simp]:
   26.51 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
   26.52 +by (erule infiniteTr.cases) blast
   26.53 +
   26.54 +definition "konigPath \<equiv> stream_dtor_unfold
   26.55 +  (lab \<odot> (\<lambda>tr. SOME tr'. tr' \<in> listF_set (sub tr) \<and> infiniteTr tr'))"
   26.56 +
   26.57 +lemma hdd_simps1[simp]: "hdd (konigPath t) = lab t"
   26.58 +unfolding konigPath_def by simp
   26.59 +
   26.60 +lemma tll_simps2[simp]: "tll (konigPath t) =
   26.61 +  konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
   26.62 +unfolding konigPath_def by simp
   26.63 +
   26.64 +(* proper paths in trees: *)
   26.65 +coinductive properPath where
   26.66 +"\<lbrakk>hdd as = lab tr; tr' \<in> listF_set (sub tr); properPath (tll as) tr'\<rbrakk> \<Longrightarrow>
   26.67 + properPath as tr"
   26.68 +
   26.69 +lemma properPath_strong_coind[consumes 1, case_names hdd_lab sub]:
   26.70 +assumes *: "phi as tr" and
   26.71 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
   26.72 +***: "\<And> as tr.
   26.73 +         phi as tr \<Longrightarrow>
   26.74 +         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
   26.75 +shows "properPath as tr"
   26.76 +using assms by (elim properPath.coinduct) blast
   26.77 +
   26.78 +lemma properPath_coind[consumes 1, case_names hdd_lab sub, induct pred: properPath]:
   26.79 +assumes *: "phi as tr" and
   26.80 +**: "\<And> as tr. phi as tr \<Longrightarrow> hdd as = lab tr" and
   26.81 +***: "\<And> as tr.
   26.82 +         phi as tr \<Longrightarrow>
   26.83 +         \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr'"
   26.84 +shows "properPath as tr"
   26.85 +using properPath_strong_coind[of phi, OF * **] *** by blast
   26.86 +
   26.87 +lemma properPath_hdd_lab:
   26.88 +"properPath as tr \<Longrightarrow> hdd as = lab tr"
   26.89 +by (erule properPath.cases) blast
   26.90 +
   26.91 +lemma properPath_sub:
   26.92 +"properPath as tr \<Longrightarrow>
   26.93 + \<exists> tr' \<in> listF_set (sub tr). phi (tll as) tr' \<or> properPath (tll as) tr'"
   26.94 +by (erule properPath.cases) blast
   26.95 +
   26.96 +(* prove the following by coinduction *)
   26.97 +theorem Konig:
   26.98 +  assumes "infiniteTr tr"
   26.99 +  shows "properPath (konigPath tr) tr"
  26.100 +proof-
  26.101 +  {fix as
  26.102 +   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
  26.103 +   proof (induct rule: properPath_coind, safe)
  26.104 +     fix t
  26.105 +     let ?t = "SOME t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'"
  26.106 +     assume "infiniteTr t"
  26.107 +     hence "\<exists>t' \<in> listF_set (sub t). infiniteTr t'" by simp
  26.108 +     hence "\<exists>t'. t' \<in> listF_set (sub t) \<and> infiniteTr t'" by blast
  26.109 +     hence "?t \<in> listF_set (sub t) \<and> infiniteTr ?t" by (elim someI_ex)
  26.110 +     moreover have "tll (konigPath t) = konigPath ?t" by simp
  26.111 +     ultimately show "\<exists>t' \<in> listF_set (sub t).
  26.112 +             infiniteTr t' \<and> tll (konigPath t) = konigPath t'" by blast
  26.113 +   qed simp
  26.114 +  }
  26.115 +  thus ?thesis using assms by blast
  26.116 +qed
  26.117 +
  26.118 +(* some more stream theorems *)
  26.119 +
  26.120 +lemma stream_map[simp]: "stream_map f = stream_dtor_unfold (f o hdd \<odot> tll)"
  26.121 +unfolding stream_map_def pair_fun_def hdd_def[abs_def] tll_def[abs_def]
  26.122 +  map_pair_def o_def prod_case_beta by simp
  26.123 +
  26.124 +lemma prod_rel[simp]: "prod_rel \<phi>1 \<phi>2 a b = (\<phi>1 (fst a) (fst b) \<and> \<phi>2 (snd a) (snd b))"
  26.125 +unfolding prod_rel_def by auto
  26.126 +
  26.127 +lemmas stream_coind =
  26.128 +  mp[OF stream.rel_coinduct, unfolded prod_rel[abs_def], folded hdd_def tll_def]
  26.129 +
  26.130 +definition plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
  26.131 +  [simp]: "plus xs ys =
  26.132 +    stream_dtor_unfold ((%(xs, ys). hdd xs + hdd ys) \<odot> (%(xs, ys). (tll xs, tll ys))) (xs, ys)"
  26.133 +
  26.134 +definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  26.135 +  [simp]: "scalar n = stream_map (\<lambda>x. n * x)"
  26.136 +
  26.137 +definition ones :: "nat stream" where [simp]: "ones = stream_dtor_unfold ((%x. 1) \<odot> id) ()"
  26.138 +definition twos :: "nat stream" where [simp]: "twos = stream_dtor_unfold ((%x. 2) \<odot> id) ()"
  26.139 +definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
  26.140 +
  26.141 +lemma "ones \<oplus> ones = twos"
  26.142 +by (intro stream_coind[where P="%x1 x2. \<exists>x. x1 = ones \<oplus> ones \<and> x2 = twos"]) auto
  26.143 +
  26.144 +lemma "n \<cdot> twos = ns (2 * n)"
  26.145 +by (intro stream_coind[where P="%x1 x2. \<exists>n. x1 = n \<cdot> twos \<and> x2 = ns (2 * n)"]) force+
  26.146 +
  26.147 +lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  26.148 +by (intro stream_coind[where P="%x1 x2. \<exists>n m xs. x1 = (n * m) \<cdot> xs \<and> x2 = n \<cdot> m \<cdot> xs"]) force+
  26.149 +
  26.150 +lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  26.151 +by (intro stream_coind[where P="%x1 x2. \<exists>n xs ys. x1 = n \<cdot> (xs \<oplus> ys) \<and> x2 = n \<cdot> xs \<oplus> n \<cdot> ys"])
  26.152 +   (force simp: add_mult_distrib2)+
  26.153 +
  26.154 +lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  26.155 +by (intro stream_coind[where P="%x1 x2. \<exists>xs ys. x1 = xs \<oplus> ys \<and> x2 = ys \<oplus> xs"]) force+
  26.156 +
  26.157 +lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  26.158 +by (intro stream_coind[where P="%x1 x2. \<exists>xs ys zs. x1 = (xs \<oplus> ys) \<oplus> zs \<and> x2 = xs \<oplus> ys \<oplus> zs"]) force+
  26.159 +
  26.160 +end
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/HOL/BNF/Examples/TreeFI.thy	Fri Sep 21 16:45:06 2012 +0200
    27.3 @@ -0,0 +1,83 @@
    27.4 +(*  Title:      HOL/BNF/Examples/TreeFI.thy
    27.5 +    Author:     Dmitriy Traytel, TU Muenchen
    27.6 +    Author:     Andrei Popescu, TU Muenchen
    27.7 +    Copyright   2012
    27.8 +
    27.9 +Finitely branching possibly infinite trees.
   27.10 +*)
   27.11 +
   27.12 +header {* Finitely Branching Possibly Infinite Trees *}
   27.13 +
   27.14 +theory TreeFI
   27.15 +imports ListF
   27.16 +begin
   27.17 +
   27.18 +hide_const (open) Sublist.sub
   27.19 +
   27.20 +codata_raw treeFI: 'tree = "'a \<times> 'tree listF"
   27.21 +
   27.22 +lemma pre_treeFI_listF_set[simp]: "pre_treeFI_set2 (i, xs) = listF_set xs"
   27.23 +unfolding pre_treeFI_set2_def collect_def[abs_def] prod_set_defs
   27.24 +by (auto simp add: listF.set_natural')
   27.25 +
   27.26 +(* selectors for trees *)
   27.27 +definition "lab tr \<equiv> fst (treeFI_dtor tr)"
   27.28 +definition "sub tr \<equiv> snd (treeFI_dtor tr)"
   27.29 +
   27.30 +lemma dtor[simp]: "treeFI_dtor tr = (lab tr, sub tr)"
   27.31 +unfolding lab_def sub_def by simp
   27.32 +
   27.33 +definition pair_fun (infixr "\<odot>" 50) where
   27.34 +  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
   27.35 +
   27.36 +lemma unfold_pair_fun_lab: "lab (treeFI_dtor_unfold (f \<odot> g) t) = f t"
   27.37 +unfolding lab_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
   27.38 +
   27.39 +lemma unfold_pair_fun_sub: "sub (treeFI_dtor_unfold (f \<odot> g) t) = listF_map (treeFI_dtor_unfold (f \<odot> g)) (g t)"
   27.40 +unfolding sub_def pair_fun_def treeFI.dtor_unfolds pre_treeFI_map_def by simp
   27.41 +
   27.42 +(* Tree reverse:*)
   27.43 +definition "trev \<equiv> treeFI_dtor_unfold (lab \<odot> lrev o sub)"
   27.44 +
   27.45 +lemma trev_simps1[simp]: "lab (trev t) = lab t"
   27.46 +unfolding trev_def by (simp add: unfold_pair_fun_lab)
   27.47 +
   27.48 +lemma trev_simps2[simp]: "sub (trev t) = listF_map trev (lrev (sub t))"
   27.49 +unfolding trev_def by (simp add: unfold_pair_fun_sub)
   27.50 +
   27.51 +lemma treeFI_coinduct:
   27.52 +assumes *: "phi x y"
   27.53 +and step: "\<And>a b. phi a b \<Longrightarrow>
   27.54 +   lab a = lab b \<and>
   27.55 +   lengthh (sub a) = lengthh (sub b) \<and>
   27.56 +   (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
   27.57 +shows "x = y"
   27.58 +proof (rule mp[OF treeFI.dtor_coinduct, of phi, OF _ *])
   27.59 +  fix a b :: "'a treeFI"
   27.60 +  let ?zs = "zipp (sub a) (sub b)"
   27.61 +  let ?z = "(lab a, ?zs)"
   27.62 +  assume "phi a b"
   27.63 +  with step have step': "lab a = lab b" "lengthh (sub a) = lengthh (sub b)"
   27.64 +    "\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i)" by auto
   27.65 +  hence "pre_treeFI_map id fst ?z = treeFI_dtor a" "pre_treeFI_map id snd ?z = treeFI_dtor b"
   27.66 +    unfolding pre_treeFI_map_def by auto
   27.67 +  moreover have "\<forall>(x, y) \<in> pre_treeFI_set2 ?z. phi x y"
   27.68 +  proof safe
   27.69 +    fix z1 z2
   27.70 +    assume "(z1, z2) \<in> pre_treeFI_set2 ?z"
   27.71 +    hence "(z1, z2) \<in> listF_set ?zs" by auto
   27.72 +    hence "\<exists>i < lengthh ?zs. nthh ?zs i = (z1, z2)" by auto
   27.73 +    with step'(2) obtain i where "i < lengthh (sub a)"
   27.74 +      "nthh (sub a) i = z1" "nthh (sub b) i = z2" by auto
   27.75 +    with step'(3) show "phi z1 z2" by auto
   27.76 +  qed
   27.77 +  ultimately show "\<exists>z.
   27.78 +    (pre_treeFI_map id fst z = treeFI_dtor a \<and>
   27.79 +    pre_treeFI_map id snd z = treeFI_dtor b) \<and>
   27.80 +    (\<forall>x y. (x, y) \<in> pre_treeFI_set2 z \<longrightarrow> phi x y)" by blast
   27.81 +qed
   27.82 +
   27.83 +lemma trev_trev: "trev (trev tr) = tr"
   27.84 +by (rule treeFI_coinduct[of "%a b. trev (trev b) = a"]) auto
   27.85 +
   27.86 +end
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/HOL/BNF/Examples/TreeFsetI.thy	Fri Sep 21 16:45:06 2012 +0200
    28.3 @@ -0,0 +1,59 @@
    28.4 +(*  Title:      HOL/BNF/Examples/TreeFsetI.thy
    28.5 +    Author:     Dmitriy Traytel, TU Muenchen
    28.6 +    Author:     Andrei Popescu, TU Muenchen
    28.7 +    Copyright   2012
    28.8 +
    28.9 +Finitely branching possibly infinite trees, with sets of children.
   28.10 +*)
   28.11 +
   28.12 +header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
   28.13 +
   28.14 +theory TreeFsetI
   28.15 +imports "../BNF"
   28.16 +begin
   28.17 +
   28.18 +hide_const (open) Sublist.sub
   28.19 +hide_fact (open) Quotient_Product.prod_rel_def
   28.20 +
   28.21 +definition pair_fun (infixr "\<odot>" 50) where
   28.22 +  "f \<odot> g \<equiv> \<lambda>x. (f x, g x)"
   28.23 +
   28.24 +codata_raw treeFsetI: 't = "'a \<times> 't fset"
   28.25 +
   28.26 +(* selectors for trees *)
   28.27 +definition "lab t \<equiv> fst (treeFsetI_dtor t)"
   28.28 +definition "sub t \<equiv> snd (treeFsetI_dtor t)"
   28.29 +
   28.30 +lemma dtor[simp]: "treeFsetI_dtor t = (lab t, sub t)"
   28.31 +unfolding lab_def sub_def by simp
   28.32 +
   28.33 +lemma unfold_pair_fun_lab: "lab (treeFsetI_dtor_unfold (f \<odot> g) t) = f t"
   28.34 +unfolding lab_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
   28.35 +
   28.36 +lemma unfold_pair_fun_sub: "sub (treeFsetI_dtor_unfold (f \<odot> g) t) = map_fset (treeFsetI_dtor_unfold (f \<odot> g)) (g t)"
   28.37 +unfolding sub_def pair_fun_def treeFsetI.dtor_unfolds pre_treeFsetI_map_def by simp
   28.38 +
   28.39 +(* tree map (contrived example): *)
   28.40 +definition "tmap f \<equiv> treeFsetI_dtor_unfold (f o lab \<odot> sub)"
   28.41 +
   28.42 +lemma tmap_simps1[simp]: "lab (tmap f t) = f (lab t)"
   28.43 +unfolding tmap_def by (simp add: unfold_pair_fun_lab)
   28.44 +
   28.45 +lemma trev_simps2[simp]: "sub (tmap f t) = map_fset (tmap f) (sub t)"
   28.46 +unfolding tmap_def by (simp add: unfold_pair_fun_sub)
   28.47 +
   28.48 +lemma pre_treeFsetI_rel[simp]: "pre_treeFsetI_rel R1 R2 a b = (R1 (fst a) (fst b) \<and>
   28.49 +  (\<forall>t \<in> fset (snd a). (\<exists>u \<in> fset (snd b). R2 t u)) \<and>
   28.50 +  (\<forall>t \<in> fset (snd b). (\<exists>u \<in> fset (snd a). R2 u t)))"
   28.51 +apply (cases a)
   28.52 +apply (cases b)
   28.53 +apply (simp add: pre_treeFsetI_rel_def prod_rel_def fset_rel_def)
   28.54 +done
   28.55 +
   28.56 +lemmas treeFsetI_coind = mp[OF treeFsetI.rel_coinduct]
   28.57 +
   28.58 +lemma "tmap (f o g) x = tmap f (tmap g x)"
   28.59 +by (intro treeFsetI_coind[where P="%x1 x2. \<exists>x. x1 = tmap (f o g) x \<and> x2 = tmap f (tmap g x)"])
   28.60 +   force+
   28.61 +
   28.62 +end
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/BNF/More_BNFs.thy	Fri Sep 21 16:45:06 2012 +0200
    29.3 @@ -0,0 +1,1511 @@
    29.4 +(*  Title:      HOL/BNF/More_BNFs.thy
    29.5 +    Author:     Dmitriy Traytel, TU Muenchen
    29.6 +    Author:     Andrei Popescu, TU Muenchen
    29.7 +    Author:     Andreas Lochbihler, Karlsruhe Institute of Technology
    29.8 +    Author:     Jasmin Blanchette, TU Muenchen
    29.9 +    Copyright   2012
   29.10 +
   29.11 +Registration of various types as bounded natural functors.
   29.12 +*)
   29.13 +
   29.14 +header {* Registration of Various Types as Bounded Natural Functors *}
   29.15 +
   29.16 +theory More_BNFs
   29.17 +imports
   29.18 +  BNF_LFP
   29.19 +  BNF_GFP
   29.20 +  "~~/src/HOL/Quotient_Examples/FSet"
   29.21 +  "~~/src/HOL/Library/Multiset"
   29.22 +  Countable_Set
   29.23 +begin
   29.24 +
   29.25 +lemma option_rec_conv_option_case: "option_rec = option_case"
   29.26 +by (simp add: fun_eq_iff split: option.split)
   29.27 +
   29.28 +definition option_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> bool" where
   29.29 +"option_rel R x_opt y_opt =
   29.30 +  (case (x_opt, y_opt) of
   29.31 +    (None, None) \<Rightarrow> True
   29.32 +  | (Some x, Some y) \<Rightarrow> R x y
   29.33 +  | _ \<Rightarrow> False)"
   29.34 +
   29.35 +bnf_def Option.map [Option.set] "\<lambda>_::'a option. natLeq" ["None"] option_rel
   29.36 +proof -
   29.37 +  show "Option.map id = id" by (simp add: fun_eq_iff Option.map_def split: option.split)
   29.38 +next
   29.39 +  fix f g
   29.40 +  show "Option.map (g \<circ> f) = Option.map g \<circ> Option.map f"
   29.41 +    by (auto simp add: fun_eq_iff Option.map_def split: option.split)
   29.42 +next
   29.43 +  fix f g x
   29.44 +  assume "\<And>z. z \<in> Option.set x \<Longrightarrow> f z = g z"
   29.45 +  thus "Option.map f x = Option.map g x"
   29.46 +    by (simp cong: Option.map_cong)
   29.47 +next
   29.48 +  fix f
   29.49 +  show "Option.set \<circ> Option.map f = op ` f \<circ> Option.set"
   29.50 +    by fastforce
   29.51 +next
   29.52 +  show "card_order natLeq" by (rule natLeq_card_order)
   29.53 +next
   29.54 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
   29.55 +next
   29.56 +  fix x
   29.57 +  show "|Option.set x| \<le>o natLeq"
   29.58 +    by (cases x) (simp_all add: ordLess_imp_ordLeq finite_iff_ordLess_natLeq[symmetric])
   29.59 +next
   29.60 +  fix A
   29.61 +  have unfold: "{x. Option.set x \<subseteq> A} = Some ` A \<union> {None}"
   29.62 +    by (auto simp add: option_rec_conv_option_case Option.set_def split: option.split_asm)
   29.63 +  show "|{x. Option.set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
   29.64 +    apply (rule ordIso_ordLeq_trans)
   29.65 +    apply (rule card_of_ordIso_subst[OF unfold])
   29.66 +    apply (rule ordLeq_transitive)
   29.67 +    apply (rule Un_csum)
   29.68 +    apply (rule ordLeq_transitive)
   29.69 +    apply (rule csum_mono)
   29.70 +    apply (rule card_of_image)
   29.71 +    apply (rule ordIso_ordLeq_trans)
   29.72 +    apply (rule single_cone)
   29.73 +    apply (rule cone_ordLeq_ctwo)
   29.74 +    apply (rule ordLeq_cexp1)
   29.75 +    apply (simp_all add: natLeq_cinfinite natLeq_Card_order cinfinite_not_czero Card_order_csum)
   29.76 +    done
   29.77 +next
   29.78 +  fix A B1 B2 f1 f2 p1 p2
   29.79 +  assume wpull: "wpull A B1 B2 f1 f2 p1 p2"
   29.80 +  show "wpull {x. Option.set x \<subseteq> A} {x. Option.set x \<subseteq> B1} {x. Option.set x \<subseteq> B2}
   29.81 +    (Option.map f1) (Option.map f2) (Option.map p1) (Option.map p2)"
   29.82 +    (is "wpull ?A ?B1 ?B2 ?f1 ?f2 ?p1 ?p2")
   29.83 +    unfolding wpull_def
   29.84 +  proof (intro strip, elim conjE)
   29.85 +    fix b1 b2
   29.86 +    assume "b1 \<in> ?B1" "b2 \<in> ?B2" "?f1 b1 = ?f2 b2"
   29.87 +    thus "\<exists>a \<in> ?A. ?p1 a = b1 \<and> ?p2 a = b2" using wpull
   29.88 +      unfolding wpull_def by (cases b2) (auto 4 5)
   29.89 +  qed
   29.90 +next
   29.91 +  fix z
   29.92 +  assume "z \<in> Option.set None"
   29.93 +  thus False by simp
   29.94 +next
   29.95 +  fix R
   29.96 +  show "{p. option_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
   29.97 +        (Gr {x. Option.set x \<subseteq> R} (Option.map fst))\<inverse> O Gr {x. Option.set x \<subseteq> R} (Option.map snd)"
   29.98 +  unfolding option_rel_def Gr_def relcomp_unfold converse_unfold
   29.99 +  by (auto simp: trans[OF eq_commute option_map_is_None] trans[OF eq_commute option_map_eq_Some]
  29.100 +           split: option.splits) blast
  29.101 +qed
  29.102 +
  29.103 +lemma card_of_list_in:
  29.104 +  "|{xs. set xs \<subseteq> A}| \<le>o |Pfunc (UNIV :: nat set) A|" (is "|?LHS| \<le>o |?RHS|")
  29.105 +proof -
  29.106 +  let ?f = "%xs. %i. if i < length xs \<and> set xs \<subseteq> A then Some (nth xs i) else None"
  29.107 +  have "inj_on ?f ?LHS" unfolding inj_on_def fun_eq_iff
  29.108 +  proof safe
  29.109 +    fix xs :: "'a list" and ys :: "'a list"
  29.110 +    assume su: "set xs \<subseteq> A" "set ys \<subseteq> A" and eq: "\<forall>i. ?f xs i = ?f ys i"
  29.111 +    hence *: "length xs = length ys"
  29.112 +    by (metis linorder_cases option.simps(2) order_less_irrefl)
  29.113 +    thus "xs = ys" by (rule nth_equalityI) (metis * eq su option.inject)
  29.114 +  qed
  29.115 +  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Pfunc_def by fastforce
  29.116 +  ultimately show ?thesis using card_of_ordLeq by blast
  29.117 +qed
  29.118 +
  29.119 +lemma list_in_empty: "A = {} \<Longrightarrow> {x. set x \<subseteq> A} = {[]}"
  29.120 +by simp
  29.121 +
  29.122 +lemma card_of_Func: "|Func A B| =o |B| ^c |A|"
  29.123 +unfolding cexp_def Field_card_of by (rule card_of_refl)
  29.124 +
  29.125 +lemma not_emp_czero_notIn_ordIso_Card_order:
  29.126 +"A \<noteq> {} \<Longrightarrow> ( |A|, czero) \<notin> ordIso \<and> Card_order |A|"
  29.127 +  apply (rule conjI)
  29.128 +  apply (metis Field_card_of czeroE)
  29.129 +  by (rule card_of_Card_order)
  29.130 +
  29.131 +lemma list_in_bd: "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
  29.132 +proof -
  29.133 +  fix A :: "'a set"
  29.134 +  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
  29.135 +  proof (cases "A = {}")
  29.136 +    case False thus ?thesis
  29.137 +      apply -
  29.138 +      apply (rule ordLeq_transitive)
  29.139 +      apply (rule card_of_list_in)
  29.140 +      apply (rule ordLeq_transitive)
  29.141 +      apply (erule card_of_Pfunc_Pow_Func)
  29.142 +      apply (rule ordIso_ordLeq_trans)
  29.143 +      apply (rule Times_cprod)
  29.144 +      apply (rule cprod_cinfinite_bound)
  29.145 +      apply (rule ordIso_ordLeq_trans)
  29.146 +      apply (rule Pow_cexp_ctwo)
  29.147 +      apply (rule ordIso_ordLeq_trans)
  29.148 +      apply (rule cexp_cong2)
  29.149 +      apply (rule card_of_nat)
  29.150 +      apply (rule Card_order_ctwo)
  29.151 +      apply (rule card_of_Card_order)
  29.152 +      apply (rule natLeq_Card_order)
  29.153 +      apply (rule disjI1)
  29.154 +      apply (rule ctwo_Cnotzero)
  29.155 +      apply (rule cexp_mono1)
  29.156 +      apply (rule ordLeq_csum2)
  29.157 +      apply (rule Card_order_ctwo)
  29.158 +      apply (rule disjI1)
  29.159 +      apply (rule ctwo_Cnotzero)
  29.160 +      apply (rule natLeq_Card_order)
  29.161 +      apply (rule ordIso_ordLeq_trans)
  29.162 +      apply (rule card_of_Func)
  29.163 +      apply (rule ordIso_ordLeq_trans)
  29.164 +      apply (rule cexp_cong2)
  29.165 +      apply (rule card_of_nat)
  29.166 +      apply (rule card_of_Card_order)
  29.167 +      apply (rule card_of_Card_order)
  29.168 +      apply (rule natLeq_Card_order)
  29.169 +      apply (rule disjI1)
  29.170 +      apply (erule not_emp_czero_notIn_ordIso_Card_order)
  29.171 +      apply (rule cexp_mono1)
  29.172 +      apply (rule ordLeq_csum1)
  29.173 +      apply (rule card_of_Card_order)
  29.174 +      apply (rule disjI1)
  29.175 +      apply (erule not_emp_czero_notIn_ordIso_Card_order)
  29.176 +      apply (rule natLeq_Card_order)
  29.177 +      apply (rule card_of_Card_order)
  29.178 +      apply (rule card_of_Card_order)
  29.179 +      apply (rule Cinfinite_cexp)
  29.180 +      apply (rule ordLeq_csum2)
  29.181 +      apply (rule Card_order_ctwo)
  29.182 +      apply (rule conjI)
  29.183 +      apply (rule natLeq_cinfinite)
  29.184 +      by (rule natLeq_Card_order)
  29.185 +  next
  29.186 +    case True thus ?thesis
  29.187 +      apply -
  29.188 +      apply (rule ordIso_ordLeq_trans)
  29.189 +      apply (rule card_of_ordIso_subst)
  29.190 +      apply (erule list_in_empty)
  29.191 +      apply (rule ordIso_ordLeq_trans)
  29.192 +      apply (rule single_cone)
  29.193 +      apply (rule cone_ordLeq_cexp)
  29.194 +      apply (rule ordLeq_transitive)
  29.195 +      apply (rule cone_ordLeq_ctwo)
  29.196 +      apply (rule ordLeq_csum2)
  29.197 +      by (rule Card_order_ctwo)
  29.198 +  qed
  29.199 +qed
  29.200 +
  29.201 +bnf_def map [set] "\<lambda>_::'a list. natLeq" ["[]"]
  29.202 +proof -
  29.203 +  show "map id = id" by (rule List.map.id)
  29.204 +next
  29.205 +  fix f g
  29.206 +  show "map (g o f) = map g o map f" by (rule List.map.comp[symmetric])
  29.207 +next
  29.208 +  fix x f g
  29.209 +  assume "\<And>z. z \<in> set x \<Longrightarrow> f z = g z"
  29.210 +  thus "map f x = map g x" by simp
  29.211 +next
  29.212 +  fix f
  29.213 +  show "set o map f = image f o set" by (rule ext, unfold o_apply, rule set_map)
  29.214 +next
  29.215 +  show "card_order natLeq" by (rule natLeq_card_order)
  29.216 +next
  29.217 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  29.218 +next
  29.219 +  fix x
  29.220 +  show "|set x| \<le>o natLeq"
  29.221 +    apply (rule ordLess_imp_ordLeq)
  29.222 +    apply (rule finite_ordLess_infinite[OF _ natLeq_Well_order])
  29.223 +    unfolding Field_natLeq Field_card_of by (auto simp: card_of_well_order_on)
  29.224 +next
  29.225 +  fix A :: "'a set"
  29.226 +  show "|{x. set x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
  29.227 +next
  29.228 +  fix A B1 B2 f1 f2 p1 p2
  29.229 +  assume "wpull A B1 B2 f1 f2 p1 p2"
  29.230 +  hence pull: "\<And>b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<Longrightarrow> \<exists>a \<in> A. p1 a = b1 \<and> p2 a = b2"
  29.231 +    unfolding wpull_def by auto
  29.232 +  show "wpull {x. set x \<subseteq> A} {x. set x \<subseteq> B1} {x. set x \<subseteq> B2} (map f1) (map f2) (map p1) (map p2)"
  29.233 +    (is "wpull ?A ?B1 ?B2 _ _ _ _")
  29.234 +  proof (unfold wpull_def)
  29.235 +    { fix as bs assume *: "as \<in> ?B1" "bs \<in> ?B2" "map f1 as = map f2 bs"
  29.236 +      hence "length as = length bs" by (metis length_map)
  29.237 +      hence "\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs" using *
  29.238 +      proof (induct as bs rule: list_induct2)
  29.239 +        case (Cons a as b bs)
  29.240 +        hence "a \<in> B1" "b \<in> B2" "f1 a = f2 b" by auto
  29.241 +        with pull obtain z where "z \<in> A" "p1 z = a" "p2 z = b" by blast
  29.242 +        moreover
  29.243 +        from Cons obtain zs where "zs \<in> ?A" "map p1 zs = as" "map p2 zs = bs" by auto
  29.244 +        ultimately have "z # zs \<in> ?A" "map p1 (z # zs) = a # as \<and> map p2 (z # zs) = b # bs" by auto
  29.245 +        thus ?case by (rule_tac x = "z # zs" in bexI)
  29.246 +      qed simp
  29.247 +    }
  29.248 +    thus "\<forall>as bs. as \<in> ?B1 \<and> bs \<in> ?B2 \<and> map f1 as = map f2 bs \<longrightarrow>
  29.249 +      (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
  29.250 +  qed
  29.251 +qed simp+
  29.252 +
  29.253 +(* Finite sets *)
  29.254 +abbreviation afset where "afset \<equiv> abs_fset"
  29.255 +abbreviation rfset where "rfset \<equiv> rep_fset"
  29.256 +
  29.257 +lemma fset_fset_member:
  29.258 +"fset A = {a. a |\<in>| A}"
  29.259 +unfolding fset_def fset_member_def by auto
  29.260 +
  29.261 +lemma afset_rfset:
  29.262 +"afset (rfset x) = x"
  29.263 +by (rule Quotient_fset[unfolded Quotient_def, THEN conjunct1, rule_format])
  29.264 +
  29.265 +lemma afset_rfset_id:
  29.266 +"afset o rfset = id"
  29.267 +unfolding comp_def afset_rfset id_def ..
  29.268 +
  29.269 +lemma rfset:
  29.270 +"rfset A = rfset B \<longleftrightarrow> A = B"
  29.271 +by (metis afset_rfset)
  29.272 +
  29.273 +lemma afset_set:
  29.274 +"afset as = afset bs \<longleftrightarrow> set as = set bs"
  29.275 +using Quotient_fset unfolding Quotient_def list_eq_def by auto
  29.276 +
  29.277 +lemma surj_afset:
  29.278 +"\<exists> as. A = afset as"
  29.279 +by (metis afset_rfset)
  29.280 +
  29.281 +lemma fset_def2:
  29.282 +"fset = set o rfset"
  29.283 +unfolding fset_def map_fun_def[abs_def] by simp
  29.284 +
  29.285 +lemma fset_def2_raw:
  29.286 +"fset A = set (rfset A)"
  29.287 +unfolding fset_def2 by simp
  29.288 +
  29.289 +lemma fset_comp_afset:
  29.290 +"fset o afset = set"
  29.291 +unfolding fset_def2 comp_def apply(rule ext)
  29.292 +unfolding afset_set[symmetric] afset_rfset ..
  29.293 +
  29.294 +lemma fset_afset:
  29.295 +"fset (afset as) = set as"
  29.296 +unfolding fset_comp_afset[symmetric] by simp
  29.297 +
  29.298 +lemma set_rfset_afset:
  29.299 +"set (rfset (afset as)) = set as"
  29.300 +unfolding afset_set[symmetric] afset_rfset ..
  29.301 +
  29.302 +lemma map_fset_comp_afset:
  29.303 +"(map_fset f) o afset = afset o (map f)"
  29.304 +unfolding map_fset_def map_fun_def[abs_def] comp_def apply(rule ext)
  29.305 +unfolding afset_set set_map set_rfset_afset id_apply ..
  29.306 +
  29.307 +lemma map_fset_afset:
  29.308 +"(map_fset f) (afset as) = afset (map f as)"
  29.309 +using map_fset_comp_afset unfolding comp_def fun_eq_iff by auto
  29.310 +
  29.311 +lemma fset_map_fset:
  29.312 +"fset (map_fset f A) = (image f) (fset A)"
  29.313 +apply(subst afset_rfset[symmetric, of A])
  29.314 +unfolding map_fset_afset fset_afset set_map
  29.315 +unfolding fset_def2_raw ..
  29.316 +
  29.317 +lemma map_fset_def2:
  29.318 +"map_fset f = afset o (map f) o rfset"
  29.319 +unfolding map_fset_def map_fun_def[abs_def] by simp
  29.320 +
  29.321 +lemma map_fset_def2_raw:
  29.322 +"map_fset f A = afset (map f (rfset A))"
  29.323 +unfolding map_fset_def2 by simp
  29.324 +
  29.325 +lemma finite_ex_fset:
  29.326 +assumes "finite A"
  29.327 +shows "\<exists> B. fset B = A"
  29.328 +by (metis assms finite_list fset_afset)
  29.329 +
  29.330 +lemma wpull_image:
  29.331 +assumes "wpull A B1 B2 f1 f2 p1 p2"
  29.332 +shows "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
  29.333 +unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
  29.334 +  fix Y1 Y2 assume Y1: "Y1 \<subseteq> B1" and Y2: "Y2 \<subseteq> B2" and EQ: "f1 ` Y1 = f2 ` Y2"
  29.335 +  def X \<equiv> "{a \<in> A. p1 a \<in> Y1 \<and> p2 a \<in> Y2}"
  29.336 +  show "\<exists>X\<subseteq>A. p1 ` X = Y1 \<and> p2 ` X = Y2"
  29.337 +  proof (rule exI[of _ X], intro conjI)
  29.338 +    show "p1 ` X = Y1"
  29.339 +    proof
  29.340 +      show "Y1 \<subseteq> p1 ` X"
  29.341 +      proof safe
  29.342 +        fix y1 assume y1: "y1 \<in> Y1"
  29.343 +        then obtain y2 where y2: "y2 \<in> Y2" and eq: "f1 y1 = f2 y2" using EQ by auto
  29.344 +        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
  29.345 +        using assms y1 Y1 Y2 unfolding wpull_def by blast
  29.346 +        thus "y1 \<in> p1 ` X" unfolding X_def using y1 y2 by auto
  29.347 +      qed
  29.348 +    qed(unfold X_def, auto)
  29.349 +    show "p2 ` X = Y2"
  29.350 +    proof
  29.351 +      show "Y2 \<subseteq> p2 ` X"
  29.352 +      proof safe
  29.353 +        fix y2 assume y2: "y2 \<in> Y2"
  29.354 +        then obtain y1 where y1: "y1 \<in> Y1" and eq: "f1 y1 = f2 y2" using EQ by force
  29.355 +        then obtain x where "x \<in> A" and "p1 x = y1" and "p2 x = y2"
  29.356 +        using assms y2 Y1 Y2 unfolding wpull_def by blast
  29.357 +        thus "y2 \<in> p2 ` X" unfolding X_def using y1 y2 by auto
  29.358 +      qed
  29.359 +    qed(unfold X_def, auto)
  29.360 +  qed(unfold X_def, auto)
  29.361 +qed
  29.362 +
  29.363 +lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
  29.364 +by (rule f_the_inv_into_f) (auto simp: inj_on_def fset_cong dest!: finite_ex_fset)
  29.365 +
  29.366 +definition fset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" where
  29.367 +"fset_rel R a b \<longleftrightarrow>
  29.368 + (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and>
  29.369 + (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
  29.370 +
  29.371 +lemma fset_rel_aux:
  29.372 +"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
  29.373 + (a, b) \<in> (Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset fst))\<inverse> O
  29.374 +          Gr {a. fset a \<subseteq> {(a, b). R a b}} (map_fset snd)" (is "?L = ?R")
  29.375 +proof
  29.376 +  assume ?L
  29.377 +  def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?L'")
  29.378 +  have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) auto
  29.379 +  hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
  29.380 +  show ?R unfolding Gr_def relcomp_unfold converse_unfold
  29.381 +  proof (intro CollectI prod_caseI exI conjI)
  29.382 +    from * show "(R', a) = (R', map_fset fst R')" using conjunct1[OF `?L`]
  29.383 +      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
  29.384 +    from * show "(R', b) = (R', map_fset snd R')" using conjunct2[OF `?L`]
  29.385 +      by (auto simp add: fset_cong[symmetric] image_def Int_def split: prod.splits)
  29.386 +  qed (auto simp add: *)
  29.387 +next
  29.388 +  assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
  29.389 +  apply (simp add: subset_eq Ball_def)
  29.390 +  apply (rule conjI)
  29.391 +  apply (clarsimp, metis snd_conv)
  29.392 +  by (clarsimp, metis fst_conv)
  29.393 +qed
  29.394 +
  29.395 +bnf_def map_fset [fset] "\<lambda>_::'a fset. natLeq" ["{||}"] fset_rel
  29.396 +proof -
  29.397 +  show "map_fset id = id"
  29.398 +  unfolding map_fset_def2 map_id o_id afset_rfset_id ..
  29.399 +next
  29.400 +  fix f g
  29.401 +  show "map_fset (g o f) = map_fset g o map_fset f"
  29.402 +  unfolding map_fset_def2 map.comp[symmetric] comp_def apply(rule ext)
  29.403 +  unfolding afset_set set_map fset_def2_raw[symmetric] image_image[symmetric]
  29.404 +  unfolding map_fset_afset[symmetric] map_fset_image afset_rfset
  29.405 +  by (rule refl)
  29.406 +next
  29.407 +  fix x f g
  29.408 +  assume "\<And>z. z \<in> fset x \<Longrightarrow> f z = g z"
  29.409 +  hence "map f (rfset x) = map g (rfset x)"
  29.410 +  apply(intro map_cong) unfolding fset_def2_raw by auto
  29.411 +  thus "map_fset f x = map_fset g x" unfolding map_fset_def2_raw
  29.412 +  by (rule arg_cong)
  29.413 +next
  29.414 +  fix f
  29.415 +  show "fset o map_fset f = image f o fset"
  29.416 +  unfolding comp_def fset_map_fset ..
  29.417 +next
  29.418 +  show "card_order natLeq" by (rule natLeq_card_order)
  29.419 +next
  29.420 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  29.421 +next
  29.422 +  fix x
  29.423 +  show "|fset x| \<le>o natLeq"
  29.424 +  unfolding fset_def2_raw
  29.425 +  apply (rule ordLess_imp_ordLeq)
  29.426 +  apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
  29.427 +  by (rule finite_set)
  29.428 +next
  29.429 +  fix A :: "'a set"
  29.430 +  have "|{x. fset x \<subseteq> A}| \<le>o |afset ` {as. set as \<subseteq> A}|"
  29.431 +  apply(rule card_of_mono1) unfolding fset_def2_raw apply auto
  29.432 +  apply (rule image_eqI)
  29.433 +  by (auto simp: afset_rfset)
  29.434 +  also have "|afset ` {as. set as \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_image .
  29.435 +  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" by (rule list_in_bd)
  29.436 +  finally show "|{x. fset x \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
  29.437 +next
  29.438 +  fix A B1 B2 f1 f2 p1 p2
  29.439 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
  29.440 +  hence "wpull (Pow A) (Pow B1) (Pow B2) (image f1) (image f2) (image p1) (image p2)"
  29.441 +  by (rule wpull_image)
  29.442 +  show "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
  29.443 +              (map_fset f1) (map_fset f2) (map_fset p1) (map_fset p2)"
  29.444 +  unfolding wpull_def Pow_def Bex_def mem_Collect_eq proof clarify
  29.445 +    fix y1 y2
  29.446 +    assume Y1: "fset y1 \<subseteq> B1" and Y2: "fset y2 \<subseteq> B2"
  29.447 +    assume "map_fset f1 y1 = map_fset f2 y2"
  29.448 +    hence EQ: "f1 ` (fset y1) = f2 ` (fset y2)" unfolding map_fset_def2_raw
  29.449 +    unfolding afset_set set_map fset_def2_raw .
  29.450 +    with Y1 Y2 obtain X where X: "X \<subseteq> A"
  29.451 +    and Y1: "p1 ` X = fset y1" and Y2: "p2 ` X = fset y2"
  29.452 +    using wpull_image[OF wp] unfolding wpull_def Pow_def
  29.453 +    unfolding Bex_def mem_Collect_eq apply -
  29.454 +    apply(erule allE[of _ "fset y1"], erule allE[of _ "fset y2"]) by auto
  29.455 +    have "\<forall> y1' \<in> fset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
  29.456 +    then obtain q1 where q1: "\<forall> y1' \<in> fset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
  29.457 +    have "\<forall> y2' \<in> fset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
  29.458 +    then obtain q2 where q2: "\<forall> y2' \<in> fset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
  29.459 +    def X' \<equiv> "q1 ` (fset y1) \<union> q2 ` (fset y2)"
  29.460 +    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = fset y1" and Y2: "p2 ` X' = fset y2"
  29.461 +    using X Y1 Y2 q1 q2 unfolding X'_def by auto
  29.462 +    have fX': "finite X'" unfolding X'_def by simp
  29.463 +    then obtain x where X'eq: "X' = fset x" by (auto dest: finite_ex_fset)
  29.464 +    show "\<exists>x. fset x \<subseteq> A \<and> map_fset p1 x = y1 \<and> map_fset p2 x = y2"
  29.465 +    apply(intro exI[of _ "x"]) using X' Y1 Y2
  29.466 +    unfolding X'eq map_fset_def2_raw fset_def2_raw set_map[symmetric]
  29.467 +    afset_set[symmetric] afset_rfset by simp
  29.468 +  qed
  29.469 +next
  29.470 +  fix R
  29.471 +  show "{p. fset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
  29.472 +        (Gr {x. fset x \<subseteq> R} (map_fset fst))\<inverse> O Gr {x. fset x \<subseteq> R} (map_fset snd)"
  29.473 +  unfolding fset_rel_def fset_rel_aux by simp
  29.474 +qed auto
  29.475 +
  29.476 +(* Countable sets *)
  29.477 +
  29.478 +lemma card_of_countable_sets_range:
  29.479 +fixes A :: "'a set"
  29.480 +shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
  29.481 +apply(rule card_of_ordLeqI[of fromNat]) using inj_on_fromNat
  29.482 +unfolding inj_on_def by auto
  29.483 +
  29.484 +lemma card_of_countable_sets_Func:
  29.485 +"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
  29.486 +using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
  29.487 +unfolding cexp_def Field_natLeq Field_card_of
  29.488 +by (rule ordLeq_ordIso_trans)
  29.489 +
  29.490 +lemma ordLeq_countable_subsets:
  29.491 +"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
  29.492 +apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
  29.493 +
  29.494 +lemma finite_countable_subset:
  29.495 +"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
  29.496 +apply default
  29.497 + apply (erule contrapos_pp)
  29.498 + apply (rule card_of_ordLeq_infinite)
  29.499 + apply (rule ordLeq_countable_subsets)
  29.500 + apply assumption
  29.501 +apply (rule finite_Collect_conjI)
  29.502 +apply (rule disjI1)
  29.503 +by (erule finite_Collect_subsets)
  29.504 +
  29.505 +lemma card_of_countable_sets:
  29.506 +"|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
  29.507 +(is "|?L| \<le>o _")
  29.508 +proof(cases "finite A")
  29.509 +  let ?R = "Func (UNIV::nat set) (A <+> (UNIV::bool set))"
  29.510 +  case True hence "finite ?L" by simp
  29.511 +  moreover have "infinite ?R"
  29.512 +  apply(rule infinite_Func[of _ "Inr True" "Inr False"]) by auto
  29.513 +  ultimately show ?thesis unfolding cexp_def csum_def ctwo_def Field_natLeq Field_card_of
  29.514 +  apply(intro ordLess_imp_ordLeq) by (rule finite_ordLess_infinite2)
  29.515 +next
  29.516 +  case False
  29.517 +  hence "|{X. X \<subseteq> A \<and> countable X}| =o |{X. X \<subseteq> A \<and> countable X} - {{}}|"
  29.518 +  by (intro card_of_infinite_diff_finitte finite.emptyI finite.insertI ordIso_symmetric)
  29.519 +     (unfold finite_countable_subset)
  29.520 +  also have "|{X. X \<subseteq> A \<and> countable X} - {{}}| \<le>o |A| ^c natLeq"
  29.521 +  using card_of_countable_sets_Func[of A] unfolding set_diff_eq by auto
  29.522 +  also have "|A| ^c natLeq \<le>o ( |A| +c ctwo) ^c natLeq"
  29.523 +  apply(rule cexp_mono1_cone_ordLeq)
  29.524 +    apply(rule ordLeq_csum1, rule card_of_Card_order)
  29.525 +    apply (rule cone_ordLeq_cexp)
  29.526 +    apply (rule cone_ordLeq_Cnotzero)
  29.527 +    using csum_Cnotzero2 ctwo_Cnotzero apply blast
  29.528 +    by (rule natLeq_Card_order)
  29.529 +  finally show ?thesis .
  29.530 +qed
  29.531 +
  29.532 +lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
  29.533 +apply (rule f_the_inv_into_f)
  29.534 +unfolding inj_on_def rcset_inj using rcset_surj by auto
  29.535 +
  29.536 +lemma Collect_Int_Times:
  29.537 +"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
  29.538 +by auto
  29.539 +
  29.540 +lemma rcset_natural': "rcset (cIm f x) = f ` rcset x"
  29.541 +unfolding cIm_def[abs_def] by simp
  29.542 +
  29.543 +definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
  29.544 +"cset_rel R a b \<longleftrightarrow>
  29.545 + (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
  29.546 + (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
  29.547 +
  29.548 +lemma cset_rel_aux:
  29.549 +"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
  29.550 + (a, b) \<in> (Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm fst))\<inverse> O
  29.551 +          Gr {x. rcset x \<subseteq> {(a, b). R a b}} (cIm snd)" (is "?L = ?R")
  29.552 +proof
  29.553 +  assume ?L
  29.554 +  def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
  29.555 +  (is "the_inv rcset ?L'")
  29.556 +  have "countable ?L'" by auto
  29.557 +  hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
  29.558 +  show ?R unfolding Gr_def relcomp_unfold converse_unfold
  29.559 +  proof (intro CollectI prod_caseI exI conjI)
  29.560 +    have "rcset a = fst ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?A")
  29.561 +    using conjunct1[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
  29.562 +    hence "a = acset ?A" by (metis acset_rcset)
  29.563 +    thus "(R', a) = (R', cIm fst R')" unfolding cIm_def * by auto
  29.564 +    have "rcset b = snd ` ({(x, y). R x y} \<inter> rcset a \<times> rcset b)" (is "_ = ?B")
  29.565 +    using conjunct2[OF `?L`] unfolding image_def by (auto simp add: Collect_Int_Times)
  29.566 +    hence "b = acset ?B" by (metis acset_rcset)
  29.567 +    thus "(R', b) = (R', cIm snd R')" unfolding cIm_def * by auto
  29.568 +  qed (auto simp add: *)
  29.569 +next
  29.570 +  assume ?R thus ?L unfolding Gr_def relcomp_unfold converse_unfold
  29.571 +  apply (simp add: subset_eq Ball_def)
  29.572 +  apply (rule conjI)
  29.573 +  apply (clarsimp, metis (lifting, no_types) rcset_natural' image_iff surjective_pairing)
  29.574 +  apply (clarsimp)
  29.575 +  by (metis Domain.intros Range.simps rcset_natural' fst_eq_Domain snd_eq_Range)
  29.576 +qed
  29.577 +
  29.578 +bnf_def cIm [rcset] "\<lambda>_::'a cset. natLeq" ["cEmp"] cset_rel
  29.579 +proof -
  29.580 +  show "cIm id = id" unfolding cIm_def[abs_def] id_def by auto
  29.581 +next
  29.582 +  fix f g show "cIm (g \<circ> f) = cIm g \<circ> cIm f"
  29.583 +  unfolding cIm_def[abs_def] apply(rule ext) unfolding comp_def by auto
  29.584 +next
  29.585 +  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
  29.586 +  thus "cIm f C = cIm g C"
  29.587 +  unfolding cIm_def[abs_def] unfolding image_def by auto
  29.588 +next
  29.589 +  fix f show "rcset \<circ> cIm f = op ` f \<circ> rcset" unfolding cIm_def[abs_def] by auto
  29.590 +next
  29.591 +  show "card_order natLeq" by (rule natLeq_card_order)
  29.592 +next
  29.593 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  29.594 +next
  29.595 +  fix C show "|rcset C| \<le>o natLeq" using rcset unfolding countable_def .
  29.596 +next
  29.597 +  fix A :: "'a set"
  29.598 +  have "|{Z. rcset Z \<subseteq> A}| \<le>o |acset ` {X. X \<subseteq> A \<and> countable X}|"
  29.599 +  apply(rule card_of_mono1) unfolding Pow_def image_def
  29.600 +  proof (rule Collect_mono, clarsimp)
  29.601 +    fix x
  29.602 +    assume "rcset x \<subseteq> A"
  29.603 +    hence "rcset x \<subseteq> A \<and> countable (rcset x) \<and> x = acset (rcset x)"
  29.604 +    using acset_rcset[of x] rcset[of x] by force
  29.605 +    thus "\<exists>y \<subseteq> A. countable y \<and> x = acset y" by blast
  29.606 +  qed
  29.607 +  also have "|acset ` {X. X \<subseteq> A \<and> countable X}| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
  29.608 +  using card_of_image .
  29.609 +  also have "|{X. X \<subseteq> A \<and> countable X}| \<le>o ( |A| +c ctwo) ^c natLeq"
  29.610 +  using card_of_countable_sets .
  29.611 +  finally show "|{Z. rcset Z \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
  29.612 +next
  29.613 +  fix A B1 B2 f1 f2 p1 p2
  29.614 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
  29.615 +  show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
  29.616 +              (cIm f1) (cIm f2) (cIm p1) (cIm p2)"
  29.617 +  unfolding wpull_def proof safe
  29.618 +    fix y1 y2
  29.619 +    assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
  29.620 +    assume "cIm f1 y1 = cIm f2 y2"
  29.621 +    hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)"
  29.622 +    unfolding cIm_def by auto
  29.623 +    with Y1 Y2 obtain X where X: "X \<subseteq> A"
  29.624 +    and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
  29.625 +    using wpull_image[OF wp] unfolding wpull_def Pow_def
  29.626 +    unfolding Bex_def mem_Collect_eq apply -
  29.627 +    apply(erule allE[of _ "rcset y1"], erule allE[of _ "rcset y2"]) by auto
  29.628 +    have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
  29.629 +    then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
  29.630 +    have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
  29.631 +    then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
  29.632 +    def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
  29.633 +    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
  29.634 +    using X Y1 Y2 q1 q2 unfolding X'_def by fast+
  29.635 +    have fX': "countable X'" unfolding X'_def by simp
  29.636 +    then obtain x where X'eq: "X' = rcset x" by (metis rcset_acset)
  29.637 +    show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cIm p1 x = y1 \<and> cIm p2 x = y2"
  29.638 +    apply(intro bexI[of _ "x"]) using X' Y1 Y2 unfolding X'eq cIm_def by auto
  29.639 +  qed
  29.640 +next
  29.641 +  fix R
  29.642 +  show "{p. cset_rel (\<lambda>x y. (x, y) \<in> R) (fst p) (snd p)} =
  29.643 +        (Gr {x. rcset x \<subseteq> R} (cIm fst))\<inverse> O Gr {x. rcset x \<subseteq> R} (cIm snd)"
  29.644 +  unfolding cset_rel_def cset_rel_aux by simp
  29.645 +qed (unfold cEmp_def, auto)
  29.646 +
  29.647 +
  29.648 +(* Multisets *)
  29.649 +
  29.650 +(* The cardinal of a mutiset: this, and the following basic lemmas about it,
  29.651 +should eventually go into Multiset.thy *)
  29.652 +definition "mcard M \<equiv> setsum (count M) {a. count M a > 0}"
  29.653 +
  29.654 +lemma mcard_emp[simp]: "mcard {#} = 0"
  29.655 +unfolding mcard_def by auto
  29.656 +
  29.657 +lemma mcard_emp_iff[simp]: "mcard M = 0 \<longleftrightarrow> M = {#}"
  29.658 +unfolding mcard_def apply safe
  29.659 +  apply simp_all
  29.660 +  by (metis multi_count_eq zero_multiset.rep_eq)
  29.661 +
  29.662 +lemma mcard_singl[simp]: "mcard {#a#} = Suc 0"
  29.663 +unfolding mcard_def by auto
  29.664 +
  29.665 +lemma mcard_Plus[simp]: "mcard (M + N) = mcard M + mcard N"
  29.666 +proof-
  29.667 +  have "setsum (count M) {a. 0 < count M a + count N a} =
  29.668 +        setsum (count M) {a. a \<in># M}"
  29.669 +  apply(rule setsum_mono_zero_cong_right) by auto
  29.670 +  moreover
  29.671 +  have "setsum (count N) {a. 0 < count M a + count N a} =
  29.672 +        setsum (count N) {a. a \<in># N}"
  29.673 +  apply(rule setsum_mono_zero_cong_right) by auto
  29.674 +  ultimately show ?thesis
  29.675 +  unfolding mcard_def count_union[THEN ext] comm_monoid_add_class.setsum.F_fun_f by simp
  29.676 +qed
  29.677 +
  29.678 +lemma setsum_gt_0_iff:
  29.679 +fixes f :: "'a \<Rightarrow> nat" assumes "finite A"
  29.680 +shows "setsum f A > 0 \<longleftrightarrow> (\<exists> a \<in> A. f a > 0)"
  29.681 +(is "?L \<longleftrightarrow> ?R")
  29.682 +proof-
  29.683 +  have "?L \<longleftrightarrow> \<not> setsum f A = 0" by fast
  29.684 +  also have "... \<longleftrightarrow> (\<exists> a \<in> A. f a \<noteq> 0)" using assms by simp
  29.685 +  also have "... \<longleftrightarrow> ?R" by simp
  29.686 +  finally show ?thesis .
  29.687 +qed
  29.688 +
  29.689 +(*   *)
  29.690 +definition mmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> 'b \<Rightarrow> nat" where
  29.691 +"mmap h f b = setsum f {a. h a = b \<and> f a > 0}"
  29.692 +
  29.693 +lemma mmap_id: "mmap id = id"
  29.694 +proof (rule ext)+
  29.695 +  fix f a show "mmap id f a = id f a"
  29.696 +  proof(cases "f a = 0")
  29.697 +    case False
  29.698 +    hence 1: "{aa. aa = a \<and> 0 < f aa} = {a}" by auto
  29.699 +    show ?thesis by (simp add: mmap_def id_apply 1)
  29.700 +  qed(unfold mmap_def, auto)
  29.701 +qed
  29.702 +
  29.703 +lemma inj_on_setsum_inv:
  29.704 +assumes f: "f \<in> multiset"
  29.705 +and 1: "(0::nat) < setsum f {a. h a = b' \<and> 0 < f a}" (is "0 < setsum f ?A'")
  29.706 +and 2: "{a. h a = b \<and> 0 < f a} = {a. h a = b' \<and> 0 < f a}" (is "?A = ?A'")
  29.707 +shows "b = b'"
  29.708 +proof-
  29.709 +  have "finite ?A'" using f unfolding multiset_def by auto
  29.710 +  hence "?A' \<noteq> {}" using 1 setsum_gt_0_iff by auto
  29.711 +  thus ?thesis using 2 by auto
  29.712 +qed
  29.713 +
  29.714 +lemma mmap_comp:
  29.715 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
  29.716 +assumes f: "f \<in> multiset"
  29.717 +shows "mmap (h2 o h1) f = (mmap h2 o mmap h1) f"
  29.718 +unfolding mmap_def[abs_def] comp_def proof(rule ext)+
  29.719 +  fix c :: 'c
  29.720 +  let ?A = "{a. h2 (h1 a) = c \<and> 0 < f a}"
  29.721 +  let ?As = "\<lambda> b. {a. h1 a = b \<and> 0 < f a}"
  29.722 +  let ?B = "{b. h2 b = c \<and> 0 < setsum f (?As b)}"
  29.723 +  have 0: "{?As b | b.  b \<in> ?B} = ?As ` ?B" by auto
  29.724 +  have "\<And> b. finite (?As b)" using f unfolding multiset_def by simp
  29.725 +  hence "?B = {b. h2 b = c \<and> ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
  29.726 +  hence A: "?A = \<Union> {?As b | b.  b \<in> ?B}" by auto
  29.727 +  have "setsum f ?A = setsum (setsum f) {?As b | b.  b \<in> ?B}"
  29.728 +  unfolding A apply(rule setsum_Union_disjoint)
  29.729 +  using f unfolding multiset_def by auto
  29.730 +  also have "... = setsum (setsum f) (?As ` ?B)" unfolding 0 ..
  29.731 +  also have "... = setsum (setsum f o ?As) ?B" apply(rule setsum_reindex)
  29.732 +  unfolding inj_on_def apply auto using inj_on_setsum_inv[OF f, of h1] by blast
  29.733 +  also have "... = setsum (\<lambda> b. setsum f (?As b)) ?B" unfolding comp_def ..
  29.734 +  finally show "setsum f ?A = setsum (\<lambda> b. setsum f (?As b)) ?B" .
  29.735 +qed
  29.736 +
  29.737 +lemma mmap_comp1:
  29.738 +fixes h1 :: "'a \<Rightarrow> 'b" and h2 :: "'b \<Rightarrow> 'c"
  29.739 +assumes "f \<in> multiset"
  29.740 +shows "mmap (\<lambda> a. h2 (h1 a)) f = mmap h2 (mmap h1 f)"
  29.741 +using mmap_comp[OF assms] unfolding comp_def by auto
  29.742 +
  29.743 +lemma mmap:
  29.744 +assumes "f \<in> multiset"
  29.745 +shows "mmap h f \<in> multiset"
  29.746 +using assms unfolding mmap_def[abs_def] multiset_def proof safe
  29.747 +  assume fin: "finite {a. 0 < f a}"  (is "finite ?A")
  29.748 +  show "finite {b. 0 < setsum f {a. h a = b \<and> 0 < f a}}"
  29.749 +  (is "finite {b. 0 < setsum f (?As b)}")
  29.750 +  proof- let ?B = "{b. 0 < setsum f (?As b)}"
  29.751 +    have "\<And> b. finite (?As b)" using assms unfolding multiset_def by simp
  29.752 +    hence B: "?B = {b. ?As b \<noteq> {}}" using setsum_gt_0_iff by auto
  29.753 +    hence "?B \<subseteq> h ` ?A" by auto
  29.754 +    thus ?thesis using finite_surj[OF fin] by auto
  29.755 +  qed
  29.756 +qed
  29.757 +
  29.758 +lemma mmap_cong:
  29.759 +assumes "\<And>a. a \<in># M \<Longrightarrow> f a = g a"
  29.760 +shows "mmap f (count M) = mmap g (count M)"
  29.761 +using assms unfolding mmap_def[abs_def] by (intro ext, intro setsum_cong) auto
  29.762 +
  29.763 +abbreviation supp where "supp f \<equiv> {a. f a > 0}"
  29.764 +
  29.765 +lemma mmap_image_comp:
  29.766 +assumes f: "f \<in> multiset"
  29.767 +shows "(supp o mmap h) f = (image h o supp) f"
  29.768 +unfolding mmap_def[abs_def] comp_def proof-
  29.769 +  have "\<And> b. finite {a. h a = b \<and> 0 < f a}" (is "\<And> b. finite (?As b)")
  29.770 +  using f unfolding multiset_def by auto
  29.771 +  thus "{b. 0 < setsum f (?As b)} = h ` {a. 0 < f a}"
  29.772 +  using setsum_gt_0_iff by auto
  29.773 +qed
  29.774 +
  29.775 +lemma mmap_image:
  29.776 +assumes f: "f \<in> multiset"
  29.777 +shows "supp (mmap h f) = h ` (supp f)"
  29.778 +using mmap_image_comp[OF assms] unfolding comp_def .
  29.779 +
  29.780 +lemma set_of_Abs_multiset:
  29.781 +assumes f: "f \<in> multiset"
  29.782 +shows "set_of (Abs_multiset f) = supp f"
  29.783 +using assms unfolding set_of_def by (auto simp: Abs_multiset_inverse)
  29.784 +
  29.785 +lemma supp_count:
  29.786 +"supp (count M) = set_of M"
  29.787 +using assms unfolding set_of_def by auto
  29.788 +
  29.789 +lemma multiset_of_surj:
  29.790 +"multiset_of ` {as. set as \<subseteq> A} = {M. set_of M \<subseteq> A}"
  29.791 +proof safe
  29.792 +  fix M assume M: "set_of M \<subseteq> A"
  29.793 +  obtain as where eq: "M = multiset_of as" using surj_multiset_of unfolding surj_def by auto
  29.794 +  hence "set as \<subseteq> A" using M by auto
  29.795 +  thus "M \<in> multiset_of ` {as. set as \<subseteq> A}" using eq by auto
  29.796 +next
  29.797 +  show "\<And>x xa xb. \<lbrakk>set xa \<subseteq> A; xb \<in> set_of (multiset_of xa)\<rbrakk> \<Longrightarrow> xb \<in> A"
  29.798 +  by (erule set_mp) (unfold set_of_multiset_of)
  29.799 +qed
  29.800 +
  29.801 +lemma card_of_set_of:
  29.802 +"|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|"
  29.803 +apply(rule card_of_ordLeqI2[of _ multiset_of]) using multiset_of_surj by auto
  29.804 +
  29.805 +lemma nat_sum_induct:
  29.806 +assumes "\<And>n1 n2. (\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow> phi m1 m2) \<Longrightarrow> phi n1 n2"
  29.807 +shows "phi (n1::nat) (n2::nat)"
  29.808 +proof-
  29.809 +  let ?chi = "\<lambda> n1n2 :: nat * nat. phi (fst n1n2) (snd n1n2)"
  29.810 +  have "?chi (n1,n2)"
  29.811 +  apply(induct rule: measure_induct[of "\<lambda> n1n2. fst n1n2 + snd n1n2" ?chi])
  29.812 +  using assms by (metis fstI sndI)
  29.813 +  thus ?thesis by simp
  29.814 +qed
  29.815 +
  29.816 +lemma matrix_count:
  29.817 +fixes ct1 ct2 :: "nat \<Rightarrow> nat"
  29.818 +assumes "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
  29.819 +shows
  29.820 +"\<exists> ct. (\<forall> i1 \<le> n1. setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ct1 i1) \<and>
  29.821 +       (\<forall> i2 \<le> n2. setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ct2 i2)"
  29.822 +(is "?phi ct1 ct2 n1 n2")
  29.823 +proof-
  29.824 +  have "\<forall> ct1 ct2 :: nat \<Rightarrow> nat.
  29.825 +        setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"
  29.826 +  proof(induct rule: nat_sum_induct[of
  29.827 +"\<lambda> n1 n2. \<forall> ct1 ct2 :: nat \<Rightarrow> nat.
  29.828 +     setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2} \<longrightarrow> ?phi ct1 ct2 n1 n2"],
  29.829 +      clarify)
  29.830 +  fix n1 n2 :: nat and ct1 ct2 :: "nat \<Rightarrow> nat"
  29.831 +  assume IH: "\<And> m1 m2. m1 + m2 < n1 + n2 \<Longrightarrow>
  29.832 +                \<forall> dt1 dt2 :: nat \<Rightarrow> nat.
  29.833 +                setsum dt1 {..<Suc m1} = setsum dt2 {..<Suc m2} \<longrightarrow> ?phi dt1 dt2 m1 m2"
  29.834 +  and ss: "setsum ct1 {..<Suc n1} = setsum ct2 {..<Suc n2}"
  29.835 +  show "?phi ct1 ct2 n1 n2"
  29.836 +  proof(cases n1)
  29.837 +    case 0 note n1 = 0
  29.838 +    show ?thesis
  29.839 +    proof(cases n2)
  29.840 +      case 0 note n2 = 0
  29.841 +      let ?ct = "\<lambda> i1 i2. ct2 0"
  29.842 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by simp
  29.843 +    next
  29.844 +      case (Suc m2) note n2 = Suc
  29.845 +      let ?ct = "\<lambda> i1 i2. ct2 i2"
  29.846 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
  29.847 +    qed
  29.848 +  next
  29.849 +    case (Suc m1) note n1 = Suc
  29.850 +    show ?thesis
  29.851 +    proof(cases n2)
  29.852 +      case 0 note n2 = 0
  29.853 +      let ?ct = "\<lambda> i1 i2. ct1 i1"
  29.854 +      show ?thesis apply(rule exI[of _ ?ct]) using n1 n2 ss by auto
  29.855 +    next
  29.856 +      case (Suc m2) note n2 = Suc
  29.857 +      show ?thesis
  29.858 +      proof(cases "ct1 n1 \<le> ct2 n2")
  29.859 +        case True
  29.860 +        def dt2 \<equiv> "\<lambda> i2. if i2 = n2 then ct2 i2 - ct1 n1 else ct2 i2"
  29.861 +        have "setsum ct1 {..<Suc m1} = setsum dt2 {..<Suc n2}"
  29.862 +        unfolding dt2_def using ss n1 True by auto
  29.863 +        hence "?phi ct1 dt2 m1 n2" using IH[of m1 n2] n1 by simp
  29.864 +        then obtain dt where
  29.865 +        1: "\<And> i1. i1 \<le> m1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc n2} = ct1 i1" and
  29.866 +        2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc m1} = dt2 i2" by auto
  29.867 +        let ?ct = "\<lambda> i1 i2. if i1 = n1 then (if i2 = n2 then ct1 n1 else 0)
  29.868 +                                       else dt i1 i2"
  29.869 +        show ?thesis apply(rule exI[of _ ?ct])
  29.870 +        using n1 n2 1 2 True unfolding dt2_def by simp
  29.871 +      next
  29.872 +        case False
  29.873 +        hence False: "ct2 n2 < ct1 n1" by simp
  29.874 +        def dt1 \<equiv> "\<lambda> i1. if i1 = n1 then ct1 i1 - ct2 n2 else ct1 i1"
  29.875 +        have "setsum dt1 {..<Suc n1} = setsum ct2 {..<Suc m2}"
  29.876 +        unfolding dt1_def using ss n2 False by auto
  29.877 +        hence "?phi dt1 ct2 n1 m2" using IH[of n1 m2] n2 by simp
  29.878 +        then obtain dt where
  29.879 +        1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. dt i1 i2) {..<Suc m2} = dt1 i1" and
  29.880 +        2: "\<And> i2. i2 \<le> m2 \<Longrightarrow> setsum (\<lambda> i1. dt i1 i2) {..<Suc n1} = ct2 i2" by force
  29.881 +        let ?ct = "\<lambda> i1 i2. if i2 = n2 then (if i1 = n1 then ct2 n2 else 0)
  29.882 +                                       else dt i1 i2"
  29.883 +        show ?thesis apply(rule exI[of _ ?ct])
  29.884 +        using n1 n2 1 2 False unfolding dt1_def by simp
  29.885 +      qed
  29.886 +    qed
  29.887 +  qed
  29.888 +  qed
  29.889 +  thus ?thesis using assms by auto
  29.890 +qed
  29.891 +
  29.892 +definition
  29.893 +"inj2 u B1 B2 \<equiv>
  29.894 + \<forall> b1 b1' b2 b2'. {b1,b1'} \<subseteq> B1 \<and> {b2,b2'} \<subseteq> B2 \<and> u b1 b2 = u b1' b2'
  29.895 +                  \<longrightarrow> b1 = b1' \<and> b2 = b2'"
  29.896 +
  29.897 +lemma matrix_setsum_finite:
  29.898 +assumes B1: "B1 \<noteq> {}" "finite B1" and B2: "B2 \<noteq> {}" "finite B2" and u: "inj2 u B1 B2"
  29.899 +and ss: "setsum N1 B1 = setsum N2 B2"
  29.900 +shows "\<exists> M :: 'a \<Rightarrow> nat.
  29.901 +            (\<forall> b1 \<in> B1. setsum (\<lambda> b2. M (u b1 b2)) B2 = N1 b1) \<and>
  29.902 +            (\<forall> b2 \<in> B2. setsum (\<lambda> b1. M (u b1 b2)) B1 = N2 b2)"
  29.903 +proof-
  29.904 +  obtain n1 where "card B1 = Suc n1" using B1 by (metis card_insert finite.simps)
  29.905 +  then obtain e1 where e1: "bij_betw e1 {..<Suc n1} B1"
  29.906 +  using ex_bij_betw_finite_nat[OF B1(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
  29.907 +  hence e1_inj: "inj_on e1 {..<Suc n1}" and e1_surj: "e1 ` {..<Suc n1} = B1"
  29.908 +  unfolding bij_betw_def by auto
  29.909 +  def f1 \<equiv> "inv_into {..<Suc n1} e1"
  29.910 +  have f1: "bij_betw f1 B1 {..<Suc n1}"
  29.911 +  and f1e1[simp]: "\<And> i1. i1 < Suc n1 \<Longrightarrow> f1 (e1 i1) = i1"
  29.912 +  and e1f1[simp]: "\<And> b1. b1 \<in> B1 \<Longrightarrow> e1 (f1 b1) = b1" unfolding f1_def
  29.913 +  apply (metis bij_betw_inv_into e1, metis bij_betw_inv_into_left e1 lessThan_iff)
  29.914 +  by (metis e1_surj f_inv_into_f)
  29.915 +  (*  *)
  29.916 +  obtain n2 where "card B2 = Suc n2" using B2 by (metis card_insert finite.simps)
  29.917 +  then obtain e2 where e2: "bij_betw e2 {..<Suc n2} B2"
  29.918 +  using ex_bij_betw_finite_nat[OF B2(2)] by (metis atLeast0LessThan bij_betw_the_inv_into)
  29.919 +  hence e2_inj: "inj_on e2 {..<Suc n2}" and e2_surj: "e2 ` {..<Suc n2} = B2"
  29.920 +  unfolding bij_betw_def by auto
  29.921 +  def f2 \<equiv> "inv_into {..<Suc n2} e2"
  29.922 +  have f2: "bij_betw f2 B2 {..<Suc n2}"
  29.923 +  and f2e2[simp]: "\<And> i2. i2 < Suc n2 \<Longrightarrow> f2 (e2 i2) = i2"
  29.924 +  and e2f2[simp]: "\<And> b2. b2 \<in> B2 \<Longrightarrow> e2 (f2 b2) = b2" unfolding f2_def
  29.925 +  apply (metis bij_betw_inv_into e2, metis bij_betw_inv_into_left e2 lessThan_iff)
  29.926 +  by (metis e2_surj f_inv_into_f)
  29.927 +  (*  *)
  29.928 +  let ?ct1 = "N1 o e1"  let ?ct2 = "N2 o e2"
  29.929 +  have ss: "setsum ?ct1 {..<Suc n1} = setsum ?ct2 {..<Suc n2}"
  29.930 +  unfolding setsum_reindex[OF e1_inj, symmetric] setsum_reindex[OF e2_inj, symmetric]
  29.931 +  e1_surj e2_surj using ss .
  29.932 +  obtain ct where
  29.933 +  ct1: "\<And> i1. i1 \<le> n1 \<Longrightarrow> setsum (\<lambda> i2. ct i1 i2) {..<Suc n2} = ?ct1 i1" and
  29.934 +  ct2: "\<And> i2. i2 \<le> n2 \<Longrightarrow> setsum (\<lambda> i1. ct i1 i2) {..<Suc n1} = ?ct2 i2"
  29.935 +  using matrix_count[OF ss] by blast
  29.936 +  (*  *)
  29.937 +  def A \<equiv> "{u b1 b2 | b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"
  29.938 +  have "\<forall> a \<in> A. \<exists> b1b2 \<in> B1 <*> B2. u (fst b1b2) (snd b1b2) = a"
  29.939 +  unfolding A_def Ball_def mem_Collect_eq by auto
  29.940 +  then obtain h1h2 where h12:
  29.941 +  "\<And>a. a \<in> A \<Longrightarrow> u (fst (h1h2 a)) (snd (h1h2 a)) = a \<and> h1h2 a \<in> B1 <*> B2" by metis
  29.942 +  def h1 \<equiv> "fst o h1h2"  def h2 \<equiv> "snd o h1h2"
  29.943 +  have h12[simp]: "\<And>a. a \<in> A \<Longrightarrow> u (h1 a) (h2 a) = a"
  29.944 +                  "\<And> a. a \<in> A \<Longrightarrow> h1 a \<in> B1"  "\<And> a. a \<in> A \<Longrightarrow> h2 a \<in> B2"
  29.945 +  using h12 unfolding h1_def h2_def by force+
  29.946 +  {fix b1 b2 assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2"
  29.947 +   hence inA: "u b1 b2 \<in> A" unfolding A_def by auto
  29.948 +   hence "u b1 b2 = u (h1 (u b1 b2)) (h2 (u b1 b2))" by auto
  29.949 +   moreover have "h1 (u b1 b2) \<in> B1" "h2 (u b1 b2) \<in> B2" using inA by auto
  29.950 +   ultimately have "h1 (u b1 b2) = b1 \<and> h2 (u b1 b2) = b2"
  29.951 +   using u b1 b2 unfolding inj2_def by fastforce
  29.952 +  }
  29.953 +  hence h1[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h1 (u b1 b2) = b1" and
  29.954 +        h2[simp]: "\<And> b1 b2. \<lbrakk>b1 \<in> B1; b2 \<in> B2\<rbrakk> \<Longrightarrow> h2 (u b1 b2) = b2" by auto
  29.955 +  def M \<equiv> "\<lambda> a. ct (f1 (h1 a)) (f2 (h2 a))"
  29.956 +  show ?thesis
  29.957 +  apply(rule exI[of _ M]) proof safe
  29.958 +    fix b1 assume b1: "b1 \<in> B1"
  29.959 +    hence f1b1: "f1 b1 \<le> n1" using f1 unfolding bij_betw_def
  29.960 +    by (metis bij_betwE f1 lessThan_iff less_Suc_eq_le)
  29.961 +    have "(\<Sum>b2\<in>B2. M (u b1 b2)) = (\<Sum>i2<Suc n2. ct (f1 b1) (f2 (e2 i2)))"
  29.962 +    unfolding e2_surj[symmetric] setsum_reindex[OF e2_inj]
  29.963 +    unfolding M_def comp_def apply(intro setsum_cong) apply force
  29.964 +    by (metis e2_surj b1 h1 h2 imageI)
  29.965 +    also have "... = N1 b1" using b1 ct1[OF f1b1] by simp
  29.966 +    finally show "(\<Sum>b2\<in>B2. M (u b1 b2)) = N1 b1" .
  29.967 +  next
  29.968 +    fix b2 assume b2: "b2 \<in> B2"
  29.969 +    hence f2b2: "f2 b2 \<le> n2" using f2 unfolding bij_betw_def
  29.970 +    by (metis bij_betwE f2 lessThan_iff less_Suc_eq_le)
  29.971 +    have "(\<Sum>b1\<in>B1. M (u b1 b2)) = (\<Sum>i1<Suc n1. ct (f1 (e1 i1)) (f2 b2))"
  29.972 +    unfolding e1_surj[symmetric] setsum_reindex[OF e1_inj]
  29.973 +    unfolding M_def comp_def apply(intro setsum_cong) apply force
  29.974 +    by (metis e1_surj b2 h1 h2 imageI)
  29.975 +    also have "... = N2 b2" using b2 ct2[OF f2b2] by simp
  29.976 +    finally show "(\<Sum>b1\<in>B1. M (u b1 b2)) = N2 b2" .
  29.977 +  qed
  29.978 +qed
  29.979 +
  29.980 +lemma supp_vimage_mmap:
  29.981 +assumes "M \<in> multiset"
  29.982 +shows "supp M \<subseteq> f -` (supp (mmap f M))"
  29.983 +using assms by (auto simp: mmap_image)
  29.984 +
  29.985 +lemma mmap_ge_0:
  29.986 +assumes "M \<in> multiset"
  29.987 +shows "0 < mmap f M b \<longleftrightarrow> (\<exists>a. 0 < M a \<and> f a = b)"
  29.988 +proof-
  29.989 +  have f: "finite {a. f a = b \<and> 0 < M a}" using assms unfolding multiset_def by auto
  29.990 +  show ?thesis unfolding mmap_def setsum_gt_0_iff[OF f] by auto
  29.991 +qed
  29.992 +
  29.993 +lemma finite_twosets:
  29.994 +assumes "finite B1" and "finite B2"
  29.995 +shows "finite {u b1 b2 |b1 b2. b1 \<in> B1 \<and> b2 \<in> B2}"  (is "finite ?A")
  29.996 +proof-
  29.997 +  have A: "?A = (\<lambda> b1b2. u (fst b1b2) (snd b1b2)) ` (B1 <*> B2)" by force
  29.998 +  show ?thesis unfolding A using finite_cartesian_product[OF assms] by auto
  29.999 +qed
 29.1000 +
 29.1001 +lemma wp_mmap:
 29.1002 +fixes A :: "'a set" and B1 :: "'b1 set" and B2 :: "'b2 set"
 29.1003 +assumes wp: "wpull A B1 B2 f1 f2 p1 p2"
 29.1004 +shows
 29.1005 +"wpull {M. M \<in> multiset \<and> supp M \<subseteq> A}
 29.1006 +       {N1. N1 \<in> multiset \<and> supp N1 \<subseteq> B1} {N2. N2 \<in> multiset \<and> supp N2 \<subseteq> B2}
 29.1007 +       (mmap f1) (mmap f2) (mmap p1) (mmap p2)"
 29.1008 +unfolding wpull_def proof (safe, unfold Bex_def mem_Collect_eq)
 29.1009 +  fix N1 :: "'b1 \<Rightarrow> nat" and N2 :: "'b2 \<Rightarrow> nat"
 29.1010 +  assume mmap': "mmap f1 N1 = mmap f2 N2"
 29.1011 +  and N1[simp]: "N1 \<in> multiset" "supp N1 \<subseteq> B1"
 29.1012 +  and N2[simp]: "N2 \<in> multiset" "supp N2 \<subseteq> B2"
 29.1013 +  have mN1[simp]: "mmap f1 N1 \<in> multiset" using N1 by (auto simp: mmap)
 29.1014 +  have mN2[simp]: "mmap f2 N2 \<in> multiset" using N2 by (auto simp: mmap)
 29.1015 +  def P \<equiv> "mmap f1 N1"
 29.1016 +  have P1: "P = mmap f1 N1" and P2: "P = mmap f2 N2" unfolding P_def using mmap' by auto
 29.1017 +  note P = P1 P2
 29.1018 +  have P_mult[simp]: "P \<in> multiset" unfolding P_def using N1 by auto
 29.1019 +  have fin_N1[simp]: "finite (supp N1)" using N1(1) unfolding multiset_def by auto
 29.1020 +  have fin_N2[simp]: "finite (supp N2)" using N2(1) unfolding multiset_def by auto
 29.1021 +  have fin_P[simp]: "finite (supp P)" using P_mult unfolding multiset_def by auto
 29.1022 +  (*  *)
 29.1023 +  def set1 \<equiv> "\<lambda> c. {b1 \<in> supp N1. f1 b1 = c}"
 29.1024 +  have set1[simp]: "\<And> c b1. b1 \<in> set1 c \<Longrightarrow> f1 b1 = c" unfolding set1_def by auto
 29.1025 +  have fin_set1: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set1 c)"
 29.1026 +  using N1(1) unfolding set1_def multiset_def by auto
 29.1027 +  have set1_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<noteq> {}"
 29.1028 +  unfolding set1_def P1 mmap_ge_0[OF N1(1)] by auto
 29.1029 +  have supp_N1_set1: "supp N1 = (\<Union> c \<in> supp P. set1 c)"
 29.1030 +  using supp_vimage_mmap[OF N1(1), of f1] unfolding set1_def P1 by auto
 29.1031 +  hence set1_inclN1: "\<And>c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> supp N1" by auto
 29.1032 +  hence set1_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set1 c \<subseteq> B1" using N1(2) by blast
 29.1033 +  have set1_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set1 c \<inter> set1 c' = {}"
 29.1034 +  unfolding set1_def by auto
 29.1035 +  have setsum_set1: "\<And> c. setsum N1 (set1 c) = P c"
 29.1036 +  unfolding P1 set1_def mmap_def apply(rule setsum_cong) by auto
 29.1037 +  (*  *)
 29.1038 +  def set2 \<equiv> "\<lambda> c. {b2 \<in> supp N2. f2 b2 = c}"
 29.1039 +  have set2[simp]: "\<And> c b2. b2 \<in> set2 c \<Longrightarrow> f2 b2 = c" unfolding set2_def by auto
 29.1040 +  have fin_set2: "\<And> c. c \<in> supp P \<Longrightarrow> finite (set2 c)"
 29.1041 +  using N2(1) unfolding set2_def multiset_def by auto
 29.1042 +  have set2_NE: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<noteq> {}"
 29.1043 +  unfolding set2_def P2 mmap_ge_0[OF N2(1)] by auto
 29.1044 +  have supp_N2_set2: "supp N2 = (\<Union> c \<in> supp P. set2 c)"
 29.1045 +  using supp_vimage_mmap[OF N2(1), of f2] unfolding set2_def P2 by auto
 29.1046 +  hence set2_inclN2: "\<And>c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> supp N2" by auto
 29.1047 +  hence set2_incl: "\<And> c. c \<in> supp P \<Longrightarrow> set2 c \<subseteq> B2" using N2(2) by blast
 29.1048 +  have set2_disj: "\<And> c c'. c \<noteq> c' \<Longrightarrow> set2 c \<inter> set2 c' = {}"
 29.1049 +  unfolding set2_def by auto
 29.1050 +  have setsum_set2: "\<And> c. setsum N2 (set2 c) = P c"
 29.1051 +  unfolding P2 set2_def mmap_def apply(rule setsum_cong) by auto
 29.1052 +  (*  *)
 29.1053 +  have ss: "\<And> c. c \<in> supp P \<Longrightarrow> setsum N1 (set1 c) = setsum N2 (set2 c)"
 29.1054 +  unfolding setsum_set1 setsum_set2 ..
 29.1055 +  have "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
 29.1056 +          \<exists> a \<in> A. p1 a = fst b1b2 \<and> p2 a = snd b1b2"
 29.1057 +  using wp set1_incl set2_incl unfolding wpull_def Ball_def mem_Collect_eq
 29.1058 +  by simp (metis set1 set2 set_rev_mp)
 29.1059 +  then obtain uu where uu:
 29.1060 +  "\<forall> c \<in> supp P. \<forall> b1b2 \<in> (set1 c) \<times> (set2 c).
 29.1061 +     uu c b1b2 \<in> A \<and> p1 (uu c b1b2) = fst b1b2 \<and> p2 (uu c b1b2) = snd b1b2" by metis
 29.1062 +  def u \<equiv> "\<lambda> c b1 b2. uu c (b1,b2)"
 29.1063 +  have u[simp]:
 29.1064 +  "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> A"
 29.1065 +  "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p1 (u c b1 b2) = b1"
 29.1066 +  "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> p2 (u c b1 b2) = b2"
 29.1067 +  using uu unfolding u_def by auto
 29.1068 +  {fix c assume c: "c \<in> supp P"
 29.1069 +   have "inj2 (u c) (set1 c) (set2 c)" unfolding inj2_def proof clarify
 29.1070 +     fix b1 b1' b2 b2'
 29.1071 +     assume "{b1, b1'} \<subseteq> set1 c" "{b2, b2'} \<subseteq> set2 c" and 0: "u c b1 b2 = u c b1' b2'"
 29.1072 +     hence "p1 (u c b1 b2) = b1 \<and> p2 (u c b1 b2) = b2 \<and>
 29.1073 +            p1 (u c b1' b2') = b1' \<and> p2 (u c b1' b2') = b2'"
 29.1074 +     using u(2)[OF c] u(3)[OF c] by simp metis
 29.1075 +     thus "b1 = b1' \<and> b2 = b2'" using 0 by auto
 29.1076 +   qed
 29.1077 +  } note inj = this
 29.1078 +  def sset \<equiv> "\<lambda> c. {u c b1 b2 | b1 b2. b1 \<in> set1 c \<and> b2 \<in> set2 c}"
 29.1079 +  have fin_sset[simp]: "\<And> c. c \<in> supp P \<Longrightarrow> finite (sset c)" unfolding sset_def
 29.1080 +  using fin_set1 fin_set2 finite_twosets by blast
 29.1081 +  have sset_A: "\<And> c. c \<in> supp P \<Longrightarrow> sset c \<subseteq> A" unfolding sset_def by auto
 29.1082 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
 29.1083 +   then obtain b1 b2 where b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
 29.1084 +   and a: "a = u c b1 b2" unfolding sset_def by auto
 29.1085 +   have "p1 a \<in> set1 c" and p2a: "p2 a \<in> set2 c"
 29.1086 +   using ac a b1 b2 c u(2) u(3) by simp+
 29.1087 +   hence "u c (p1 a) (p2 a) = a" unfolding a using b1 b2 inj[OF c]
 29.1088 +   unfolding inj2_def by (metis c u(2) u(3))
 29.1089 +  } note u_p12[simp] = this
 29.1090 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
 29.1091 +   hence "p1 a \<in> set1 c" unfolding sset_def by auto
 29.1092 +  }note p1[simp] = this
 29.1093 +  {fix c a assume c: "c \<in> supp P" and ac: "a \<in> sset c"
 29.1094 +   hence "p2 a \<in> set2 c" unfolding sset_def by auto
 29.1095 +  }note p2[simp] = this
 29.1096 +  (*  *)
 29.1097 +  {fix c assume c: "c \<in> supp P"
 29.1098 +   hence "\<exists> M. (\<forall> b1 \<in> set1 c. setsum (\<lambda> b2. M (u c b1 b2)) (set2 c) = N1 b1) \<and>
 29.1099 +               (\<forall> b2 \<in> set2 c. setsum (\<lambda> b1. M (u c b1 b2)) (set1 c) = N2 b2)"
 29.1100 +   unfolding sset_def
 29.1101 +   using matrix_setsum_finite[OF set1_NE[OF c] fin_set1[OF c]
 29.1102 +                                 set2_NE[OF c] fin_set2[OF c] inj[OF c] ss[OF c]] by auto
 29.1103 +  }
 29.1104 +  then obtain Ms where
 29.1105 +  ss1: "\<And> c b1. \<lbrakk>c \<in> supp P; b1 \<in> set1 c\<rbrakk> \<Longrightarrow>
 29.1106 +                   setsum (\<lambda> b2. Ms c (u c b1 b2)) (set2 c) = N1 b1" and
 29.1107 +  ss2: "\<And> c b2. \<lbrakk>c \<in> supp P; b2 \<in> set2 c\<rbrakk> \<Longrightarrow>
 29.1108 +                   setsum (\<lambda> b1. Ms c (u c b1 b2)) (set1 c) = N2 b2"
 29.1109 +  by metis
 29.1110 +  def SET \<equiv> "\<Union> c \<in> supp P. sset c"
 29.1111 +  have fin_SET[simp]: "finite SET" unfolding SET_def apply(rule finite_UN_I) by auto
 29.1112 +  have SET_A: "SET \<subseteq> A" unfolding SET_def using sset_A by auto
 29.1113 +  have u_SET[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk> \<Longrightarrow> u c b1 b2 \<in> SET"
 29.1114 +  unfolding SET_def sset_def by blast
 29.1115 +  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p1a: "p1 a \<in> set1 c"
 29.1116 +   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
 29.1117 +   unfolding SET_def by auto
 29.1118 +   hence "p1 a \<in> set1 c'" unfolding sset_def by auto
 29.1119 +   hence eq: "c = c'" using p1a c c' set1_disj by auto
 29.1120 +   hence "a \<in> sset c" using ac' by simp
 29.1121 +  } note p1_rev = this
 29.1122 +  {fix c a assume c: "c \<in> supp P" and a: "a \<in> SET" and p2a: "p2 a \<in> set2 c"
 29.1123 +   then obtain c' where c': "c' \<in> supp P" and ac': "a \<in> sset c'"
 29.1124 +   unfolding SET_def by auto
 29.1125 +   hence "p2 a \<in> set2 c'" unfolding sset_def by auto
 29.1126 +   hence eq: "c = c'" using p2a c c' set2_disj by auto
 29.1127 +   hence "a \<in> sset c" using ac' by simp
 29.1128 +  } note p2_rev = this
 29.1129 +  (*  *)
 29.1130 +  have "\<forall> a \<in> SET. \<exists> c \<in> supp P. a \<in> sset c" unfolding SET_def by auto
 29.1131 +  then obtain h where h: "\<forall> a \<in> SET. h a \<in> supp P \<and> a \<in> sset (h a)" by metis
 29.1132 +  have h_u[simp]: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
 29.1133 +                      \<Longrightarrow> h (u c b1 b2) = c"
 29.1134 +  by (metis h p2 set2 u(3) u_SET)
 29.1135 +  have h_u1: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
 29.1136 +                      \<Longrightarrow> h (u c b1 b2) = f1 b1"
 29.1137 +  using h unfolding sset_def by auto
 29.1138 +  have h_u2: "\<And> c b1 b2. \<lbrakk>c \<in> supp P; b1 \<in> set1 c; b2 \<in> set2 c\<rbrakk>
 29.1139 +                      \<Longrightarrow> h (u c b1 b2) = f2 b2"
 29.1140 +  using h unfolding sset_def by auto
 29.1141 +  def M \<equiv> "\<lambda> a. if a \<in> SET \<and> p1 a \<in> supp N1 \<and> p2 a \<in> supp N2 then Ms (h a) a else 0"
 29.1142 +  have sM: "supp M \<subseteq> SET" "supp M \<subseteq> p1 -` (supp N1)" "supp M \<subseteq> p2 -` (supp N2)"
 29.1143 +  unfolding M_def by auto
 29.1144 +  show "\<exists>M. (M \<in> multiset \<and> supp M \<subseteq> A) \<and> mmap p1 M = N1 \<and> mmap p2 M = N2"
 29.1145 +  proof(rule exI[of _ M], safe)
 29.1146 +    show "M \<in> multiset"
 29.1147 +    unfolding multiset_def using finite_subset[OF sM(1) fin_SET] by simp
 29.1148 +  next
 29.1149 +    fix a assume "0 < M a"
 29.1150 +    thus "a \<in> A" unfolding M_def using SET_A by (cases "a \<in> SET") auto
 29.1151 +  next
 29.1152 +    show "mmap p1 M = N1"
 29.1153 +    unfolding mmap_def[abs_def] proof(rule ext)
 29.1154 +      fix b1
 29.1155 +      let ?K = "{a. p1 a = b1 \<and> 0 < M a}"
 29.1156 +      show "setsum M ?K = N1 b1"
 29.1157 +      proof(cases "b1 \<in> supp N1")
 29.1158 +        case False
 29.1159 +        hence "?K = {}" using sM(2) by auto
 29.1160 +        thus ?thesis using False by auto
 29.1161 +      next
 29.1162 +        case True
 29.1163 +        def c \<equiv> "f1 b1"
 29.1164 +        have c: "c \<in> supp P" and b1: "b1 \<in> set1 c"
 29.1165 +        unfolding set1_def c_def P1 using True by (auto simp: mmap_image)
 29.1166 +        have "setsum M ?K = setsum M {a. p1 a = b1 \<and> a \<in> SET}"
 29.1167 +        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
 29.1168 +        also have "... = setsum M ((\<lambda> b2. u c b1 b2) ` (set2 c))"
 29.1169 +        apply(rule setsum_cong) using c b1 proof safe
 29.1170 +          fix a assume p1a: "p1 a \<in> set1 c" and "0 < P c" and "a \<in> SET"
 29.1171 +          hence ac: "a \<in> sset c" using p1_rev by auto
 29.1172 +          hence "a = u c (p1 a) (p2 a)" using c by auto
 29.1173 +          moreover have "p2 a \<in> set2 c" using ac c by auto
 29.1174 +          ultimately show "a \<in> u c (p1 a) ` set2 c" by auto
 29.1175 +        next
 29.1176 +          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
 29.1177 +          hence "u c b1 b2 \<in> SET" using c by auto
 29.1178 +        qed auto
 29.1179 +        also have "... = setsum (\<lambda> b2. M (u c b1 b2)) (set2 c)"
 29.1180 +        unfolding comp_def[symmetric] apply(rule setsum_reindex)
 29.1181 +        using inj unfolding inj_on_def inj2_def using b1 c u(3) by blast
 29.1182 +        also have "... = N1 b1" unfolding ss1[OF c b1, symmetric]
 29.1183 +          apply(rule setsum_cong[OF refl]) unfolding M_def
 29.1184 +          using True h_u[OF c b1] set2_def u(2,3)[OF c b1] u_SET[OF c b1] by fastforce
 29.1185 +        finally show ?thesis .
 29.1186 +      qed
 29.1187 +    qed
 29.1188 +  next
 29.1189 +    show "mmap p2 M = N2"
 29.1190 +    unfolding mmap_def[abs_def] proof(rule ext)
 29.1191 +      fix b2
 29.1192 +      let ?K = "{a. p2 a = b2 \<and> 0 < M a}"
 29.1193 +      show "setsum M ?K = N2 b2"
 29.1194 +      proof(cases "b2 \<in> supp N2")
 29.1195 +        case False
 29.1196 +        hence "?K = {}" using sM(3) by auto
 29.1197 +        thus ?thesis using False by auto
 29.1198 +      next
 29.1199 +        case True
 29.1200 +        def c \<equiv> "f2 b2"
 29.1201 +        have c: "c \<in> supp P" and b2: "b2 \<in> set2 c"
 29.1202 +        unfolding set2_def c_def P2 using True by (auto simp: mmap_image)
 29.1203 +        have "setsum M ?K = setsum M {a. p2 a = b2 \<and> a \<in> SET}"
 29.1204 +        apply(rule setsum_mono_zero_cong_left) unfolding M_def by auto
 29.1205 +        also have "... = setsum M ((\<lambda> b1. u c b1 b2) ` (set1 c))"
 29.1206 +        apply(rule setsum_cong) using c b2 proof safe
 29.1207 +          fix a assume p2a: "p2 a \<in> set2 c" and "0 < P c" and "a \<in> SET"
 29.1208 +          hence ac: "a \<in> sset c" using p2_rev by auto
 29.1209 +          hence "a = u c (p1 a) (p2 a)" using c by auto
 29.1210 +          moreover have "p1 a \<in> set1 c" using ac c by auto
 29.1211 +          ultimately show "a \<in> (\<lambda>b1. u c b1 (p2 a)) ` set1 c" by auto
 29.1212 +        next
 29.1213 +          fix b2 assume b1: "b1 \<in> set1 c" and b2: "b2 \<in> set2 c"
 29.1214 +          hence "u c b1 b2 \<in> SET" using c by auto
 29.1215 +        qed auto
 29.1216 +        also have "... = setsum (M o (\<lambda> b1. u c b1 b2)) (set1 c)"
 29.1217 +        apply(rule setsum_reindex)
 29.1218 +        using inj unfolding inj_on_def inj2_def using b2 c u(2) by blast
 29.1219 +        also have "... = setsum (\<lambda> b1. M (u c b1 b2)) (set1 c)"
 29.1220 +        unfolding comp_def[symmetric] by simp
 29.1221 +        also have "... = N2 b2" unfolding ss2[OF c b2, symmetric]
 29.1222 +          apply(rule setsum_cong[OF refl]) unfolding M_def set2_def
 29.1223 +          using True h_u1[OF c _ b2] u(2,3)[OF c _ b2] u_SET[OF c _ b2]
 29.1224 +          unfolding set1_def by fastforce
 29.1225 +        finally show ?thesis .
 29.1226 +      qed
 29.1227 +    qed
 29.1228 +  qed
 29.1229 +qed
 29.1230 +
 29.1231 +definition multiset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
 29.1232 +"multiset_map h = Abs_multiset \<circ> mmap h \<circ> count"
 29.1233 +
 29.1234 +bnf_def multiset_map [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
 29.1235 +unfolding multiset_map_def
 29.1236 +proof -
 29.1237 +  show "Abs_multiset \<circ> mmap id \<circ> count = id" unfolding mmap_id by (auto simp: count_inverse)
 29.1238 +next
 29.1239 +  fix f g
 29.1240 +  show "Abs_multiset \<circ> mmap (g \<circ> f) \<circ> count =
 29.1241 +        Abs_multiset \<circ> mmap g \<circ> count \<circ> (Abs_multiset \<circ> mmap f \<circ> count)"
 29.1242 +  unfolding comp_def apply(rule ext)
 29.1243 +  by (auto simp: Abs_multiset_inverse count mmap_comp1 mmap)
 29.1244 +next
 29.1245 +  fix M f g assume eq: "\<And>a. a \<in> set_of M \<Longrightarrow> f a = g a"
 29.1246 +  thus "(Abs_multiset \<circ> mmap f \<circ> count) M = (Abs_multiset \<circ> mmap g \<circ> count) M" apply auto
 29.1247 +  unfolding cIm_def[abs_def] image_def
 29.1248 +  by (auto intro!: mmap_cong simp: Abs_multiset_inject count mmap)
 29.1249 +next
 29.1250 +  fix f show "set_of \<circ> (Abs_multiset \<circ> mmap f \<circ> count) = op ` f \<circ> set_of"
 29.1251 +  by (auto simp: count mmap mmap_image set_of_Abs_multiset supp_count)
 29.1252 +next
 29.1253 +  show "card_order natLeq" by (rule natLeq_card_order)
 29.1254 +next
 29.1255 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
 29.1256 +next
 29.1257 +  fix M show "|set_of M| \<le>o natLeq"
 29.1258 +  apply(rule ordLess_imp_ordLeq)
 29.1259 +  unfolding finite_iff_ordLess_natLeq[symmetric] using finite_set_of .
 29.1260 +next
 29.1261 +  fix A :: "'a set"
 29.1262 +  have "|{M. set_of M \<subseteq> A}| \<le>o |{as. set as \<subseteq> A}|" using card_of_set_of .
 29.1263 +  also have "|{as. set as \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq"
 29.1264 +  by (rule list_in_bd)
 29.1265 +  finally show "|{M. set_of M \<subseteq> A}| \<le>o ( |A| +c ctwo) ^c natLeq" .
 29.1266 +next
 29.1267 +  fix A B1 B2 f1 f2 p1 p2
 29.1268 +  let ?map = "\<lambda> f. Abs_multiset \<circ> mmap f \<circ> count"
 29.1269 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
 29.1270 +  show "wpull {x. set_of x \<subseteq> A} {x. set_of x \<subseteq> B1} {x. set_of x \<subseteq> B2}
 29.1271 +              (?map f1) (?map f2) (?map p1) (?map p2)"
 29.1272 +  unfolding wpull_def proof safe
 29.1273 +    fix y1 y2
 29.1274 +    assume y1: "set_of y1 \<subseteq> B1" and y2: "set_of y2 \<subseteq> B2"
 29.1275 +    and m: "?map f1 y1 = ?map f2 y2"
 29.1276 +    def N1 \<equiv> "count y1"  def N2 \<equiv> "count y2"
 29.1277 +    have "N1 \<in> multiset \<and> supp N1 \<subseteq> B1" and "N2 \<in> multiset \<and> supp N2 \<subseteq> B2"
 29.1278 +    and "mmap f1 N1 = mmap f2 N2"
 29.1279 +    using y1 y2 m unfolding N1_def N2_def
 29.1280 +    by (auto simp: Abs_multiset_inject count mmap)
 29.1281 +    then obtain M where M: "M \<in> multiset \<and> supp M \<subseteq> A"
 29.1282 +    and N1: "mmap p1 M = N1" and N2: "mmap p2 M = N2"
 29.1283 +    using wp_mmap[OF wp] unfolding wpull_def by auto
 29.1284 +    def x \<equiv> "Abs_multiset M"
 29.1285 +    show "\<exists>x\<in>{x. set_of x \<subseteq> A}. ?map p1 x = y1 \<and> ?map p2 x = y2"
 29.1286 +    apply(intro bexI[of _ x]) using M N1 N2 unfolding N1_def N2_def x_def
 29.1287 +    by (auto simp: count_inverse Abs_multiset_inverse)
 29.1288 +  qed
 29.1289 +qed (unfold set_of_empty, auto)
 29.1290 +
 29.1291 +inductive multiset_rel' where 
 29.1292 +Zero: "multiset_rel' R {#} {#}" 
 29.1293 +|
 29.1294 +Plus: "\<lbrakk>R a b; multiset_rel' R M N\<rbrakk> \<Longrightarrow> multiset_rel' R (M + {#a#}) (N + {#b#})"
 29.1295 +
 29.1296 +lemma multiset_map_Zero_iff[simp]: "multiset_map f M = {#} \<longleftrightarrow> M = {#}"
 29.1297 +by (metis image_is_empty multiset.set_natural' set_of_eq_empty_iff)
 29.1298 +
 29.1299 +lemma multiset_map_Zero[simp]: "multiset_map f {#} = {#}" by simp
 29.1300 +
 29.1301 +lemma multiset_rel_Zero: "multiset_rel R {#} {#}"
 29.1302 +unfolding multiset_rel_def Gr_def relcomp_unfold by auto
 29.1303 +
 29.1304 +declare multiset.count[simp]
 29.1305 +declare mmap[simp]
 29.1306 +declare Abs_multiset_inverse[simp]
 29.1307 +declare multiset.count_inverse[simp]
 29.1308 +declare union_preserves_multiset[simp]
 29.1309 +
 29.1310 +lemma mmap_Plus[simp]:
 29.1311 +assumes "K \<in> multiset" and "L \<in> multiset"
 29.1312 +shows "mmap f (\<lambda>a. K a + L a) a = mmap f K a + mmap f L a"
 29.1313 +proof-
 29.1314 +  have "{aa. f aa = a \<and> (0 < K aa \<or> 0 < L aa)} \<subseteq>
 29.1315 +        {aa. 0 < K aa} \<union> {aa. 0 < L aa}" (is "?C \<subseteq> ?A \<union> ?B") by auto
 29.1316 +  moreover have "finite (?A \<union> ?B)" apply(rule finite_UnI)
 29.1317 +  using assms unfolding multiset_def by auto
 29.1318 +  ultimately have C: "finite ?C" using finite_subset by blast
 29.1319 +  have "setsum K {aa. f aa = a \<and> 0 < K aa} = setsum K {aa. f aa = a \<and> 0 < K aa + L aa}"
 29.1320 +  apply(rule setsum_mono_zero_cong_left) using C by auto
 29.1321 +  moreover
 29.1322 +  have "setsum L {aa. f aa = a \<and> 0 < L aa} = setsum L {aa. f aa = a \<and> 0 < K aa + L aa}"
 29.1323 +  apply(rule setsum_mono_zero_cong_left) using C by auto
 29.1324 +  ultimately show ?thesis
 29.1325 +  unfolding mmap_def unfolding comm_monoid_add_class.setsum.F_fun_f by auto
 29.1326 +qed
 29.1327 +
 29.1328 +lemma multiset_map_Plus[simp]:
 29.1329 +"multiset_map f (M1 + M2) = multiset_map f M1 + multiset_map f M2"
 29.1330 +unfolding multiset_map_def
 29.1331 +apply(subst multiset.count_inject[symmetric])
 29.1332 +unfolding plus_multiset.rep_eq comp_def by auto
 29.1333 +
 29.1334 +lemma multiset_map_singl[simp]: "multiset_map f {#a#} = {#f a#}"
 29.1335 +proof-
 29.1336 +  have 0: "\<And> b. card {aa. a = aa \<and> (a = aa \<longrightarrow> f aa = b)} =
 29.1337 +                (if b = f a then 1 else 0)" by auto
 29.1338 +  thus ?thesis
 29.1339 +  unfolding multiset_map_def comp_def mmap_def[abs_def] map_fun_def
 29.1340 +  by (simp, simp add: single_def)
 29.1341 +qed
 29.1342 +
 29.1343 +lemma multiset_rel_Plus:
 29.1344 +assumes ab: "R a b" and MN: "multiset_rel R M N"
 29.1345 +shows "multiset_rel R (M + {#a#}) (N + {#b#})"
 29.1346 +proof-
 29.1347 +  {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
 29.1348 +   hence "\<exists>ya. multiset_map fst y + {#a#} = multiset_map fst ya \<and>
 29.1349 +               multiset_map snd y + {#b#} = multiset_map snd ya \<and>
 29.1350 +               set_of ya \<subseteq> {(x, y). R x y}"
 29.1351 +   apply(intro exI[of _ "y + {#(a,b)#}"]) by auto
 29.1352 +  }
 29.1353 +  thus ?thesis
 29.1354 +  using assms
 29.1355 +  unfolding multiset_rel_def Gr_def relcomp_unfold by force
 29.1356 +qed
 29.1357 +
 29.1358 +lemma multiset_rel'_imp_multiset_rel:
 29.1359 +"multiset_rel' R M N \<Longrightarrow> multiset_rel R M N"
 29.1360 +apply(induct rule: multiset_rel'.induct)
 29.1361 +using multiset_rel_Zero multiset_rel_Plus by auto
 29.1362 +
 29.1363 +lemma mcard_multiset_map[simp]: "mcard (multiset_map f M) = mcard M"
 29.1364 +proof-
 29.1365 +  def A \<equiv> "\<lambda> b. {a. f a = b \<and> a \<in># M}"
 29.1366 +  let ?B = "{b. 0 < setsum (count M) (A b)}"
 29.1367 +  have "{b. \<exists>a. f a = b \<and> a \<in># M} \<subseteq> f ` {a. a \<in># M}" by auto
 29.1368 +  moreover have "finite (f ` {a. a \<in># M})" apply(rule finite_imageI)
 29.1369 +  using finite_Collect_mem .
 29.1370 +  ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
 29.1371 +  have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
 29.1372 +  by (metis (lifting, mono_tags) mem_Collect_eq rel_simps(54)
 29.1373 +                                 setsum_gt_0_iff setsum_infinite)
 29.1374 +  have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
 29.1375 +  apply safe
 29.1376 +    apply (metis less_not_refl setsum_gt_0_iff setsum_infinite)
 29.1377 +    by (metis A_def finite_Collect_conjI finite_Collect_mem setsum_gt_0_iff)
 29.1378 +  hence AB: "A ` ?B = {A b | b. \<exists> a \<in> A b. count M a > 0}" by auto
 29.1379 +
 29.1380 +  have "setsum (\<lambda> x. setsum (count M) (A x)) ?B = setsum (setsum (count M) o A) ?B"
 29.1381 +  unfolding comp_def ..
 29.1382 +  also have "... = (\<Sum>x\<in> A ` ?B. setsum (count M) x)"
 29.1383 +  unfolding comm_monoid_add_class.setsum_reindex[OF i, symmetric] ..
 29.1384 +  also have "... = setsum (count M) (\<Union>x\<in>A ` {b. 0 < setsum (count M) (A b)}. x)"
 29.1385 +  (is "_ = setsum (count M) ?J")
 29.1386 +  apply(rule comm_monoid_add_class.setsum_UN_disjoint[symmetric])
 29.1387 +  using 0 fin unfolding A_def by (auto intro!: finite_imageI)
 29.1388 +  also have "?J = {a. a \<in># M}" unfolding AB unfolding A_def by auto
 29.1389 +  finally have "setsum (\<lambda> x. setsum (count M) (A x)) ?B =
 29.1390 +                setsum (count M) {a. a \<in># M}" .
 29.1391 +  thus ?thesis unfolding A_def mcard_def multiset_map_def by (simp add: mmap_def)
 29.1392 +qed
 29.1393 +
 29.1394 +lemma multiset_rel_mcard: 
 29.1395 +assumes "multiset_rel R M N" 
 29.1396 +shows "mcard M = mcard N"
 29.1397 +using assms unfolding multiset_rel_def relcomp_unfold Gr_def by auto
 29.1398 +
 29.1399 +lemma multiset_induct2[case_names empty addL addR]:
 29.1400 +assumes empty: "P {#} {#}" 
 29.1401 +and addL: "\<And>M N a. P M N \<Longrightarrow> P (M + {#a#}) N"
 29.1402 +and addR: "\<And>M N a. P M N \<Longrightarrow> P M (N + {#a#})"
 29.1403 +shows "P M N"
 29.1404 +apply(induct N rule: multiset_induct)
 29.1405 +  apply(induct M rule: multiset_induct, rule empty, erule addL)
 29.1406 +  apply(induct M rule: multiset_induct, erule addR, erule addR)
 29.1407 +done
 29.1408 +
 29.1409 +lemma multiset_induct2_mcard[consumes 1, case_names empty add]:
 29.1410 +assumes c: "mcard M = mcard N"
 29.1411 +and empty: "P {#} {#}"
 29.1412 +and add: "\<And>M N a b. P M N \<Longrightarrow> P (M + {#a#}) (N + {#b#})"
 29.1413 +shows "P M N"
 29.1414 +using c proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
 29.1415 +  case (less M)  show ?case
 29.1416 +  proof(cases "M = {#}")
 29.1417 +    case True hence "N = {#}" using less.prems by auto
 29.1418 +    thus ?thesis using True empty by auto
 29.1419 +  next
 29.1420 +    case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
 29.1421 +    have "N \<noteq> {#}" using False less.prems by auto
 29.1422 +    then obtain N1 b where N: "N = N1 + {#b#}" by (metis multi_nonempty_split)
 29.1423 +    have "mcard M1 = mcard N1" using less.prems unfolding M N by auto
 29.1424 +    thus ?thesis using M N less.hyps add by auto
 29.1425 +  qed
 29.1426 +qed
 29.1427 +
 29.1428 +lemma msed_map_invL:
 29.1429 +assumes "multiset_map f (M + {#a#}) = N"
 29.1430 +shows "\<exists> N1. N = N1 + {#f a#} \<and> multiset_map f M = N1"
 29.1431 +proof-
 29.1432 +  have "f a \<in># N"
 29.1433 +  using assms multiset.set_natural'[of f "M + {#a#}"] by auto
 29.1434 +  then obtain N1 where N: "N = N1 + {#f a#}" using multi_member_split by metis
 29.1435 +  have "multiset_map f M = N1" using assms unfolding N by simp
 29.1436 +  thus ?thesis using N by blast
 29.1437 +qed
 29.1438 +
 29.1439 +lemma msed_map_invR:
 29.1440 +assumes "multiset_map f M = N + {#b#}"
 29.1441 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> f a = b \<and> multiset_map f M1 = N"
 29.1442 +proof-
 29.1443 +  obtain a where a: "a \<in># M" and fa: "f a = b"
 29.1444 +  using multiset.set_natural'[of f M] unfolding assms
 29.1445 +  by (metis image_iff mem_set_of_iff union_single_eq_member)
 29.1446 +  then obtain M1 where M: "M = M1 + {#a#}" using multi_member_split by metis
 29.1447 +  have "multiset_map f M1 = N" using assms unfolding M fa[symmetric] by simp
 29.1448 +  thus ?thesis using M fa by blast
 29.1449 +qed
 29.1450 +
 29.1451 +lemma msed_rel_invL:
 29.1452 +assumes "multiset_rel R (M + {#a#}) N"
 29.1453 +shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> multiset_rel R M N1"
 29.1454 +proof-
 29.1455 +  obtain K where KM: "multiset_map fst K = M + {#a#}"
 29.1456 +  and KN: "multiset_map snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
 29.1457 +  using assms
 29.1458 +  unfolding multiset_rel_def Gr_def relcomp_unfold by auto
 29.1459 +  obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
 29.1460 +  and K1M: "multiset_map fst K1 = M" using msed_map_invR[OF KM] by auto
 29.1461 +  obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "multiset_map snd K1 = N1"
 29.1462 +  using msed_map_invL[OF KN[unfolded K]] by auto
 29.1463 +  have Rab: "R a (snd ab)" using sK a unfolding K by auto
 29.1464 +  have "multiset_rel R M N1" using sK K1M K1N1 
 29.1465 +  unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
 29.1466 +  thus ?thesis using N Rab by auto
 29.1467 +qed
 29.1468 +
 29.1469 +lemma msed_rel_invR:
 29.1470 +assumes "multiset_rel R M (N + {#b#})"
 29.1471 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> multiset_rel R M1 N"
 29.1472 +proof-
 29.1473 +  obtain K where KN: "multiset_map snd K = N + {#b#}"
 29.1474 +  and KM: "multiset_map fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
 29.1475 +  using assms
 29.1476 +  unfolding multiset_rel_def Gr_def relcomp_unfold by auto
 29.1477 +  obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
 29.1478 +  and K1N: "multiset_map snd K1 = N" using msed_map_invR[OF KN] by auto
 29.1479 +  obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "multiset_map fst K1 = M1"
 29.1480 +  using msed_map_invL[OF KM[unfolded K]] by auto
 29.1481 +  have Rab: "R (fst ab) b" using sK b unfolding K by auto
 29.1482 +  have "multiset_rel R M1 N" using sK K1N K1M1
 29.1483 +  unfolding K multiset_rel_def Gr_def relcomp_unfold by auto
 29.1484 +  thus ?thesis using M Rab by auto
 29.1485 +qed
 29.1486 +
 29.1487 +lemma multiset_rel_imp_multiset_rel':
 29.1488 +assumes "multiset_rel R M N"
 29.1489 +shows "multiset_rel' R M N"
 29.1490 +using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
 29.1491 +  case (less M)
 29.1492 +  have c: "mcard M = mcard N" using multiset_rel_mcard[OF less.prems] .
 29.1493 +  show ?case
 29.1494 +  proof(cases "M = {#}")
 29.1495 +    case True hence "N = {#}" using c by simp
 29.1496 +    thus ?thesis using True multiset_rel'.Zero by auto
 29.1497 +  next
 29.1498 +    case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
 29.1499 +    obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "multiset_rel R M1 N1"
 29.1500 +    using msed_rel_invL[OF less.prems[unfolded M]] by auto
 29.1501 +    have "multiset_rel' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
 29.1502 +    thus ?thesis using multiset_rel'.Plus[of R a b, OF R] unfolding M N by simp
 29.1503 +  qed
 29.1504 +qed
 29.1505 +
 29.1506 +lemma multiset_rel_multiset_rel':
 29.1507 +"multiset_rel R M N = multiset_rel' R M N"
 29.1508 +using  multiset_rel_imp_multiset_rel' multiset_rel'_imp_multiset_rel by auto
 29.1509 +
 29.1510 +(* The main end product for multiset_rel: inductive characterization *)
 29.1511 +theorems multiset_rel_induct[case_names empty add, induct pred: multiset_rel] =
 29.1512 +         multiset_rel'.induct[unfolded multiset_rel_multiset_rel'[symmetric]]
 29.1513 +
 29.1514 +end
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/BNF/README.html	Fri Sep 21 16:45:06 2012 +0200
    30.3 @@ -0,0 +1,54 @@
    30.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
    30.5 +
    30.6 +<html>
    30.7 +
    30.8 +<head>
    30.9 +  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
   30.10 +  <title>BNF Package</title>
   30.11 +</head>
   30.12 +
   30.13 +<body>
   30.14 +
   30.15 +<h3><i>BNF</i>: A (co)datatype package based on bounded natural functors
   30.16 +(BNFs)</h3>
   30.17 +
   30.18 +<p>
   30.19 +The <i>BNF</i> package provides a fully modular framework for constructing
   30.20 +inductive and coinductive datatypes in HOL, with support for mixed mutual and
   30.21 +nested (co)recursion. Mixed (co)recursion enables type definitions involving
   30.22 +both datatypes and codatatypes, such as the type of finitely branching trees of
   30.23 +possibly infinite depth. The framework draws heavily from category theory.
   30.24 +
   30.25 +<p>
   30.26 +The package is described in the following paper:
   30.27 +
   30.28 +<ul>
   30.29 +  <li><a href="http://www21.in.tum.de/~traytel/papers/codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic&mdash;Category Theory Applied to Theorem Proving</a>, <br>
   30.30 +  Dmitriy Traytel, Andrei Popescu, and Jasmin Christian Blanchette.<br>
   30.31 +  <i>Logic in Computer Science (LICS 2012)</i>, 2012.
   30.32 +</ul>
   30.33 +
   30.34 +<p>
   30.35 +The main entry point for applications is <tt>BNF.thy</tt>. The <tt>Examples</tt>
   30.36 +directory contains various examples of (co)datatypes, including the examples
   30.37 +from the paper.
   30.38 +
   30.39 +<p>
   30.40 +The key notion underlying the package is that of a <i>bounded natural functor</i>
   30.41 +(<i>BNF</i>)&mdash;an enriched type constructor satisfying specific properties
   30.42 +preserved by interesting categorical operations (composition, least fixed point,
   30.43 +and greatest fixed point). The <tt>Basic_BNFs.thy</tt> and <tt>More_BNFs.thy</tt>
   30.44 +files register various basic types, notably for sums, products, function spaces,
   30.45 +finite sets, multisets, and countable sets. Custom BNFs can be registered as well.
   30.46 +
   30.47 +<p>
   30.48 +<b>Warning:</b> The package is under development. Please contact any nonempty
   30.49 +subset of
   30.50 +<a href="mailto:traytel@in.tum.de">the</a>
   30.51 +<a href="mailto:popescua@in.tum.de">above</a>
   30.52 +<a href="mailto:blanchette@in.tum.de">authors</a>
   30.53 +if you have questions or comments.
   30.54 +
   30.55 +</body>
   30.56 +
   30.57 +</html>
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/BNF/Tools/bnf_comp.ML	Fri Sep 21 16:45:06 2012 +0200
    31.3 @@ -0,0 +1,726 @@
    31.4 +(*  Title:      HOL/BNF/Tools/bnf_comp.ML
    31.5 +    Author:     Dmitriy Traytel, TU Muenchen
    31.6 +    Author:     Jasmin Blanchette, TU Muenchen
    31.7 +    Copyright   2012
    31.8 +
    31.9 +Composition of bounded natural functors.
   31.10 +*)
   31.11 +
   31.12 +signature BNF_COMP =
   31.13 +sig
   31.14 +  type unfold_set
   31.15 +  val empty_unfolds: unfold_set
   31.16 +  val map_unfolds_of: unfold_set -> thm list
   31.17 +  val rel_unfolds_of: unfold_set -> thm list
   31.18 +  val set_unfoldss_of: unfold_set -> thm list list
   31.19 +  val srel_unfolds_of: unfold_set -> thm list
   31.20 +
   31.21 +  val bnf_of_typ: BNF_Def.const_policy -> (binding -> binding) ->
   31.22 +    ((string * sort) list list -> (string * sort) list) -> typ -> unfold_set * Proof.context ->
   31.23 +    (BNF_Def.BNF * (typ list * typ list)) * (unfold_set * Proof.context)
   31.24 +  val default_comp_sort: (string * sort) list list -> (string * sort) list
   31.25 +  val normalize_bnfs: (int -> binding -> binding) -> ''a list list -> ''a list ->
   31.26 +    (''a list list -> ''a list) -> BNF_Def.BNF list -> unfold_set -> Proof.context ->
   31.27 +    (int list list * ''a list) * (BNF_Def.BNF list * (unfold_set * Proof.context))
   31.28 +  val seal_bnf: unfold_set -> binding -> typ list -> BNF_Def.BNF -> Proof.context ->
   31.29 +    (BNF_Def.BNF * typ list) * local_theory
   31.30 +end;
   31.31 +
   31.32 +structure BNF_Comp : BNF_COMP =
   31.33 +struct
   31.34 +
   31.35 +open BNF_Def
   31.36 +open BNF_Util
   31.37 +open BNF_Tactics
   31.38 +open BNF_Comp_Tactics
   31.39 +
   31.40 +type unfold_set = {
   31.41 +  map_unfolds: thm list,
   31.42 +  set_unfoldss: thm list list,
   31.43 +  rel_unfolds: thm list,
   31.44 +  srel_unfolds: thm list
   31.45 +};
   31.46 +
   31.47 +val empty_unfolds = {map_unfolds = [], set_unfoldss = [], rel_unfolds = [], srel_unfolds = []};
   31.48 +
   31.49 +fun add_to_thms thms new = thms |> not (Thm.is_reflexive new) ? insert Thm.eq_thm new;
   31.50 +fun adds_to_thms thms news = insert (eq_set Thm.eq_thm) (no_reflexive news) thms;
   31.51 +
   31.52 +fun add_to_unfolds map sets rel srel
   31.53 +  {map_unfolds, set_unfoldss, rel_unfolds, srel_unfolds} =
   31.54 +  {map_unfolds = add_to_thms map_unfolds map,
   31.55 +    set_unfoldss = adds_to_thms set_unfoldss sets,
   31.56 +    rel_unfolds = add_to_thms rel_unfolds rel,
   31.57 +    srel_unfolds = add_to_thms srel_unfolds srel};
   31.58 +
   31.59 +fun add_bnf_to_unfolds bnf =
   31.60 +  add_to_unfolds (map_def_of_bnf bnf) (set_defs_of_bnf bnf) (rel_def_of_bnf bnf)
   31.61 +    (srel_def_of_bnf bnf);
   31.62 +
   31.63 +val map_unfolds_of = #map_unfolds;
   31.64 +val set_unfoldss_of = #set_unfoldss;
   31.65 +val rel_unfolds_of = #rel_unfolds;
   31.66 +val srel_unfolds_of = #srel_unfolds;
   31.67 +
   31.68 +val bdTN = "bdT";
   31.69 +
   31.70 +fun mk_killN n = "_kill" ^ string_of_int n;
   31.71 +fun mk_liftN n = "_lift" ^ string_of_int n;
   31.72 +fun mk_permuteN src dest =
   31.73 +  "_permute_" ^ implode (map string_of_int src) ^ "_" ^ implode (map string_of_int dest);
   31.74 +
   31.75 +(*copied from Envir.expand_term_free*)
   31.76 +fun expand_term_const defs =
   31.77 +  let
   31.78 +    val eqs = map ((fn ((x, U), u) => (x, (U, u))) o apfst dest_Const) defs;
   31.79 +    val get = fn Const (x, _) => AList.lookup (op =) eqs x | _ => NONE;
   31.80 +  in Envir.expand_term get end;
   31.81 +
   31.82 +fun clean_compose_bnf const_policy qualify b outer inners (unfold_set, lthy) =
   31.83 +  let
   31.84 +    val olive = live_of_bnf outer;