pcpodef package: state two goals, instead of encoded conjunction;
authorwenzelm
Thu, 11 Dec 2008 16:50:18 +0100
changeset 29063 7619f0561cd7
parent 29062 6f8a100325b6
child 29065 d53f78cafb86
pcpodef package: state two goals, instead of encoded conjunction;
src/HOLCF/Cfun.thy
src/HOLCF/Fixrec.thy
src/HOLCF/Lift.thy
src/HOLCF/Sprod.thy
src/HOLCF/Ssum.thy
src/HOLCF/Tools/pcpodef_package.ML
--- a/src/HOLCF/Cfun.thy	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Cfun.thy	Thu Dec 11 16:50:18 2008 +0100
@@ -23,7 +23,7 @@
 by (rule admI, rule cont_lub_fun)
 
 cpodef (CFun)  ('a, 'b) "->" (infixr "->" 0) = "{f::'a => 'b. cont f}"
-by (simp add: Ex_cont adm_cont)
+by (simp_all add: Ex_cont adm_cont)
 
 syntax (xsymbols)
   "->"     :: "[type, type] => type"      ("(_ \<rightarrow>/ _)" [1,0]0)
--- a/src/HOLCF/Fixrec.thy	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Fixrec.thy	Thu Dec 11 16:50:18 2008 +0100
@@ -15,7 +15,7 @@
 defaultsort cpo
 
 pcpodef (open) 'a maybe = "UNIV::(one ++ 'a u) set"
-by simp
+by simp_all
 
 constdefs
   fail :: "'a maybe"
--- a/src/HOLCF/Lift.thy	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Lift.thy	Thu Dec 11 16:50:18 2008 +0100
@@ -12,7 +12,7 @@
 defaultsort type
 
 pcpodef 'a lift = "UNIV :: 'a discr u set"
-by simp
+by simp_all
 
 instance lift :: (finite) finite_po
 by (rule typedef_finite_po [OF type_definition_lift])
--- a/src/HOLCF/Sprod.thy	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Sprod.thy	Thu Dec 11 16:50:18 2008 +0100
@@ -17,7 +17,7 @@
 
 pcpodef (Sprod)  ('a, 'b) "**" (infixr "**" 20) =
         "{p::'a \<times> 'b. p = \<bottom> \<or> (cfst\<cdot>p \<noteq> \<bottom> \<and> csnd\<cdot>p \<noteq> \<bottom>)}"
-by simp
+by simp_all
 
 instance "**" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
 by (rule typedef_finite_po [OF type_definition_Sprod])
--- a/src/HOLCF/Ssum.thy	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Ssum.thy	Thu Dec 11 16:50:18 2008 +0100
@@ -19,7 +19,7 @@
   "{p :: tr \<times> ('a \<times> 'b).
     (cfst\<cdot>p \<sqsubseteq> TT \<longleftrightarrow> csnd\<cdot>(csnd\<cdot>p) = \<bottom>) \<and>
     (cfst\<cdot>p \<sqsubseteq> FF \<longleftrightarrow> cfst\<cdot>(csnd\<cdot>p) = \<bottom>)}"
-by simp
+by simp_all
 
 instance "++" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
 by (rule typedef_finite_po [OF type_definition_Ssum])
--- a/src/HOLCF/Tools/pcpodef_package.ML	Thu Dec 11 16:30:35 2008 +0100
+++ b/src/HOLCF/Tools/pcpodef_package.ML	Thu Dec 11 16:50:18 2008 +0100
@@ -47,11 +47,11 @@
       error ("Not a set type: " ^ quote (Syntax.string_of_typ ctxt setT));
 
     (*goal*)
-    val goal_UU_mem = HOLogic.mk_mem (Const (@{const_name UU}, oldT), set);
-    val goal_nonempty = HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set));
-    val goal_admissible = mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set));
-    val goal = HOLogic.mk_Trueprop
-      (HOLogic.mk_conj (if pcpo then goal_UU_mem else goal_nonempty, goal_admissible));
+    val goal_UU_mem = HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
+    val goal_nonempty =
+      HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
+    val goal_admissible =
+      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
 
     (*lhs*)
     val defS = Sign.defaultS thy;
@@ -107,10 +107,10 @@
         |> Sign.parent_path
       end;
 
-    fun make_pcpo UUmem (type_def, less_def, set_def) theory =
+    fun make_pcpo UU_mem (type_def, less_def, set_def) theory =
       let
-        val UUmem' = fold_rule (the_list set_def) UUmem;
-        val pcpo_thms = map (Thm.transfer theory) [type_def, less_def, UUmem'];
+        val UU_mem' = fold_rule (the_list set_def) UU_mem;
+        val pcpo_thms = map (Thm.transfer theory) [type_def, less_def, UU_mem'];
         val theory' = theory
           |> AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo})
             (Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1);
@@ -130,27 +130,18 @@
         |> Sign.parent_path
       end;
 
-    fun pcpodef_result UUmem_admissible theory =
-      let
-        val UUmem = UUmem_admissible RS conjunct1;
-        val admissible = UUmem_admissible RS conjunct2;
-      in
-        theory
-        |> make_po (Tactic.rtac exI 1 THEN Tactic.rtac UUmem 1)
-        |-> (fn defs => make_cpo admissible defs #> make_pcpo UUmem defs)
-      end;
+    fun pcpodef_result UU_mem admissible =
+      make_po (Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1)
+      #-> (fn defs => make_cpo admissible defs #> make_pcpo UU_mem defs);
 
-    fun cpodef_result nonempty_admissible theory =
-      let
-        val nonempty = nonempty_admissible RS conjunct1;
-        val admissible = nonempty_admissible RS conjunct2;
-      in
-        theory
-        |> make_po (Tactic.rtac nonempty 1)
-        |-> make_cpo admissible
-      end;
-
-  in (goal, if pcpo then pcpodef_result else cpodef_result) end
+    fun cpodef_result nonempty admissible =
+      make_po (Tactic.rtac nonempty 1)
+      #-> make_cpo admissible;
+  in
+    if pcpo
+    then (goal_UU_mem, goal_admissible, pcpodef_result)
+    else (goal_nonempty, goal_admissible, cpodef_result)
+  end
   handle ERROR msg => err_in_cpodef msg name;
 
 
@@ -160,10 +151,10 @@
 
 fun gen_pcpodef_proof prep_term pcpo ((def, name), typ, set, opt_morphs) thy =
   let
-    val (goal, pcpodef_result) =
+    val (goal1, goal2, make_result) =
       prepare_pcpodef prep_term pcpo def name typ set opt_morphs thy;
-    fun after_qed [[th]] = ProofContext.theory (pcpodef_result th);
-  in Proof.theorem_i NONE after_qed [[(goal, [])]] (ProofContext.init thy) end;
+    fun after_qed [[th1, th2]] = ProofContext.theory (make_result th1 th2);
+  in Proof.theorem_i NONE after_qed [[(goal1, []), (goal2, [])]] (ProofContext.init thy) end;
 
 in