src/HOL/Library/While_Combinator.thy
changeset 37760 8380686be5cd
parent 37757 dc78d2d9e90a
child 41720 f749155883d7
equal deleted inserted replaced
37759:00ff97087ab5 37760:8380686be5cd
     8 
     8 
     9 theory While_Combinator
     9 theory While_Combinator
    10 imports Main
    10 imports Main
    11 begin
    11 begin
    12 
    12 
    13 subsection {* Option result *}
    13 subsection {* Partial version *}
    14 
    14 
    15 definition while_option :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
    15 definition while_option :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
    16 "while_option b c s = (if (\<exists>k. ~ b ((c ^^ k) s))
    16 "while_option b c s = (if (\<exists>k. ~ b ((c ^^ k) s))
    17    then Some ((c ^^ (LEAST k. ~ b ((c ^^ k) s))) s)
    17    then Some ((c ^^ (LEAST k. ~ b ((c ^^ k) s))) s)
    18    else None)"
    18    else None)"
    79       by (induct i) (auto simp: init step 1) }
    79       by (induct i) (auto simp: init step 1) }
    80   thus "P t" by (auto simp: t)
    80   thus "P t" by (auto simp: t)
    81 qed
    81 qed
    82 
    82 
    83 
    83 
    84 subsection {* Totalized version *}
    84 subsection {* Total version *}
    85 
    85 
    86 definition while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
    86 definition while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
    87 where "while b c s = the (while_option b c s)"
    87 where "while b c s = the (while_option b c s)"
    88 
    88 
    89 lemma while_unfold:
    89 lemma while_unfold:
   125    apply blast
   125    apply blast
   126   apply (erule wf_subset)
   126   apply (erule wf_subset)
   127   apply blast
   127   apply blast
   128   done
   128   done
   129 
   129 
   130 text {*
       
   131  \medskip An application: computation of the @{term lfp} on finite
       
   132  sets via iteration.
       
   133 *}
       
   134 
       
   135 theorem lfp_conv_while:
       
   136   "[| mono f; finite U; f U = U |] ==>
       
   137     lfp f = fst (while (\<lambda>(A, fA). A \<noteq> fA) (\<lambda>(A, fA). (fA, f fA)) ({}, f {}))"
       
   138 apply (rule_tac P = "\<lambda>(A, B). (A \<subseteq> U \<and> B = f A \<and> A \<subseteq> B \<and> B \<subseteq> lfp f)" and
       
   139                 r = "((Pow U \<times> UNIV) \<times> (Pow U \<times> UNIV)) \<inter>
       
   140                      inv_image finite_psubset (op - U o fst)" in while_rule)
       
   141    apply (subst lfp_unfold)
       
   142     apply assumption
       
   143    apply (simp add: monoD)
       
   144   apply (subst lfp_unfold)
       
   145    apply assumption
       
   146   apply clarsimp
       
   147   apply (blast dest: monoD)
       
   148  apply (fastsimp intro!: lfp_lowerbound)
       
   149  apply (blast intro: wf_finite_psubset Int_lower2 [THEN [2] wf_subset])
       
   150 apply (clarsimp simp add: finite_psubset_def order_less_le)
       
   151 apply (blast intro!: finite_Diff dest: monoD)
       
   152 done
       
   153 
       
   154 
       
   155 subsection {* Example *}
       
   156 
       
   157 text{* Cannot use @{thm[source]set_eq_subset} because it leads to
       
   158 looping because the antisymmetry simproc turns the subset relationship
       
   159 back into equality. *}
       
   160 
       
   161 theorem "P (lfp (\<lambda>N::int set. {0} \<union> {(n + 2) mod 6 | n. n \<in> N})) =
       
   162   P {0, 4, 2}"
       
   163 proof -
       
   164   have seteq: "!!A B. (A = B) = ((!a : A. a:B) & (!b:B. b:A))"
       
   165     by blast
       
   166   have aux: "!!f A B. {f n | n. A n \<or> B n} = {f n | n. A n} \<union> {f n | n. B n}"
       
   167     apply blast
       
   168     done
       
   169   show ?thesis
       
   170     apply (subst lfp_conv_while [where ?U = "{0, 1, 2, 3, 4, 5}"])
       
   171        apply (rule monoI)
       
   172       apply blast
       
   173      apply simp
       
   174     apply (simp add: aux set_eq_subset)
       
   175     txt {* The fixpoint computation is performed purely by rewriting: *}
       
   176     apply (simp add: while_unfold aux seteq del: subset_empty)
       
   177     done
       
   178 qed
       
   179 
   130 
   180 end
   131 end