src/LCF/LCF.thy

-(*  Title:      LCF/lcf.thy
+(*  Title:      LCF/LCF.thy
     ID:         $Id$
     Author:     Tobias Nipkow
     Copyright   1992  University of Cambridge
 *)
 
 header {* LCF on top of First-Order Logic *}
 
 theory LCF
 imports FOL
-uses ("LCF_lemmas.ML") ("pair.ML") ("fix.ML")
 begin
 
 text {* This theory is based on Lawrence Paulson's book Logic and Computation. *}
 
 subsection {* Natural Deduction Rules for LCF *}

   adm_conj:      "[| adm(P); adm(Q) |] ==> adm(%x. P(x)&Q(x))"
   adm_disj:      "[| adm(P); adm(Q) |] ==> adm(%x. P(x)|Q(x))"
   adm_imp:       "[| adm(%x.~P(x)); adm(Q) |] ==> adm(%x. P(x)-->Q(x))"
   adm_all:       "(!!y. adm(P(y))) ==> adm(%x. ALL y. P(y,x))"
 
-ML {* use_legacy_bindings (the_context ()) *}
-
-use "LCF_lemmas.ML"
+
+lemma eq_imp_less1: "x = y ==> x << y"
+  by (simp add: eq_def)
+
+lemma eq_imp_less2: "x = y ==> y << x"
+  by (simp add: eq_def)
+
+lemma less_refl [simp]: "x << x"
+  apply (rule eq_imp_less1)
+  apply (rule refl)
+  done
+
+lemma less_anti_sym: "[| x << y; y << x |] ==> x=y"
+  by (simp add: eq_def)
+
+lemma ext: "(!!x::'a::cpo. f(x)=(g(x)::'b::cpo)) ==> (%x. f(x))=(%x. g(x))"
+  apply (rule less_anti_sym)
+  apply (rule less_ext)
+  apply simp
+  apply simp
+  done
+
+lemma cong: "[| f=g; x=y |] ==> f(x)=g(y)"
+  by simp
+
+lemma less_ap_term: "x << y ==> f(x) << f(y)"
+  by (rule less_refl [THEN mono])
+
+lemma less_ap_thm: "f << g ==> f(x) << g(x)"
+  by (rule less_refl [THEN [2] mono])
+
+lemma ap_term: "(x::'a::cpo) = y ==> (f(x)::'b::cpo) = f(y)"
+  apply (rule cong [OF refl])
+  apply simp
+  done
+
+lemma ap_thm: "f = g ==> f(x) = g(x)"
+  apply (erule cong)
+  apply (rule refl)
+  done
+
+
+lemma UU_abs: "(%x::'a::cpo. UU) = UU"
+  apply (rule less_anti_sym)
+  prefer 2
+  apply (rule minimal)
+  apply (rule less_ext)
+  apply (rule allI)
+  apply (rule minimal)
+  done
+
+lemma UU_app: "UU(x) = UU"
+  by (rule UU_abs [symmetric, THEN ap_thm])
+
+lemma less_UU: "x << UU ==> x=UU"
+  apply (rule less_anti_sym)
+  apply assumption
+  apply (rule minimal)
+  done
+
+lemma tr_induct: "[| P(UU); P(TT); P(FF) |] ==> ALL b. P(b)"
+  apply (rule allI)
+  apply (rule mp)
+  apply (rule_tac [2] p = b in tr_cases)
+  apply blast
+  done
+
+lemma Contrapos: "~ B ==> (A ==> B) ==> ~A"
+  by blast
+
+lemma not_less_imp_not_eq1: "~ x << y \<Longrightarrow> x \<noteq> y"
+  apply (erule Contrapos)
+  apply simp
+  done
+
+lemma not_less_imp_not_eq2: "~ y << x \<Longrightarrow> x \<noteq> y"
+  apply (erule Contrapos)
+  apply simp
+  done
+
+lemma not_UU_eq_TT: "UU \<noteq> TT"
+  by (rule not_less_imp_not_eq2) (rule not_TT_less_UU)
+lemma not_UU_eq_FF: "UU \<noteq> FF"
+  by (rule not_less_imp_not_eq2) (rule not_FF_less_UU)
+lemma not_TT_eq_UU: "TT \<noteq> UU"
+  by (rule not_less_imp_not_eq1) (rule not_TT_less_UU)
+lemma not_TT_eq_FF: "TT \<noteq> FF"
+  by (rule not_less_imp_not_eq1) (rule not_TT_less_FF)
+lemma not_FF_eq_UU: "FF \<noteq> UU"
+  by (rule not_less_imp_not_eq1) (rule not_FF_less_UU)
+lemma not_FF_eq_TT: "FF \<noteq> TT"
+  by (rule not_less_imp_not_eq1) (rule not_FF_less_TT)
+
+
+lemma COND_cases_iff [rule_format]:
+    "ALL b. P(b=>x|y) <-> (b=UU-->P(UU)) & (b=TT-->P(x)) & (b=FF-->P(y))"
+  apply (insert not_UU_eq_TT not_UU_eq_FF not_TT_eq_UU
+    not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT)
+  apply (rule tr_induct)
+  apply (simplesubst COND_UU)
+  apply blast
+  apply (simplesubst COND_TT)
+  apply blast
+  apply (simplesubst COND_FF)
+  apply blast
+  done
+
+lemma COND_cases: 
+  "[| x = UU --> P(UU); x = TT --> P(xa); x = FF --> P(y) |] ==> P(x => xa | y)"
+  apply (rule COND_cases_iff [THEN iffD2])
+  apply blast
+  done
+
+lemmas [simp] =
+  minimal
+  UU_app
+  UU_app [THEN ap_thm]
+  UU_app [THEN ap_thm, THEN ap_thm]
+  not_TT_less_FF not_FF_less_TT not_TT_less_UU not_FF_less_UU not_UU_eq_TT
+  not_UU_eq_FF not_TT_eq_UU not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT
+  COND_UU COND_TT COND_FF
+  surj_pairing FST SND
 
 
 subsection {* Ordered pairs and products *}
 
-use "pair.ML"
+lemma expand_all_PROD: "(ALL p. P(p)) <-> (ALL x y. P(<x,y>))"
+  apply (rule iffI)
+  apply blast
+  apply (rule allI)
+  apply (rule surj_pairing [THEN subst])
+  apply blast
+  done
+
+lemma PROD_less: "(p::'a*'b) << q <-> FST(p) << FST(q) & SND(p) << SND(q)"
+  apply (rule iffI)
+  apply (rule conjI)
+  apply (erule less_ap_term)
+  apply (erule less_ap_term)
+  apply (erule conjE)
+  apply (rule surj_pairing [of p, THEN subst])
+  apply (rule surj_pairing [of q, THEN subst])
+  apply (rule mono, erule less_ap_term, assumption)
+  done
+
+lemma PROD_eq: "p=q <-> FST(p)=FST(q) & SND(p)=SND(q)"
+  apply (rule iffI)
+  apply simp
+  apply (unfold eq_def)
+  apply (simp add: PROD_less)
+  done
+
+lemma PAIR_less [simp]: "<a,b> << <c,d> <-> a<<c & b<<d"
+  by (simp add: PROD_less)
+
+lemma PAIR_eq [simp]: "<a,b> = <c,d> <-> a=c & b=d"
+  by (simp add: PROD_eq)
+
+lemma UU_is_UU_UU [simp]: "<UU,UU> = UU"
+  by (rule less_UU) (simp add: PROD_less)
+
+lemma FST_STRICT [simp]: "FST(UU) = UU"
+  apply (rule subst [OF UU_is_UU_UU])
+  apply (simp del: UU_is_UU_UU)
+  done
+
+lemma SND_STRICT [simp]: "SND(UU) = UU"
+  apply (rule subst [OF UU_is_UU_UU])
+  apply (simp del: UU_is_UU_UU)
+  done
 
 
 subsection {* Fixedpoint theory *}
 
-use "fix.ML"
-
+lemma adm_eq: "adm(%x. t(x)=(u(x)::'a::cpo))"
+  apply (unfold eq_def)
+  apply (rule adm_conj adm_less)+
+  done
+
+lemma adm_not_not: "adm(P) ==> adm(%x.~~P(x))"
+  by simp
+
+lemma not_eq_TT: "ALL p. ~p=TT <-> (p=FF | p=UU)"
+  and not_eq_FF: "ALL p. ~p=FF <-> (p=TT | p=UU)"
+  and not_eq_UU: "ALL p. ~p=UU <-> (p=TT | p=FF)"
+  by (rule tr_induct, simp_all)+
+
+lemma adm_not_eq_tr: "ALL p::tr. adm(%x. ~t(x)=p)"
+  apply (rule tr_induct)
+  apply (simp_all add: not_eq_TT not_eq_FF not_eq_UU)
+  apply (rule adm_disj adm_eq)+
+  done
+
+lemmas adm_lemmas =
+  adm_not_free adm_eq adm_less adm_not_less
+  adm_not_eq_tr adm_conj adm_disj adm_imp adm_all
+
+
+ML {*
+local
+  val adm_lemmas = thms "adm_lemmas"
+  val induct = thm "induct"
+in
+  fun induct_tac v i =
+    res_inst_tac[("f",v)] induct i THEN REPEAT (resolve_tac adm_lemmas i)
 end
+*}
+
+lemma least_FIX: "f(p) = p ==> FIX(f) << p"
+  apply (tactic {* induct_tac "f" 1 *})
+  apply (rule minimal)
+  apply (intro strip)
+  apply (erule subst)
+  apply (erule less_ap_term)
+  done
+
+lemma lfp_is_FIX:
+  assumes 1: "f(p) = p"
+    and 2: "ALL q. f(q)=q --> p << q"
+  shows "p = FIX(f)"
+  apply (rule less_anti_sym)
+  apply (rule 2 [THEN spec, THEN mp])
+  apply (rule FIX_eq)
+  apply (rule least_FIX)
+  apply (rule 1)
+  done
+
+
+lemma FIX_pair: "<FIX(f),FIX(g)> = FIX(%p.<f(FST(p)),g(SND(p))>)"
+  apply (rule lfp_is_FIX)
+  apply (simp add: FIX_eq [of f] FIX_eq [of g])
+  apply (intro strip)
+  apply (simp add: PROD_less)
+  apply (rule conjI)
+  apply (rule least_FIX)
+  apply (erule subst, rule FST [symmetric])
+  apply (rule least_FIX)
+  apply (erule subst, rule SND [symmetric])
+  done
+
+lemma FIX1: "FIX(f) = FST(FIX(%p. <f(FST(p)),g(SND(p))>))"
+  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct1])
+
+lemma FIX2: "FIX(g) = SND(FIX(%p. <f(FST(p)),g(SND(p))>))"
+  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct2])
+
+lemma induct2:
+  assumes 1: "adm(%p. P(FST(p),SND(p)))"
+    and 2: "P(UU::'a,UU::'b)"
+    and 3: "ALL x y. P(x,y) --> P(f(x),g(y))"
+  shows "P(FIX(f),FIX(g))"
+  apply (rule FIX1 [THEN ssubst, of _ f g])
+  apply (rule FIX2 [THEN ssubst, of _ f g])
+  apply (rule induct [OF 1, where ?f = "%x. <f(FST(x)),g(SND(x))>"])
+  apply simp
+  apply (rule 2)
+  apply (simp add: expand_all_PROD)
+  apply (rule 3)
+  done
+
+ML {*
+local
+  val induct2 = thm "induct2"
+  val adm_lemmas = thms "adm_lemmas"
+in
+
+fun induct2_tac (f,g) i =
+  res_inst_tac[("f",f),("g",g)] induct2 i THEN
+  REPEAT(resolve_tac adm_lemmas i)
+
+end
+*}
+
+end