src/HOL/Predicate.thy

--- a/src/HOL/Predicate.thy	Thu Nov 19 08:25:51 2009 +0100
+++ b/src/HOL/Predicate.thy	Thu Nov 19 08:25:53 2009 +0100
@@ -570,6 +570,9 @@
 definition if_pred :: "bool \<Rightarrow> unit pred" where
   if_pred_eq: "if_pred b = (if b then single () else \<bottom>)"
 
+definition holds :: "unit pred \<Rightarrow> bool" where
+  holds_eq: "holds P = eval P ()"
+
 definition not_pred :: "unit pred \<Rightarrow> unit pred" where
   not_pred_eq: "not_pred P = (if eval P () then \<bottom> else single ())"
 
@@ -592,7 +595,54 @@
 lemma not_predE': "eval (not_pred P) x \<Longrightarrow> (\<not> eval P x \<Longrightarrow> thesis) \<Longrightarrow> thesis"
   unfolding not_pred_eq
   by (auto split: split_if_asm elim: botE)
+lemma "f () = False \<or> f () = True"
+by simp
 
+lemma closure_of_bool_cases:
+assumes "(f :: unit \<Rightarrow> bool) = (%u. False) \<Longrightarrow> P f"
+assumes "f = (%u. True) \<Longrightarrow> P f"
+shows "P f"
+proof -
+  have "f = (%u. False) \<or> f = (%u. True)"
+    apply (cases "f ()")
+    apply (rule disjI2)
+    apply (rule ext)
+    apply (simp add: unit_eq)
+    apply (rule disjI1)
+    apply (rule ext)
+    apply (simp add: unit_eq)
+    done
+  from this prems show ?thesis by blast
+qed
+
+lemma unit_pred_cases:
+assumes "P \<bottom>"
+assumes "P (single ())"
+shows "P Q"
+using assms
+unfolding bot_pred_def Collect_def empty_def single_def
+apply (cases Q)
+apply simp
+apply (rule_tac f="fun" in closure_of_bool_cases)
+apply auto
+apply (subgoal_tac "(%x. () = x) = (%x. True)") 
+apply auto
+done
+
+lemma holds_if_pred:
+  "holds (if_pred b) = b"
+unfolding if_pred_eq holds_eq
+by (cases b) (auto intro: singleI elim: botE)
+
+lemma if_pred_holds:
+  "if_pred (holds P) = P"
+unfolding if_pred_eq holds_eq
+by (rule unit_pred_cases) (auto intro: singleI elim: botE)
+
+lemma is_empty_holds:
+  "is_empty P \<longleftrightarrow> \<not> holds P"
+unfolding is_empty_def holds_eq
+by (rule unit_pred_cases) (auto elim: botE intro: singleI)
 
 subsubsection {* Implementation *}
 
@@ -838,7 +888,7 @@
   bind (infixl "\<guillemotright>=" 70)
 
 hide (open) type pred seq
-hide (open) const Pred eval single bind is_empty singleton if_pred not_pred
+hide (open) const Pred eval single bind is_empty singleton if_pred not_pred holds
   Empty Insert Join Seq member pred_of_seq "apply" adjunct null the_only eq map not_unique the
 
 end