theory MonoPredicateTransformers
  imports PredicateTransformers
begin

section {* Monotonic predicate transformers *}

declare [[coercion_enabled]]

text {* Closed operations *}

lemma mono_skip [simp,intro]: "mono id"
  by (auto intro: order_class.monoI)

lemma mono_ex [simp]: "\<exists>f :: 'a :: order \<Rightarrow> 'a. mono f"
  by (rule_tac x=id in exI) simp

lemma mono_comp_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F o G)"
  by (auto simp: order_class.mono_def intro!: order_class.monoI)

lemma mono_magic [simp,intro]: "mono \<top>"
  by (simp add: order_class.mono_def)

lemma mono_abort [simp,intro]: "mono \<bottom>"
  by (simp add: order_class.mono_def)

lemma mono_sup_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F + G)"
  by (auto simp: order_class.mono_def intro: sup.coboundedI1 sup.coboundedI2)

lemma mono_inf_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F \<sqinter> G)"
  by (auto simp: order_class.mono_def intro: inf.coboundedI1 inf.coboundedI2)

text {* The lifting of * is not isotonic closed  *}
lemma mono_inf_clos [intro]: "\<lbrakk>mono F; mono G\<rbrakk> \<Longrightarrow> mono (F * G)"
  (* nitpick[show_all] *) oops

lemma mono_Sup_clos [intro]: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f \<Longrightarrow> mono (\<Squnion> F)"
  by (auto simp: order_class.mono_def, rule SUP_mono) auto

lemma mono_Inf_clos [intro]: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f \<Longrightarrow> mono (\<Sqinter> F)"
  by (auto simp: order_class.mono_def, rule INF_mono) auto

text {* Type of monotonic predicate transformers *}

typedef 'a mtran = "{F :: 'a :: bbi \<Rightarrow> 'a. mono F}" by simp
setup_lifting type_definition_mtran

declare [[coercion Rep_mtran]]

text {* It forms a monoid on respect to function aplication *}
instantiation mtran :: (bbi) monoid_mult
begin
  lift_definition one_mtran :: "'a mtran" is id ..
  lift_definition times_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> 'a mtran" is "op o" ..
  instance
    by default (transfer, auto)+
end

text {* It forms a complete lattice *}
instantiation mtran :: (bbi) bounded_lattice
begin
lift_definition bot_mtran :: "'a mtran" is \<bottom>  ..
lift_definition sup_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> 'a mtran" is sup ..
lift_definition top_mtran :: "'a mtran" is \<top>  ..
lift_definition inf_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> 'a mtran" is inf ..
lift_definition less_eq_mtran:: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> bool" is "op \<le>" .
lift_definition less_mtran :: "'a mtran \<Rightarrow> 'a mtran \<Rightarrow> bool" is "op <" .
instance
  by default (transfer, auto)+
end

instantiation mtran :: (bbi) complete_lattice
begin
lift_definition Inf_mtran :: "'a mtran set \<Rightarrow> 'a mtran" is Inf by auto
lift_definition Sup_mtran :: "'a mtran set \<Rightarrow> 'a mtran" is Sup by auto
instance
  by default (transfer, auto intro: Inf_lower Inf_greatest Sup_upper Sup_least)+
end

text {* It doesn't form a distributivity lattice *}
instance mtran :: (bbi) complete_distrib_lattice
  apply default defer (* nitpick *) oops

text {* It forms a pre quantale on respect to function aplication, but not a full quantale *}

instance mtran :: (bbi) near_quantale_Sup_unital
  by default (transfer, auto)

lemma mono_qSup_subdistl: "mono (f :: 'a :: complete_lattice \<Rightarrow> 'a) \<Longrightarrow> \<Squnion>((\<lambda>g. f o g) ` G) \<le> f \<circ> \<Squnion>G"
  by (rule Sup_least) (auto intro!: le_funI order_class.monoD[of "\<lambda>x. f x"] SUP_upper)

instance mtran :: (bbi) pre_quantale_Sup
  by default (transfer, simp only: mono_qSup_subdistl)

instance mtran :: (bbi) quantale_Sup_unital
  (* nitpick, it needs to be strict monotone *) oops

end


(*  Title:      ZF/ex/Limit.thy
    Author:     Sten Agerholm
    Author:     Lawrence C Paulson

A formalization of the inverse limit construction of domain theory.

The following paper comments on the formalization:

"A Comparison of HOL-ST and Isabelle/ZF" by Sten Agerholm
In Proceedings of the First Isabelle Users Workshop, Technical
Report No. 379, University of Cambridge Computer Laboratory, 1995.

This is a condensed version of:

"A Comparison of HOL-ST and Isabelle/ZF" by Sten Agerholm
Technical Report No. 369, University of Cambridge Computer
Laboratory, 1995.
*)

theory Limit  imports  ZF begin

definition
  rel :: "[i,i,i]=>o"  where
    "rel(D,x,y) == <x,y>:snd(D)"

definition
  set :: "i=>i"  where
    "set(D) == fst(D)"

definition
  po  :: "i=>o"  where
    "po(D) ==
     (\<forall>x \<in> set(D). rel(D,x,x)) &
     (\<forall>x \<in> set(D). \<forall>y \<in> set(D). \<forall>z \<in> set(D).
       rel(D,x,y) \<longrightarrow> rel(D,y,z) \<longrightarrow> rel(D,x,z)) &
     (\<forall>x \<in> set(D). \<forall>y \<in> set(D). rel(D,x,y) \<longrightarrow> rel(D,y,x) \<longrightarrow> x = y)"

definition
  chain :: "[i,i]=>o"  where
    (* Chains are object level functions nat->set(D) *)
    "chain(D,X) == X \<in> nat->set(D) & (\<forall>n \<in> nat. rel(D,X`n,X`(succ(n))))"

definition
  isub :: "[i,i,i]=>o"  where
    "isub(D,X,x) == x \<in> set(D) & (\<forall>n \<in> nat. rel(D,X`n,x))"

definition
  islub :: "[i,i,i]=>o"  where
    "islub(D,X,x) == isub(D,X,x) & (\<forall>y. isub(D,X,y) \<longrightarrow> rel(D,x,y))"

definition
  lub :: "[i,i]=>i"  where
    "lub(D,X) == THE x. islub(D,X,x)"

definition
  cpo :: "i=>o"  where
    "cpo(D) == po(D) & (\<forall>X. chain(D,X) \<longrightarrow> (\<exists>x. islub(D,X,x)))"

definition
  pcpo :: "i=>o"  where
    "pcpo(D) == cpo(D) & (\<exists>x \<in> set(D). \<forall>y \<in> set(D). rel(D,x,y))"

definition
  bot :: "i=>i"  where
    "bot(D) == THE x. x \<in> set(D) & (\<forall>y \<in> set(D). rel(D,x,y))"

definition
  mono :: "[i,i]=>i"  where
    "mono(D,E) ==
     {f \<in> set(D)->set(E).
      \<forall>x \<in> set(D). \<forall>y \<in> set(D). rel(D,x,y) \<longrightarrow> rel(E,f`x,f`y)}"

definition
  cont :: "[i,i]=>i"  where
    "cont(D,E) ==
     {f \<in> mono(D,E).
      \<forall>X. chain(D,X) \<longrightarrow> f`(lub(D,X)) = lub(E,\<lambda>n \<in> nat. f`(X`n))}"

definition
  cf :: "[i,i]=>i"  where
    "cf(D,E) ==
     <cont(D,E),
      {y \<in> cont(D,E)*cont(D,E). \<forall>x \<in> set(D). rel(E,(fst(y))`x,(snd(y))`x)}>"

definition
  suffix :: "[i,i]=>i"  where
    "suffix(X,n) == \<lambda>m \<in> nat. X`(n #+ m)"

definition
  subchain :: "[i,i]=>o"  where
    "subchain(X,Y) == \<forall>m \<in> nat. \<exists>n \<in> nat. X`m = Y`(m #+ n)"

definition
  dominate :: "[i,i,i]=>o"  where
    "dominate(D,X,Y) == \<forall>m \<in> nat. \<exists>n \<in> nat. rel(D,X`m,Y`n)"

definition
  matrix :: "[i,i]=>o"  where
    "matrix(D,M) ==
     M \<in> nat -> (nat -> set(D)) &
     (\<forall>n \<in> nat. \<forall>m \<in> nat. rel(D,M`n`m,M`succ(n)`m)) &
     (\<forall>n \<in> nat. \<forall>m \<in> nat. rel(D,M`n`m,M`n`succ(m))) &
     (\<forall>n \<in> nat. \<forall>m \<in> nat. rel(D,M`n`m,M`succ(n)`succ(m)))"

definition
  projpair  :: "[i,i,i,i]=>o"  where
    "projpair(D,E,e,p) ==
     e \<in> cont(D,E) & p \<in> cont(E,D) &
     p O e = id(set(D)) & rel(cf(E,E),e O p,id(set(E)))"

definition
  emb       :: "[i,i,i]=>o"  where
    "emb(D,E,e) == \<exists>p. projpair(D,E,e,p)"

definition
  Rp        :: "[i,i,i]=>i"  where
    "Rp(D,E,e) == THE p. projpair(D,E,e,p)"

definition
  (* Twice, constructions on cpos are more difficult. *)
  iprod     :: "i=>i"  where
    "iprod(DD) ==
     <(\<Prod>n \<in> nat. set(DD`n)),
      {x:(\<Prod>n \<in> nat. set(DD`n))*(\<Prod>n \<in> nat. set(DD`n)).
       \<forall>n \<in> nat. rel(DD`n,fst(x)`n,snd(x)`n)}>"

definition
  mkcpo     :: "[i,i=>o]=>i"  where
    (* Cannot use rel(D), is meta fun, need two more args *)
    "mkcpo(D,P) ==
     <{x \<in> set(D). P(x)},{x \<in> set(D)*set(D). rel(D,fst(x),snd(x))}>"

definition
  subcpo    :: "[i,i]=>o"  where
    "subcpo(D,E) ==
     set(D) \<subseteq> set(E) &
     (\<forall>x \<in> set(D). \<forall>y \<in> set(D). rel(D,x,y) \<longleftrightarrow> rel(E,x,y)) &
     (\<forall>X. chain(D,X) \<longrightarrow> lub(E,X):set(D))"

definition
  subpcpo   :: "[i,i]=>o"  where
    "subpcpo(D,E) == subcpo(D,E) & bot(E):set(D)"

definition
  emb_chain :: "[i,i]=>o"  where
    "emb_chain(DD,ee) ==
     (\<forall>n \<in> nat. cpo(DD`n)) & (\<forall>n \<in> nat. emb(DD`n,DD`succ(n),ee`n))"

definition
  Dinf      :: "[i,i]=>i"  where
    "Dinf(DD,ee) ==
     mkcpo(iprod(DD))
     (%x. \<forall>n \<in> nat. Rp(DD`n,DD`succ(n),ee`n)`(x`succ(n)) = x`n)"

definition
  e_less    :: "[i,i,i,i]=>i"  where
  (* Valid for m \<le> n only. *)
    "e_less(DD,ee,m,n) == rec(n#-m,id(set(DD`m)),%x y. ee`(m#+x) O y)"

definition
  e_gr      :: "[i,i,i,i]=>i"  where
  (* Valid for n \<le> m only. *)
    "e_gr(DD,ee,m,n) ==
     rec(m#-n,id(set(DD`n)),
         %x y. y O Rp(DD`(n#+x),DD`(succ(n#+x)),ee`(n#+x)))"

definition
  eps       :: "[i,i,i,i]=>i"  where
    "eps(DD,ee,m,n) == if(m \<le> n,e_less(DD,ee,m,n),e_gr(DD,ee,m,n))"

definition
  rho_emb   :: "[i,i,i]=>i"  where
    "rho_emb(DD,ee,n) == \<lambda>x \<in> set(DD`n). \<lambda>m \<in> nat. eps(DD,ee,n,m)`x"

definition
  rho_proj  :: "[i,i,i]=>i"  where
    "rho_proj(DD,ee,n) == \<lambda>x \<in> set(Dinf(DD,ee)). x`n"

definition
  commute   :: "[i,i,i,i=>i]=>o"  where
    "commute(DD,ee,E,r) ==
     (\<forall>n \<in> nat. emb(DD`n,E,r(n))) &
     (\<forall>m \<in> nat. \<forall>n \<in> nat. m \<le> n \<longrightarrow> r(n) O eps(DD,ee,m,n) = r(m))"

definition
  mediating :: "[i,i,i=>i,i=>i,i]=>o"  where
    "mediating(E,G,r,f,t) == emb(E,G,t) & (\<forall>n \<in> nat. f(n) = t O r(n))"

lemmas nat_linear_le = Ord_linear_le [OF nat_into_Ord nat_into_Ord]

(*----------------------------------------------------------------------*)
(* Basic results.                                                       *)
(*----------------------------------------------------------------------*)

lemma set_I: "x \<in> fst(D) ==> x \<in> set(D)"
by (simp add: set_def)

lemma rel_I: "<x,y>:snd(D) ==> rel(D,x,y)"
by (simp add: rel_def)

lemma rel_E: "rel(D,x,y) ==> <x,y>:snd(D)"
by (simp add: rel_def)

(*----------------------------------------------------------------------*)
(* I/E/D rules for po and cpo.                                          *)
(*----------------------------------------------------------------------*)

lemma po_refl: "[|po(D); x \<in> set(D)|] ==> rel(D,x,x)"
by (unfold po_def, blast)

lemma po_trans: "[|po(D); rel(D,x,y); rel(D,y,z); x \<in> set(D);
                  y \<in> set(D); z \<in> set(D)|] ==> rel(D,x,z)"
by (unfold po_def, blast)

lemma po_antisym:
    "[|po(D); rel(D,x,y); rel(D,y,x); x \<in> set(D); y \<in> set(D)|] ==> x = y"
by (unfold po_def, blast)

lemma poI:
  "[| !!x. x \<in> set(D) ==> rel(D,x,x);
      !!x y z. [| rel(D,x,y); rel(D,y,z); x \<in> set(D); y \<in> set(D); z \<in> set(D)|]
               ==> rel(D,x,z);
      !!x y. [| rel(D,x,y); rel(D,y,x); x \<in> set(D); y \<in> set(D)|] ==> x=y |]
   ==> po(D)"
by (unfold po_def, blast)

lemma cpoI: "[| po(D); !!X. chain(D,X) ==> islub(D,X,x(D,X))|] ==> cpo(D)"
by (simp add: cpo_def, blast)

lemma cpo_po: "cpo(D) ==> po(D)"
by (simp add: cpo_def)

lemma cpo_refl [simp,intro!,TC]: "[|cpo(D); x \<in> set(D)|] ==> rel(D,x,x)"
by (blast intro: po_refl cpo_po)

lemma cpo_trans:
     "[|cpo(D); rel(D,x,y); rel(D,y,z); x \<in> set(D);
        y \<in> set(D); z \<in> set(D)|] ==> rel(D,x,z)"
by (blast intro: cpo_po po_trans)

lemma cpo_antisym:
     "[|cpo(D); rel(D,x,y); rel(D,y,x); x \<in> set(D); y \<in> set(D)|] ==> x = y"
by (blast intro: cpo_po po_antisym)

lemma cpo_islub: "[|cpo(D); chain(D,X);  !!x. islub(D,X,x) ==> R|] ==> R"
by (simp add: cpo_def, blast)

(*----------------------------------------------------------------------*)
(* Theorems about isub and islub.                                       *)
(*----------------------------------------------------------------------*)

lemma islub_isub: "islub(D,X,x) ==> isub(D,X,x)"
by (simp add: islub_def)

lemma islub_in: "islub(D,X,x) ==> x \<in> set(D)"
by (simp add: islub_def isub_def)

lemma islub_ub: "[|islub(D,X,x); n \<in> nat|] ==> rel(D,X`n,x)"
by (simp add: islub_def isub_def)

lemma islub_least: "[|islub(D,X,x); isub(D,X,y)|] ==> rel(D,x,y)"
by (simp add: islub_def)

lemma islubI:
    "[|isub(D,X,x); !!y. isub(D,X,y) ==> rel(D,x,y)|] ==> islub(D,X,x)"
by (simp add: islub_def)

lemma isubI:
    "[|x \<in> set(D);  !!n. n \<in> nat ==> rel(D,X`n,x)|] ==> isub(D,X,x)"
by (simp add: isub_def)

lemma isubE:
    "[|isub(D,X,x); [|x \<in> set(D);  !!n. n \<in> nat==>rel(D,X`n,x)|] ==> P
     |] ==> P"
by (simp add: isub_def)

lemma isubD1: "isub(D,X,x) ==> x \<in> set(D)"
by (simp add: isub_def)

lemma isubD2: "[|isub(D,X,x); n \<in> nat|]==>rel(D,X`n,x)"
by (simp add: isub_def)

lemma islub_unique: "[|islub(D,X,x); islub(D,X,y); cpo(D)|] ==> x = y"
by (blast intro: cpo_antisym islub_least islub_isub islub_in)

(*----------------------------------------------------------------------*)
(* lub gives the least upper bound of chains.                           *)
(*----------------------------------------------------------------------*)

lemma cpo_lub: "[|chain(D,X); cpo(D)|] ==> islub(D,X,lub(D,X))"
apply (simp add: lub_def)
apply (best elim: cpo_islub intro: theI islub_unique)
done

(*----------------------------------------------------------------------*)
(* Theorems about chains.                                               *)
(*----------------------------------------------------------------------*)

lemma chainI:
  "[|X \<in> nat->set(D);  !!n. n \<in> nat ==> rel(D,X`n,X`succ(n))|] ==> chain(D,X)"
by (simp add: chain_def)

lemma chain_fun: "chain(D,X) ==> X \<in> nat -> set(D)"
by (simp add: chain_def)

lemma chain_in [simp,TC]: "[|chain(D,X); n \<in> nat|] ==> X`n \<in> set(D)"
apply (simp add: chain_def)
apply (blast dest: apply_type)
done

lemma chain_rel [simp,TC]:
     "[|chain(D,X); n \<in> nat|] ==> rel(D, X ` n, X ` succ(n))"
by (simp add: chain_def)

lemma chain_rel_gen_add:
     "[|chain(D,X); cpo(D); n \<in> nat; m \<in> nat|] ==> rel(D,X`n,(X`(m #+ n)))"
apply (induct_tac m)
apply (auto intro: cpo_trans)
done

lemma chain_rel_gen:
    "[|n \<le> m; chain(D,X); cpo(D); m \<in> nat|] ==> rel(D,X`n,X`m)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp) (*prepare the induction*)
apply (induct_tac m)
apply (auto intro: cpo_trans simp add: le_iff)
done

(*----------------------------------------------------------------------*)
(* Theorems about pcpos and bottom.                                     *)
(*----------------------------------------------------------------------*)

lemma pcpoI:
    "[|!!y. y \<in> set(D)==>rel(D,x,y); x \<in> set(D); cpo(D)|]==>pcpo(D)"
by (simp add: pcpo_def, auto)

lemma pcpo_cpo [TC]: "pcpo(D) ==> cpo(D)"
by (simp add: pcpo_def)

lemma pcpo_bot_ex1:
    "pcpo(D) ==> \<exists>! x. x \<in> set(D) & (\<forall>y \<in> set(D). rel(D,x,y))"
apply (simp add: pcpo_def)
apply (blast intro: cpo_antisym)
done

lemma bot_least [TC]:
    "[| pcpo(D); y \<in> set(D)|] ==> rel(D,bot(D),y)"
apply (simp add: bot_def)
apply (best intro: pcpo_bot_ex1 [THEN theI2])
done

lemma bot_in [TC]:
    "pcpo(D) ==> bot(D):set(D)"
apply (simp add: bot_def)
apply (best intro: pcpo_bot_ex1 [THEN theI2])
done

lemma bot_unique:
    "[| pcpo(D); x \<in> set(D); !!y. y \<in> set(D) ==> rel(D,x,y)|] ==> x = bot(D)"
by (blast intro: cpo_antisym pcpo_cpo bot_in bot_least)

(*----------------------------------------------------------------------*)
(* Constant chains and lubs and cpos.                                   *)
(*----------------------------------------------------------------------*)

lemma chain_const: "[|x \<in> set(D); cpo(D)|] ==> chain(D,(\<lambda>n \<in> nat. x))"
by (simp add: chain_def)

lemma islub_const:
   "[|x \<in> set(D); cpo(D)|] ==> islub(D,(\<lambda>n \<in> nat. x),x)"
by (simp add: islub_def isub_def, blast)

lemma lub_const: "[|x \<in> set(D); cpo(D)|] ==> lub(D,\<lambda>n \<in> nat. x) = x"
by (blast intro: islub_unique cpo_lub chain_const islub_const)

(*----------------------------------------------------------------------*)
(* Taking the suffix of chains has no effect on ub's.                   *)
(*----------------------------------------------------------------------*)

lemma isub_suffix:
    "[| chain(D,X); cpo(D) |] ==> isub(D,suffix(X,n),x) \<longleftrightarrow> isub(D,X,x)"
apply (simp add: isub_def suffix_def, safe)
apply (drule_tac x = na in bspec)
apply (auto intro: cpo_trans chain_rel_gen_add)
done

lemma islub_suffix:
  "[|chain(D,X); cpo(D)|] ==> islub(D,suffix(X,n),x) \<longleftrightarrow> islub(D,X,x)"
by (simp add: islub_def isub_suffix)

lemma lub_suffix:
    "[|chain(D,X); cpo(D)|] ==> lub(D,suffix(X,n)) = lub(D,X)"
by (simp add: lub_def islub_suffix)

(*----------------------------------------------------------------------*)
(* Dominate and subchain.                                               *)
(*----------------------------------------------------------------------*)

lemma dominateI:
  "[| !!m. m \<in> nat ==> n(m):nat; !!m. m \<in> nat ==> rel(D,X`m,Y`n(m))|]
   ==> dominate(D,X,Y)"
by (simp add: dominate_def, blast)

lemma dominate_isub:
  "[|dominate(D,X,Y); isub(D,Y,x); cpo(D);
     X \<in> nat->set(D); Y \<in> nat->set(D)|] ==> isub(D,X,x)"
apply (simp add: isub_def dominate_def)
apply (blast intro: cpo_trans intro!: apply_funtype)
done

lemma dominate_islub:
  "[|dominate(D,X,Y); islub(D,X,x); islub(D,Y,y); cpo(D);
     X \<in> nat->set(D); Y \<in> nat->set(D)|] ==> rel(D,x,y)"
apply (simp add: islub_def)
apply (blast intro: dominate_isub)
done

lemma subchain_isub:
     "[|subchain(Y,X); isub(D,X,x)|] ==> isub(D,Y,x)"
by (simp add: isub_def subchain_def, force)

lemma dominate_islub_eq:
     "[|dominate(D,X,Y); subchain(Y,X); islub(D,X,x); islub(D,Y,y); cpo(D);
        X \<in> nat->set(D); Y \<in> nat->set(D)|] ==> x = y"
by (blast intro: cpo_antisym dominate_islub islub_least subchain_isub
                 islub_isub islub_in)

(*----------------------------------------------------------------------*)
(* Matrix.                                                              *)
(*----------------------------------------------------------------------*)

lemma matrix_fun: "matrix(D,M) ==> M \<in> nat -> (nat -> set(D))"
by (simp add: matrix_def)

lemma matrix_in_fun: "[|matrix(D,M); n \<in> nat|] ==> M`n \<in> nat -> set(D)"
by (blast intro: apply_funtype matrix_fun)

lemma matrix_in: "[|matrix(D,M); n \<in> nat; m \<in> nat|] ==> M`n`m \<in> set(D)"
by (blast intro: apply_funtype matrix_in_fun)

lemma matrix_rel_1_0:
    "[|matrix(D,M); n \<in> nat; m \<in> nat|] ==> rel(D,M`n`m,M`succ(n)`m)"
by (simp add: matrix_def)

lemma matrix_rel_0_1:
    "[|matrix(D,M); n \<in> nat; m \<in> nat|] ==> rel(D,M`n`m,M`n`succ(m))"
by (simp add: matrix_def)

lemma matrix_rel_1_1:
    "[|matrix(D,M); n \<in> nat; m \<in> nat|] ==> rel(D,M`n`m,M`succ(n)`succ(m))"
by (simp add: matrix_def)

lemma fun_swap: "f \<in> X->Y->Z ==> (\<lambda>y \<in> Y. \<lambda>x \<in> X. f`x`y):Y->X->Z"
by (blast intro: lam_type apply_funtype)

lemma matrix_sym_axis:
    "matrix(D,M) ==> matrix(D,\<lambda>m \<in> nat. \<lambda>n \<in> nat. M`n`m)"
by (simp add: matrix_def fun_swap)

lemma matrix_chain_diag:
    "matrix(D,M) ==> chain(D,\<lambda>n \<in> nat. M`n`n)"
apply (simp add: chain_def)
apply (auto intro: lam_type matrix_in matrix_rel_1_1)
done

lemma matrix_chain_left:
    "[|matrix(D,M); n \<in> nat|] ==> chain(D,M`n)"
apply (unfold chain_def)
apply (auto intro: matrix_fun [THEN apply_type] matrix_in matrix_rel_0_1)
done

lemma matrix_chain_right:
    "[|matrix(D,M); m \<in> nat|] ==> chain(D,\<lambda>n \<in> nat. M`n`m)"
apply (simp add: chain_def)
apply (auto intro: lam_type matrix_in matrix_rel_1_0)
done

lemma matrix_chainI:
  assumes xprem: "!!x. x \<in> nat==>chain(D,M`x)"
      and yprem: "!!y. y \<in> nat==>chain(D,\<lambda>x \<in> nat. M`x`y)"
      and Mfun:  "M \<in> nat->nat->set(D)"
      and cpoD:  "cpo(D)"
  shows "matrix(D,M)"
proof -
  {
    fix n m assume "n \<in> nat" "m \<in> nat"
    with chain_rel [OF yprem]
    have "rel(D, M ` n ` m, M ` succ(n) ` m)" by simp
  } note rel_succ = this
  show "matrix(D,M)"
  proof (simp add: matrix_def Mfun rel_succ, intro conjI ballI)
    fix n m assume n: "n \<in> nat" and m: "m \<in> nat"
    thus "rel(D, M ` n ` m, M ` n ` succ(m))"
      by (simp add: chain_rel xprem)
  next
    fix n m assume n: "n \<in> nat" and m: "m \<in> nat"
    thus "rel(D, M ` n ` m, M ` succ(n) ` succ(m))"
      by (rule cpo_trans [OF cpoD rel_succ],
          simp_all add: chain_fun [THEN apply_type] xprem)
  qed
qed

lemma lemma2:
     "[|x \<in> nat; m \<in> nat; rel(D,(\<lambda>n \<in> nat. M`n`m1)`x,(\<lambda>n \<in> nat. M`n`m1)`m)|]
      ==> rel(D,M`x`m1,M`m`m1)"
by simp

lemma isub_lemma:
    "[|isub(D, \<lambda>n \<in> nat. M`n`n, y); matrix(D,M); cpo(D)|]
     ==> isub(D, \<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m), y)"
proof (simp add: isub_def, safe)
  fix n
  assume DM: "matrix(D, M)" and D: "cpo(D)" and n: "n \<in> nat" and y: "y \<in> set(D)"
     and rel: "\<forall>n\<in>nat. rel(D, M ` n ` n, y)"
  have "rel(D, lub(D, M ` n), y)"
  proof (rule matrix_chain_left [THEN cpo_lub, THEN islub_least], simp_all add: n D DM)
    show "isub(D, M ` n, y)"
      proof (unfold isub_def, intro conjI ballI y)
        fix k assume k: "k \<in> nat"
        show "rel(D, M ` n ` k, y)"
          proof (cases "n \<le> k")
            case True
            hence yy: "rel(D, M`n`k, M`k`k)"
              by (blast intro: lemma2 n k y DM D chain_rel_gen matrix_chain_right)
            show "?thesis"
              by (rule cpo_trans [OF D yy],
                  simp_all add: k rel n y DM matrix_in)
          next
            case False
            hence le: "k \<le> n"
              by (blast intro: not_le_iff_lt [THEN iffD1, THEN leI] nat_into_Ord n k)
            show "?thesis"
              by (rule cpo_trans [OF D chain_rel_gen [OF le]],
                  simp_all add: n y k rel DM D matrix_chain_left)
          qed
        qed
  qed
  moreover
  have "M ` n \<in> nat \<rightarrow> set(D)" by (blast intro: DM n matrix_fun [THEN apply_type])
  ultimately show "rel(D, lub(D, Lambda(nat, op `(M ` n))), y)"  by simp
qed

lemma matrix_chain_lub:
    "[|matrix(D,M); cpo(D)|] ==> chain(D,\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m))"
proof (simp add: chain_def, intro conjI ballI)
  assume "matrix(D, M)" "cpo(D)"
  thus "(\<lambda>x\<in>nat. lub(D, Lambda(nat, op `(M ` x)))) \<in> nat \<rightarrow> set(D)"
    by (force intro: islub_in cpo_lub chainI lam_type matrix_in matrix_rel_0_1)
next
  fix n
  assume DD: "matrix(D, M)" "cpo(D)" "n \<in> nat"
  hence "dominate(D, M ` n, M ` succ(n))"
    by (force simp add: dominate_def intro: matrix_rel_1_0)
  with DD show "rel(D, lub(D, Lambda(nat, op `(M ` n))),
               lub(D, Lambda(nat, op `(M ` succ(n)))))"
    by (simp add: matrix_chain_left [THEN chain_fun, THEN eta]
      dominate_islub cpo_lub matrix_chain_left chain_fun)
qed

lemma isub_eq:
  assumes DM: "matrix(D, M)" and D: "cpo(D)"
  shows "isub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m)),y) \<longleftrightarrow> isub(D,(\<lambda>n \<in> nat. M`n`n),y)"
proof
  assume isub: "isub(D, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))), y)"
  hence dom: "dominate(D, \<lambda>n\<in>nat. M ` n ` n, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))))"
    using DM D
    by (simp add: dominate_def, intro ballI bexI,
        simp_all add: matrix_chain_left [THEN chain_fun, THEN eta] islub_ub cpo_lub matrix_chain_left)
  thus "isub(D, \<lambda>n\<in>nat. M ` n ` n, y)" using DM D
    by - (rule dominate_isub [OF dom isub],
          simp_all add: matrix_chain_diag chain_fun matrix_chain_lub)
next
  assume isub: "isub(D, \<lambda>n\<in>nat. M ` n ` n, y)"
  thus "isub(D, \<lambda>n\<in>nat. lub(D, Lambda(nat, op `(M ` n))), y)"  using DM D
    by (simp add: isub_lemma)
qed

lemma lub_matrix_diag_aux1:
    "lub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m))) =
     (THE x. islub(D, (\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m)), x))"
by (simp add: lub_def)

lemma lub_matrix_diag_aux2:
    "lub(D,(\<lambda>n \<in> nat. M`n`n)) =
     (THE x. islub(D, (\<lambda>n \<in> nat. M`n`n), x))"
by (simp add: lub_def)

lemma lub_matrix_diag:
    "[|matrix(D,M); cpo(D)|]
     ==> lub(D,(\<lambda>n \<in> nat. lub(D,\<lambda>m \<in> nat. M`n`m))) =
         lub(D,(\<lambda>n \<in> nat. M`n`n))"
apply (simp (no_asm) add: lub_matrix_diag_aux1 lub_matrix_diag_aux2)
apply (simp add: islub_def isub_eq)
done

lemma lub_matrix_diag_sym:
    "[|matrix(D,M); cpo(D)|]
     ==> lub(D,(\<lambda>m \<in> nat. lub(D,\<lambda>n \<in> nat. M`n`m))) =
         lub(D,(\<lambda>n \<in> nat. M`n`n))"
by (drule matrix_sym_axis [THEN lub_matrix_diag], auto)

(*----------------------------------------------------------------------*)
(* I/E/D rules for mono and cont.                                       *)
(*----------------------------------------------------------------------*)

lemma monoI:
    "[|f \<in> set(D)->set(E);
       !!x y. [|rel(D,x,y); x \<in> set(D); y \<in> set(D)|] ==> rel(E,f`x,f`y)|]
     ==> f \<in> mono(D,E)"
by (simp add: mono_def)

lemma mono_fun: "f \<in> mono(D,E) ==> f \<in> set(D)->set(E)"
by (simp add: mono_def)

lemma mono_map: "[|f \<in> mono(D,E); x \<in> set(D)|] ==> f`x \<in> set(E)"
by (blast intro!: mono_fun [THEN apply_type])

lemma mono_mono:
    "[|f \<in> mono(D,E); rel(D,x,y); x \<in> set(D); y \<in> set(D)|] ==> rel(E,f`x,f`y)"
by (simp add: mono_def)

lemma contI:
    "[|f \<in> set(D)->set(E);
       !!x y. [|rel(D,x,y); x \<in> set(D); y \<in> set(D)|] ==> rel(E,f`x,f`y);
       !!X. chain(D,X) ==> f`lub(D,X) = lub(E,\<lambda>n \<in> nat. f`(X`n))|]
     ==> f \<in> cont(D,E)"
by (simp add: cont_def mono_def)

lemma cont2mono: "f \<in> cont(D,E) ==> f \<in> mono(D,E)"
by (simp add: cont_def)

lemma cont_fun [TC]: "f \<in> cont(D,E) ==> f \<in> set(D)->set(E)"
apply (simp add: cont_def)
apply (rule mono_fun, blast)
done

lemma cont_map [TC]: "[|f \<in> cont(D,E); x \<in> set(D)|] ==> f`x \<in> set(E)"
by (blast intro!: cont_fun [THEN apply_type])

declare comp_fun [TC]

lemma cont_mono:
    "[|f \<in> cont(D,E); rel(D,x,y); x \<in> set(D); y \<in> set(D)|] ==> rel(E,f`x,f`y)"
apply (simp add: cont_def)
apply (blast intro!: mono_mono)
done

lemma cont_lub:
   "[|f \<in> cont(D,E); chain(D,X)|] ==> f`(lub(D,X)) = lub(E,\<lambda>n \<in> nat. f`(X`n))"
by (simp add: cont_def)

(*----------------------------------------------------------------------*)
(* Continuity and chains.                                               *)
(*----------------------------------------------------------------------*)

lemma mono_chain:
     "[|f \<in> mono(D,E); chain(D,X)|] ==> chain(E,\<lambda>n \<in> nat. f`(X`n))"
apply (simp (no_asm) add: chain_def)
apply (blast intro: lam_type mono_map chain_in mono_mono chain_rel)
done

lemma cont_chain:
     "[|f \<in> cont(D,E); chain(D,X)|] ==> chain(E,\<lambda>n \<in> nat. f`(X`n))"
by (blast intro: mono_chain cont2mono)

(*----------------------------------------------------------------------*)
(* I/E/D rules about (set+rel) cf, the continuous function space.       *)
(*----------------------------------------------------------------------*)

(* The following development more difficult with cpo-as-relation approach. *)

lemma cf_cont: "f \<in> set(cf(D,E)) ==> f \<in> cont(D,E)"
by (simp add: set_def cf_def)

lemma cont_cf: (* Non-trivial with relation *)
    "f \<in> cont(D,E) ==> f \<in> set(cf(D,E))"
by (simp add: set_def cf_def)

(* rel_cf originally an equality. Now stated as two rules. Seemed easiest. *)

lemma rel_cfI:
    "[|!!x. x \<in> set(D) ==> rel(E,f`x,g`x); f \<in> cont(D,E); g \<in> cont(D,E)|]
     ==> rel(cf(D,E),f,g)"
by (simp add: rel_I cf_def)

lemma rel_cf: "[|rel(cf(D,E),f,g); x \<in> set(D)|] ==> rel(E,f`x,g`x)"
by (simp add: rel_def cf_def)

(*----------------------------------------------------------------------*)
(* Theorems about the continuous function space.                        *)
(*----------------------------------------------------------------------*)

lemma chain_cf:
    "[| chain(cf(D,E),X); x \<in> set(D)|] ==> chain(E,\<lambda>n \<in> nat. X`n`x)"
apply (rule chainI)
apply (blast intro: lam_type apply_funtype cont_fun cf_cont chain_in, simp)
apply (blast intro: rel_cf chain_rel)
done

lemma matrix_lemma:
    "[|chain(cf(D,E),X); chain(D,Xa); cpo(D); cpo(E) |]
     ==> matrix(E,\<lambda>x \<in> nat. \<lambda>xa \<in> nat. X`x`(Xa`xa))"
apply (rule matrix_chainI, auto)
apply (force intro: chainI lam_type apply_funtype cont_fun cf_cont cont_mono)
apply (force intro: chainI lam_type apply_funtype cont_fun cf_cont rel_cf)
apply (blast intro: lam_type apply_funtype cont_fun cf_cont chain_in)
done

lemma chain_cf_lub_cont:
  assumes ch: "chain(cf(D,E),X)" and D: "cpo(D)" and E: "cpo(E)"
  shows   "(\<lambda>x \<in> set(D). lub(E, \<lambda>n \<in> nat. X ` n ` x)) \<in> cont(D, E)"
proof (rule contI)
  show "(\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) \<in> set(D) \<rightarrow> set(E)"
    by (blast intro: lam_type chain_cf [THEN cpo_lub, THEN islub_in] ch E)
next
  fix x y
  assume xy: "rel(D, x, y)" "x \<in> set(D)" "y \<in> set(D)"
  hence dom: "dominate(E, \<lambda>n\<in>nat. X ` n ` x, \<lambda>n\<in>nat. X ` n ` y)"
    by (force intro: dominateI  chain_in [OF ch, THEN cf_cont, THEN cont_mono])
  note chE = chain_cf [OF ch]
  from xy show "rel(E, (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` x,
                       (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` y)"
    by (simp add: dominate_islub [OF dom] cpo_lub [OF chE] E chain_fun [OF chE])
next
  fix Y
  assume chDY: "chain(D,Y)"
  have "lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>y\<in>nat. X ` x ` (Y ` y))) =
        lub(E, \<lambda>x\<in>nat. X ` x ` (Y ` x))"
    using matrix_lemma [THEN lub_matrix_diag, OF ch chDY]
    by (simp add: D E)
   also have "... =  lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` n ` (Y ` x)))"
    using  matrix_lemma [THEN lub_matrix_diag_sym, OF ch chDY]
    by (simp add: D E)
  finally have "lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` x ` (Y ` n))) =
                lub(E, \<lambda>x\<in>nat. lub(E, \<lambda>n\<in>nat. X ` n ` (Y ` x)))" .
  thus "(\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` lub(D, Y) =
        lub(E, \<lambda>n\<in>nat. (\<lambda>x\<in>set(D). lub(E, \<lambda>n\<in>nat. X ` n ` x)) ` (Y ` n))"
    by (simp add: cpo_lub [THEN islub_in]  D chDY
                  chain_in [THEN cf_cont, THEN cont_lub, OF ch])
  qed

lemma islub_cf:
    "[| chain(cf(D,E),X); cpo(D); cpo(E)|]
     ==> islub(cf(D,E), X, \<lambda>x \<in> set(D). lub(E,\<lambda>n \<in> nat. X`n`x))"
apply (rule islubI)
apply (rule isubI)
apply (rule chain_cf_lub_cont [THEN cont_cf], assumption+)
apply (rule rel_cfI)
apply (force dest!: chain_cf [THEN cpo_lub, THEN islub_ub])
apply (blast intro: cf_cont chain_in)
apply (blast intro: cont_cf chain_cf_lub_cont)
apply (rule rel_cfI, simp)
apply (force intro: chain_cf [THEN cpo_lub, THEN islub_least]
                   cf_cont [THEN cont_fun, THEN apply_type] isubI
            elim: isubD2 [THEN rel_cf] isubD1)
apply (blast intro: chain_cf_lub_cont isubD1 cf_cont)+
done

lemma cpo_cf [TC]:
    "[| cpo(D); cpo(E)|] ==> cpo(cf(D,E))"
apply (rule poI [THEN cpoI])
apply (rule rel_cfI)
apply (assumption | rule cpo_refl cf_cont [THEN cont_fun, THEN apply_type]
                         cf_cont)+
apply (rule rel_cfI)
apply (rule cpo_trans, assumption)
apply (erule rel_cf, assumption)
apply (rule rel_cf, assumption)
apply (assumption | rule cf_cont [THEN cont_fun, THEN apply_type] cf_cont)+
apply (rule fun_extension)
apply (assumption | rule cf_cont [THEN cont_fun])+
apply (blast intro: cpo_antisym rel_cf
                    cf_cont [THEN cont_fun, THEN apply_type])
apply (fast intro: islub_cf)
done

lemma lub_cf:
     "[| chain(cf(D,E),X); cpo(D); cpo(E)|]
      ==> lub(cf(D,E), X) = (\<lambda>x \<in> set(D). lub(E,\<lambda>n \<in> nat. X`n`x))"
by (blast intro: islub_unique cpo_lub islub_cf cpo_cf)

lemma const_cont [TC]:
     "[|y \<in> set(E); cpo(D); cpo(E)|] ==> (\<lambda>x \<in> set(D).y) \<in> cont(D,E)"
apply (rule contI)
prefer 2 apply simp
apply (blast intro: lam_type)
apply (simp add: chain_in cpo_lub [THEN islub_in] lub_const)
done

lemma cf_least:
    "[|cpo(D); pcpo(E); y \<in> cont(D,E)|]==>rel(cf(D,E),(\<lambda>x \<in> set(D).bot(E)),y)"
apply (rule rel_cfI, simp, typecheck)
done

lemma pcpo_cf:
    "[|cpo(D); pcpo(E)|] ==> pcpo(cf(D,E))"
apply (rule pcpoI)
apply (assumption |
       rule cf_least bot_in const_cont [THEN cont_cf] cf_cont cpo_cf pcpo_cpo)+
done

lemma bot_cf:
    "[|cpo(D); pcpo(E)|] ==> bot(cf(D,E)) = (\<lambda>x \<in> set(D).bot(E))"
by (blast intro: bot_unique [symmetric] pcpo_cf cf_least
                 bot_in [THEN const_cont, THEN cont_cf] cf_cont pcpo_cpo)

(*----------------------------------------------------------------------*)
(* Identity and composition.                                            *)
(*----------------------------------------------------------------------*)

lemma id_cont [TC,intro!]:
    "cpo(D) ==> id(set(D)) \<in> cont(D,D)"
by (simp add: id_type contI cpo_lub [THEN islub_in] chain_fun [THEN eta])

lemmas comp_cont_apply =  cont_fun [THEN comp_fun_apply]

lemma comp_pres_cont [TC]:
    "[| f \<in> cont(D',E); g \<in> cont(D,D'); cpo(D)|] ==> f O g \<in> cont(D,E)"
apply (rule contI)
apply (rule_tac [2] comp_cont_apply [THEN ssubst])
apply (rule_tac [4] comp_cont_apply [THEN ssubst])
apply (rule_tac [6] cont_mono)
apply (rule_tac [7] cont_mono) (* 13 subgoals *)
apply typecheck (* proves all but the lub case *)
apply (subst comp_cont_apply)
apply (rule_tac [3] cont_lub [THEN ssubst])
apply (rule_tac [5] cont_lub [THEN ssubst])
prefer 7 apply (simp add: comp_cont_apply chain_in)
apply (auto intro: cpo_lub [THEN islub_in] cont_chain)
done

lemma comp_mono:
    "[| f \<in> cont(D',E); g \<in> cont(D,D'); f':cont(D',E); g':cont(D,D');
        rel(cf(D',E),f,f'); rel(cf(D,D'),g,g'); cpo(D); cpo(E) |]
     ==> rel(cf(D,E),f O g,f' O g')"
apply (rule rel_cfI)
apply (subst comp_cont_apply)
apply (rule_tac [3] comp_cont_apply [THEN ssubst])
apply (rule_tac [5] cpo_trans)
apply (assumption | rule rel_cf cont_mono cont_map comp_pres_cont)+
done

lemma chain_cf_comp:
    "[| chain(cf(D',E),X); chain(cf(D,D'),Y); cpo(D); cpo(E)|]
     ==> chain(cf(D,E),\<lambda>n \<in> nat. X`n O Y`n)"
apply (rule chainI)
defer 1
apply simp
apply (rule rel_cfI)
apply (rule comp_cont_apply [THEN ssubst])
apply (rule_tac [3] comp_cont_apply [THEN ssubst])
apply (rule_tac [5] cpo_trans)
apply (rule_tac [6] rel_cf)
apply (rule_tac [8] cont_mono)
apply (blast intro: lam_type comp_pres_cont cont_cf chain_in [THEN cf_cont]
                    cont_map chain_rel rel_cf)+
done

lemma comp_lubs:
    "[| chain(cf(D',E),X); chain(cf(D,D'),Y); cpo(D); cpo(D'); cpo(E)|]
     ==> lub(cf(D',E),X) O lub(cf(D,D'),Y) = lub(cf(D,E),\<lambda>n \<in> nat. X`n O Y`n)"
apply (rule fun_extension)
apply (rule_tac [3] lub_cf [THEN ssubst])
apply (assumption |
       rule comp_fun cf_cont [THEN cont_fun]  cpo_lub [THEN islub_in]
            cpo_cf chain_cf_comp)+
apply (simp add: chain_in [THEN cf_cont, THEN comp_cont_apply])
apply (subst comp_cont_apply)
apply (assumption | rule cpo_lub [THEN islub_in, THEN cf_cont]  cpo_cf)+
apply (simp add: lub_cf chain_cf chain_in [THEN cf_cont, THEN cont_lub]
                 chain_cf [THEN cpo_lub, THEN islub_in])
apply (cut_tac M = "\<lambda>xa \<in> nat. \<lambda>xb \<in> nat. X`xa` (Y`xb`x)" in lub_matrix_diag)
prefer 3 apply simp
apply (rule matrix_chainI, simp_all)
apply (drule chain_in [THEN cf_cont], assumption)
apply (force dest: cont_chain [OF _ chain_cf])
apply (rule chain_cf)
apply (assumption |
       rule cont_fun [THEN apply_type] chain_in [THEN cf_cont] lam_type)+
done

(*----------------------------------------------------------------------*)
(* Theorems about projpair.                                             *)
(*----------------------------------------------------------------------*)

lemma projpairI:
    "[| e \<in> cont(D,E); p \<in> cont(E,D); p O e = id(set(D));
        rel(cf(E,E))(e O p)(id(set(E)))|] ==> projpair(D,E,e,p)"
by (simp add: projpair_def)

lemma projpair_e_cont: "projpair(D,E,e,p) ==> e \<in> cont(D,E)"
by (simp add: projpair_def)

lemma projpair_p_cont: "projpair(D,E,e,p) ==> p \<in> cont(E,D)"
by (simp add: projpair_def)

lemma projpair_ep_cont: "projpair(D,E,e,p) ==> e \<in> cont(D,E) & p \<in> cont(E,D)"
by (simp add: projpair_def)

lemma projpair_eq: "projpair(D,E,e,p) ==> p O e = id(set(D))"
by (simp add: projpair_def)

lemma projpair_rel: "projpair(D,E,e,p) ==> rel(cf(E,E))(e O p)(id(set(E)))"
by (simp add: projpair_def)

(*----------------------------------------------------------------------*)
(* NB! projpair_e_cont and projpair_p_cont cannot be used repeatedly    *)
(*   at the same time since both match a goal of the form f \<in> cont(X,Y).*)
(*----------------------------------------------------------------------*)

(*----------------------------------------------------------------------*)
(* Uniqueness of embedding projection pairs.                            *)
(*----------------------------------------------------------------------*)

lemmas id_comp = fun_is_rel [THEN left_comp_id]
and    comp_id = fun_is_rel [THEN right_comp_id]

lemma projpair_unique_aux1:
    "[|cpo(D); cpo(E); projpair(D,E,e,p); projpair(D,E,e',p');
       rel(cf(D,E),e,e')|] ==> rel(cf(E,D),p',p)"
apply (rule_tac b=p' in
       projpair_p_cont [THEN cont_fun, THEN id_comp, THEN subst], assumption)
apply (rule projpair_eq [THEN subst], assumption)
apply (rule cpo_trans)
apply (assumption | rule cpo_cf)+
(* The following corresponds to EXISTS_TAC, non-trivial instantiation. *)
apply (rule_tac [4] f = "p O (e' O p')" in cont_cf)
apply (subst comp_assoc)
apply (blast intro:  cpo_cf cont_cf comp_mono comp_pres_cont
             dest: projpair_ep_cont)
apply (rule_tac P = "%x. rel (cf (E,D),p O e' O p',x)"
         in projpair_p_cont [THEN cont_fun, THEN comp_id, THEN subst],
       assumption)
apply (rule comp_mono)
apply (blast intro: cpo_cf cont_cf comp_pres_cont projpair_rel
             dest: projpair_ep_cont)+
done

text\<open>Proof's very like the previous one.  Is there a pattern that
      could be exploited?\<close>
lemma projpair_unique_aux2:
    "[|cpo(D); cpo(E); projpair(D,E,e,p); projpair(D,E,e',p');
       rel(cf(E,D),p',p)|] ==> rel(cf(D,E),e,e')"
apply (rule_tac b=e
         in projpair_e_cont [THEN cont_fun, THEN comp_id, THEN subst],
       assumption)
apply (rule_tac e1=e' in projpair_eq [THEN subst], assumption)
apply (rule cpo_trans)
apply (assumption | rule cpo_cf)+
apply (rule_tac [4] f = "(e O p) O e'" in cont_cf)
apply (subst comp_assoc)
apply (blast intro:  cpo_cf cont_cf comp_mono comp_pres_cont
             dest: projpair_ep_cont)
apply (rule_tac P = "%x. rel (cf (D,E), (e O p) O e',x)"
         in projpair_e_cont [THEN cont_fun, THEN id_comp, THEN subst],
       assumption)
apply (blast intro: cpo_cf cont_cf comp_pres_cont projpair_rel comp_mono
             dest: projpair_ep_cont)+
done

lemma projpair_unique:
    "[|cpo(D); cpo(E); projpair(D,E,e,p); projpair(D,E,e',p')|]
     ==> (e=e')\<longleftrightarrow>(p=p')"
by (blast intro: cpo_antisym projpair_unique_aux1 projpair_unique_aux2 cpo_cf cont_cf
          dest: projpair_ep_cont)

(* Slightly different, more asms, since THE chooses the unique element. *)

lemma embRp:
    "[|emb(D,E,e); cpo(D); cpo(E)|] ==> projpair(D,E,e,Rp(D,E,e))"
apply (simp add: emb_def Rp_def)
apply (blast intro: theI2 projpair_unique [THEN iffD1])
done

lemma embI: "projpair(D,E,e,p) ==> emb(D,E,e)"
by (simp add: emb_def, auto)

lemma Rp_unique: "[|projpair(D,E,e,p); cpo(D); cpo(E)|] ==> Rp(D,E,e) = p"
by (blast intro: embRp embI projpair_unique [THEN iffD1])

lemma emb_cont [TC]: "emb(D,E,e) ==> e \<in> cont(D,E)"
apply (simp add: emb_def)
apply (blast intro: projpair_e_cont)
done

(* The following three theorems have cpo asms due to THE (uniqueness). *)

lemmas Rp_cont [TC] = embRp [THEN projpair_p_cont]
lemmas embRp_eq = embRp [THEN projpair_eq]
lemmas embRp_rel = embRp [THEN projpair_rel]

lemma embRp_eq_thm:
    "[|emb(D,E,e); x \<in> set(D); cpo(D); cpo(E)|] ==> Rp(D,E,e)`(e`x) = x"
apply (rule comp_fun_apply [THEN subst])
apply (assumption | rule Rp_cont emb_cont cont_fun)+
apply (subst embRp_eq)
apply (auto intro: id_conv)
done

(*----------------------------------------------------------------------*)
(* The identity embedding.                                              *)
(*----------------------------------------------------------------------*)

lemma projpair_id:
    "cpo(D) ==> projpair(D,D,id(set(D)),id(set(D)))"
apply (simp add: projpair_def)
apply (blast intro: cpo_cf cont_cf)
done

lemma emb_id:
    "cpo(D) ==> emb(D,D,id(set(D)))"
by (auto intro: embI projpair_id)

lemma Rp_id:
    "cpo(D) ==> Rp(D,D,id(set(D))) = id(set(D))"
by (auto intro: Rp_unique projpair_id)

(*----------------------------------------------------------------------*)
(* Composition preserves embeddings.                                    *)
(*----------------------------------------------------------------------*)

(* Considerably shorter, only partly due to a simpler comp_assoc. *)
(* Proof in HOL-ST: 70 lines (minus 14 due to comp_assoc complication). *)
(* Proof in Isa/ZF: 23 lines (compared to 56: 60% reduction). *)

lemma comp_lemma:
    "[|emb(D,D',e); emb(D',E,e'); cpo(D); cpo(D'); cpo(E)|]
     ==> projpair(D,E,e' O e,(Rp(D,D',e)) O (Rp(D',E,e')))"
apply (simp add: projpair_def, safe)
apply (assumption | rule comp_pres_cont Rp_cont emb_cont)+
apply (rule comp_assoc [THEN subst])
apply (rule_tac t1 = e' in comp_assoc [THEN ssubst])
apply (subst embRp_eq) (* Matches everything due to subst/ssubst. *)
apply assumption+
apply (subst comp_id)
apply (assumption | rule cont_fun Rp_cont embRp_eq)+
apply (rule comp_assoc [THEN subst])
apply (rule_tac t1 = "Rp (D,D',e)" in comp_assoc [THEN ssubst])
apply (rule cpo_trans)
apply (assumption | rule cpo_cf)+
apply (rule comp_mono)
apply (rule_tac [6] cpo_refl)
apply (erule_tac [7] asm_rl | rule_tac [7] cont_cf Rp_cont)+
prefer 6 apply (blast intro: cpo_cf)
apply (rule_tac [5] comp_mono)
apply (rule_tac [10] embRp_rel)
apply (rule_tac [9] cpo_cf [THEN cpo_refl])
apply (simp_all add: comp_id embRp_rel comp_pres_cont Rp_cont
                     id_cont emb_cont cont_fun cont_cf)
done

(* The use of THEN is great in places like the following, both ugly in HOL. *)

lemmas emb_comp = comp_lemma [THEN embI]
lemmas Rp_comp = comp_lemma [THEN Rp_unique]

(*----------------------------------------------------------------------*)
(* Infinite cartesian product.                                          *)
(*----------------------------------------------------------------------*)

lemma iprodI:
    "x:(\<Prod>n \<in> nat. set(DD`n)) ==> x \<in> set(iprod(DD))"
by (simp add: set_def iprod_def)

lemma iprodE:
    "x \<in> set(iprod(DD)) ==> x:(\<Prod>n \<in> nat. set(DD`n))"
by (simp add: set_def iprod_def)

(* Contains typing conditions in contrast to HOL-ST *)

lemma rel_iprodI:
    "[|!!n. n \<in> nat ==> rel(DD`n,f`n,g`n); f:(\<Prod>n \<in> nat. set(DD`n));
       g:(\<Prod>n \<in> nat. set(DD`n))|] ==> rel(iprod(DD),f,g)"
by (simp add: iprod_def rel_I)

lemma rel_iprodE:
    "[|rel(iprod(DD),f,g); n \<in> nat|] ==> rel(DD`n,f`n,g`n)"
by (simp add: iprod_def rel_def)

lemma chain_iprod:
    "[|chain(iprod(DD),X);  !!n. n \<in> nat ==> cpo(DD`n); n \<in> nat|]
     ==> chain(DD`n,\<lambda>m \<in> nat. X`m`n)"
apply (unfold chain_def, safe)
apply (rule lam_type)
apply (rule apply_type)
apply (rule iprodE)
apply (blast intro: apply_funtype, assumption)
apply (simp add: rel_iprodE)
done

lemma islub_iprod:
    "[|chain(iprod(DD),X);  !!n. n \<in> nat ==> cpo(DD`n)|]
     ==> islub(iprod(DD),X,\<lambda>n \<in> nat. lub(DD`n,\<lambda>m \<in> nat. X`m`n))"
apply (simp add: islub_def isub_def, safe)
apply (rule iprodI)
apply (blast intro: lam_type chain_iprod [THEN cpo_lub, THEN islub_in])
apply (rule rel_iprodI, simp)
(*looks like something should be inserted into the assumptions!*)
apply (rule_tac P = "%t. rel (DD`na,t,lub (DD`na,\<lambda>x \<in> nat. X`x`na))"
            and b1 = "%n. X`n`na" in beta [THEN subst])
apply (simp del: beta_if
            add: chain_iprod [THEN cpo_lub, THEN islub_ub] iprodE
                chain_in)+
apply (blast intro: iprodI lam_type chain_iprod [THEN cpo_lub, THEN islub_in])
apply (rule rel_iprodI)
apply (simp | rule islub_least chain_iprod [THEN cpo_lub])+
apply (simp add: isub_def, safe)
apply (erule iprodE [THEN apply_type])
apply (simp_all add: rel_iprodE lam_type iprodE
                     chain_iprod [THEN cpo_lub, THEN islub_in])
done

lemma cpo_iprod [TC]:
    "(!!n. n \<in> nat ==> cpo(DD`n)) ==> cpo(iprod(DD))"
apply (assumption | rule cpoI poI)+
apply (rule rel_iprodI) (*not repeated: want to solve 1, leave 2 unchanged *)
apply (simp | rule cpo_refl iprodE [THEN apply_type] iprodE)+
apply (rule rel_iprodI)
apply (drule rel_iprodE)
apply (drule_tac [2] rel_iprodE)
apply (simp | rule cpo_trans iprodE [THEN apply_type] iprodE)+
apply (rule fun_extension)
apply (blast intro: iprodE)
apply (blast intro: iprodE)
apply (blast intro: cpo_antisym rel_iprodE iprodE [THEN apply_type])+
apply (auto intro: islub_iprod)
done

lemma lub_iprod:
    "[|chain(iprod(DD),X);  !!n. n \<in> nat ==> cpo(DD`n)|]
     ==> lub(iprod(DD),X) = (\<lambda>n \<in> nat. lub(DD`n,\<lambda>m \<in> nat. X`m`n))"
by (blast intro: cpo_lub [THEN islub_unique] islub_iprod cpo_iprod)

(*----------------------------------------------------------------------*)
(* The notion of subcpo.                                                *)
(*----------------------------------------------------------------------*)

lemma subcpoI:
    "[|set(D)<=set(E);
       !!x y. [|x \<in> set(D); y \<in> set(D)|] ==> rel(D,x,y)\<longleftrightarrow>rel(E,x,y);
       !!X. chain(D,X) ==> lub(E,X) \<in> set(D)|] ==> subcpo(D,E)"
by (simp add: subcpo_def)

lemma subcpo_subset: "subcpo(D,E) ==> set(D)<=set(E)"
by (simp add: subcpo_def)

lemma subcpo_rel_eq:
    "[|subcpo(D,E); x \<in> set(D); y \<in> set(D)|] ==> rel(D,x,y)\<longleftrightarrow>rel(E,x,y)"
by (simp add: subcpo_def)

lemmas subcpo_relD1 = subcpo_rel_eq [THEN iffD1]
lemmas subcpo_relD2 = subcpo_rel_eq [THEN iffD2]

lemma subcpo_lub: "[|subcpo(D,E); chain(D,X)|] ==> lub(E,X) \<in> set(D)"
by (simp add: subcpo_def)

lemma chain_subcpo: "[|subcpo(D,E); chain(D,X)|] ==> chain(E,X)"
by (blast intro: Pi_type [THEN chainI] chain_fun subcpo_relD1
                    subcpo_subset [THEN subsetD]
                    chain_in chain_rel)

lemma ub_subcpo: "[|subcpo(D,E); chain(D,X); isub(D,X,x)|] ==> isub(E,X,x)"
by (blast intro: isubI subcpo_relD1 subcpo_relD1 chain_in isubD1 isubD2
                    subcpo_subset [THEN subsetD] chain_in chain_rel)

lemma islub_subcpo:
     "[|subcpo(D,E); cpo(E); chain(D,X)|] ==> islub(D,X,lub(E,X))"
by (blast intro: islubI isubI subcpo_lub subcpo_relD2 chain_in islub_ub
                 islub_least cpo_lub chain_subcpo isubD1 ub_subcpo)

lemma subcpo_cpo: "[|subcpo(D,E); cpo(E)|] ==> cpo(D)"
apply (assumption | rule cpoI poI)+
apply (simp add: subcpo_rel_eq)
apply (assumption | rule cpo_refl subcpo_subset [THEN subsetD])+
apply (simp add: subcpo_rel_eq)
apply (blast intro: subcpo_subset [THEN subsetD] cpo_trans)
apply (simp add: subcpo_rel_eq)
apply (blast intro: cpo_antisym subcpo_subset [THEN subsetD])
apply (fast intro: islub_subcpo)
done

lemma lub_subcpo: "[|subcpo(D,E); cpo(E); chain(D,X)|] ==> lub(D,X) = lub(E,X)"
by (blast intro: cpo_lub [THEN islub_unique] islub_subcpo subcpo_cpo)

(*----------------------------------------------------------------------*)
(* Making subcpos using mkcpo.                                          *)
(*----------------------------------------------------------------------*)

lemma mkcpoI: "[|x \<in> set(D); P(x)|] ==> x \<in> set(mkcpo(D,P))"
by (simp add: set_def mkcpo_def)

lemma mkcpoD1: "x \<in> set(mkcpo(D,P))==> x \<in> set(D)"
by (simp add: set_def mkcpo_def)

lemma mkcpoD2: "x \<in> set(mkcpo(D,P))==> P(x)"
by (simp add: set_def mkcpo_def)

lemma rel_mkcpoE: "rel(mkcpo(D,P),x,y) ==> rel(D,x,y)"
by (simp add: rel_def mkcpo_def)

lemma rel_mkcpo:
    "[|x \<in> set(D); y \<in> set(D)|] ==> rel(mkcpo(D,P),x,y) \<longleftrightarrow> rel(D,x,y)"
by (simp add: mkcpo_def rel_def set_def)

lemma chain_mkcpo:
    "chain(mkcpo(D,P),X) ==> chain(D,X)"
apply (rule chainI)
apply (blast intro: Pi_type chain_fun chain_in [THEN mkcpoD1])
apply (blast intro: rel_mkcpo [THEN iffD1] chain_rel mkcpoD1 chain_in)
done

lemma subcpo_mkcpo:
     "[|!!X. chain(mkcpo(D,P),X) ==> P(lub(D,X)); cpo(D)|]
      ==> subcpo(mkcpo(D,P),D)"
apply (intro subcpoI subsetI rel_mkcpo)
apply (erule mkcpoD1)+
apply (blast intro: mkcpoI cpo_lub [THEN islub_in] chain_mkcpo)
done

(*----------------------------------------------------------------------*)
(* Embedding projection chains of cpos.                                 *)
(*----------------------------------------------------------------------*)

lemma emb_chainI:
    "[|!!n. n \<in> nat ==> cpo(DD`n);
       !!n. n \<in> nat ==> emb(DD`n,DD`succ(n),ee`n)|] ==> emb_chain(DD,ee)"
by (simp add: emb_chain_def)

lemma emb_chain_cpo [TC]: "[|emb_chain(DD,ee); n \<in> nat|] ==> cpo(DD`n)"
by (simp add: emb_chain_def)

lemma emb_chain_emb:
    "[|emb_chain(DD,ee); n \<in> nat|] ==> emb(DD`n,DD`succ(n),ee`n)"
by (simp add: emb_chain_def)

(*----------------------------------------------------------------------*)
(* Dinf, the inverse Limit.                                             *)
(*----------------------------------------------------------------------*)

lemma DinfI:
    "[|x:(\<Prod>n \<in> nat. set(DD`n));
       !!n. n \<in> nat ==> Rp(DD`n,DD`succ(n),ee`n)`(x`succ(n)) = x`n|]
     ==> x \<in> set(Dinf(DD,ee))"
apply (simp add: Dinf_def)
apply (blast intro: mkcpoI iprodI)
done

lemma Dinf_prod: "x \<in> set(Dinf(DD,ee)) ==> x:(\<Prod>n \<in> nat. set(DD`n))"
apply (simp add: Dinf_def)
apply (erule mkcpoD1 [THEN iprodE])
done

lemma Dinf_eq:
    "[|x \<in> set(Dinf(DD,ee)); n \<in> nat|]
     ==> Rp(DD`n,DD`succ(n),ee`n)`(x`succ(n)) = x`n"
apply (simp add: Dinf_def)
apply (blast dest: mkcpoD2)
done

lemma rel_DinfI:
    "[|!!n. n \<in> nat ==> rel(DD`n,x`n,y`n);
       x:(\<Prod>n \<in> nat. set(DD`n)); y:(\<Prod>n \<in> nat. set(DD`n))|]
     ==> rel(Dinf(DD,ee),x,y)"
apply (simp add: Dinf_def)
apply (blast intro: rel_mkcpo [THEN iffD2] rel_iprodI iprodI)
done

lemma rel_Dinf: "[|rel(Dinf(DD,ee),x,y); n \<in> nat|] ==> rel(DD`n,x`n,y`n)"
apply (simp add: Dinf_def)
apply (erule rel_mkcpoE [THEN rel_iprodE], assumption)
done

lemma chain_Dinf: "chain(Dinf(DD,ee),X) ==> chain(iprod(DD),X)"
apply (simp add: Dinf_def)
apply (erule chain_mkcpo)
done

lemma subcpo_Dinf: "emb_chain(DD,ee) ==> subcpo(Dinf(DD,ee),iprod(DD))"
apply (simp add: Dinf_def)
apply (rule subcpo_mkcpo)
apply (simp add: Dinf_def [symmetric])
apply (rule ballI)
apply (simplesubst lub_iprod)
  \<comment>\<open>Subst would rewrite the lhs. We want to change the rhs.\<close>
apply (assumption | rule chain_Dinf emb_chain_cpo)+
apply simp
apply (subst Rp_cont [THEN cont_lub])
apply (assumption |
       rule emb_chain_cpo emb_chain_emb nat_succI chain_iprod chain_Dinf)+
(* Useful simplification, ugly in HOL. *)
apply (simp add: Dinf_eq chain_in)
apply (auto intro: cpo_iprod emb_chain_cpo)
done

(* Simple example of existential reasoning in Isabelle versus HOL. *)

lemma cpo_Dinf: "emb_chain(DD,ee) ==> cpo(Dinf(DD,ee))"
apply (rule subcpo_cpo)
apply (erule subcpo_Dinf)
apply (auto intro: cpo_iprod emb_chain_cpo)
done

(* Again and again the proofs are much easier to WRITE in Isabelle, but
  the proof steps are essentially the same (I think). *)

lemma lub_Dinf:
    "[|chain(Dinf(DD,ee),X); emb_chain(DD,ee)|]
     ==> lub(Dinf(DD,ee),X) = (\<lambda>n \<in> nat. lub(DD`n,\<lambda>m \<in> nat. X`m`n))"
apply (subst subcpo_Dinf [THEN lub_subcpo])
apply (auto intro: cpo_iprod emb_chain_cpo lub_iprod chain_Dinf)
done

(*----------------------------------------------------------------------*)
(* Generalising embedddings D_m -> D_{m+1} to embeddings D_m -> D_n,    *)
(* defined as eps(DD,ee,m,n), via e_less and e_gr.                      *)
(*----------------------------------------------------------------------*)

lemma e_less_eq:
    "m \<in> nat ==> e_less(DD,ee,m,m) = id(set(DD`m))"
by (simp add: e_less_def)

lemma lemma_succ_sub: "succ(m#+n)#-m = succ(natify(n))"
by simp

lemma e_less_add:
     "e_less(DD,ee,m,succ(m#+k)) = (ee`(m#+k))O(e_less(DD,ee,m,m#+k))"
by (simp add: e_less_def)

lemma le_exists:
    "[| m \<le> n;  !!x. [|n=m#+x; x \<in> nat|] ==> Q;  n \<in> nat |] ==> Q"
apply (drule less_imp_succ_add, auto)
done

lemma e_less_le: "[| m \<le> n;  n \<in> nat |]
     ==> e_less(DD,ee,m,succ(n)) = ee`n O e_less(DD,ee,m,n)"
apply (rule le_exists, assumption)
apply (simp add: e_less_add, assumption)
done

(* All theorems assume variables m and n are natural numbers. *)

lemma e_less_succ:
     "m \<in> nat ==> e_less(DD,ee,m,succ(m)) = ee`m O id(set(DD`m))"
by (simp add: e_less_le e_less_eq)

lemma e_less_succ_emb:
    "[|!!n. n \<in> nat ==> emb(DD`n,DD`succ(n),ee`n); m \<in> nat|]
     ==> e_less(DD,ee,m,succ(m)) = ee`m"
apply (simp add: e_less_succ)
apply (blast intro: emb_cont cont_fun comp_id)
done

(* Compare this proof with the HOL one, here we do type checking. *)
(* In any case the one below was very easy to write. *)

lemma emb_e_less_add:
     "[| emb_chain(DD,ee); m \<in> nat |]
      ==> emb(DD`m, DD`(m#+k), e_less(DD,ee,m,m#+k))"
apply (subgoal_tac "emb (DD`m, DD` (m#+natify (k)),
                         e_less (DD,ee,m,m#+natify (k))) ")
apply (rule_tac [2] n = "natify (k) " in nat_induct)
apply (simp_all add: e_less_eq)
apply (assumption | rule emb_id emb_chain_cpo)+
apply (simp add: e_less_add)
apply (auto intro: emb_comp emb_chain_emb emb_chain_cpo)
done

lemma emb_e_less:
     "[| m \<le> n;  emb_chain(DD,ee);  n \<in> nat |]
      ==> emb(DD`m, DD`n, e_less(DD,ee,m,n))"
apply (frule lt_nat_in_nat)
apply (erule nat_succI)
(* same proof as e_less_le *)
apply (rule le_exists, assumption)
apply (simp add: emb_e_less_add, assumption)
done

lemma comp_mono_eq: "[|f=f'; g=g'|] ==> f O g = f' O g'"
by simp

(* Note the object-level implication for induction on k. This
   must be removed later to allow the theorems to be used for simp.
   Therefore this theorem is only a lemma. *)

lemma e_less_split_add_lemma [rule_format]:
    "[| emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> n \<le> k \<longrightarrow>
         e_less(DD,ee,m,m#+k) = e_less(DD,ee,m#+n,m#+k) O e_less(DD,ee,m,m#+n)"
apply (induct_tac k)
apply (simp add: e_less_eq id_type [THEN id_comp])
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (erule impE, assumption)
apply (simp add: e_less_add)
apply (subst e_less_le)
apply (assumption | rule add_le_mono nat_le_refl add_type nat_succI)+
apply (subst comp_assoc)
apply (assumption | rule comp_mono_eq refl)+
apply (simp del: add_succ_right add: add_succ_right [symmetric]
            add: e_less_eq add_type nat_succI)
apply (subst id_comp) (* simp cannot unify/inst right, use brr below (?) . *)
apply (assumption |
       rule emb_e_less_add [THEN emb_cont, THEN cont_fun] refl nat_succI)+
done

lemma e_less_split_add:
    "[| n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> e_less(DD,ee,m,m#+k) = e_less(DD,ee,m#+n,m#+k) O e_less(DD,ee,m,m#+n)"
by (blast intro: e_less_split_add_lemma)

lemma e_gr_eq:
    "m \<in> nat ==> e_gr(DD,ee,m,m) = id(set(DD`m))"
by (simp add: e_gr_def)

lemma e_gr_add:
    "[|n \<in> nat; k \<in> nat|]
     ==> e_gr(DD,ee,succ(n#+k),n) =
         e_gr(DD,ee,n#+k,n) O Rp(DD`(n#+k),DD`succ(n#+k),ee`(n#+k))"
by (simp add: e_gr_def)

lemma e_gr_le:
     "[|n \<le> m; m \<in> nat; n \<in> nat|]
      ==> e_gr(DD,ee,succ(m),n) = e_gr(DD,ee,m,n) O Rp(DD`m,DD`succ(m),ee`m)"
apply (erule le_exists)
apply (simp add: e_gr_add, assumption+)
done

lemma e_gr_succ:
 "m \<in> nat ==> e_gr(DD,ee,succ(m),m) = id(set(DD`m)) O Rp(DD`m,DD`succ(m),ee`m)"
by (simp add: e_gr_le e_gr_eq)

(* Cpo asm's due to THE uniqueness. *)
lemma e_gr_succ_emb: "[|emb_chain(DD,ee); m \<in> nat|]
     ==> e_gr(DD,ee,succ(m),m) = Rp(DD`m,DD`succ(m),ee`m)"
apply (simp add: e_gr_succ)
apply (blast intro: id_comp Rp_cont cont_fun emb_chain_cpo emb_chain_emb)
done

lemma e_gr_fun_add:
    "[|emb_chain(DD,ee); n \<in> nat; k \<in> nat|]
     ==> e_gr(DD,ee,n#+k,n): set(DD`(n#+k))->set(DD`n)"
apply (induct_tac k)
apply (simp add: e_gr_eq id_type)
apply (simp add: e_gr_add)
apply (blast intro: comp_fun Rp_cont cont_fun emb_chain_emb emb_chain_cpo)
done

lemma e_gr_fun:
    "[|n \<le> m; emb_chain(DD,ee); m \<in> nat; n \<in> nat|]
     ==> e_gr(DD,ee,m,n): set(DD`m)->set(DD`n)"
apply (rule le_exists, assumption)
apply (simp add: e_gr_fun_add, assumption+)
done

lemma e_gr_split_add_lemma:
    "[| emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> m \<le> k \<longrightarrow>
         e_gr(DD,ee,n#+k,n) = e_gr(DD,ee,n#+m,n) O e_gr(DD,ee,n#+k,n#+m)"
apply (induct_tac k)
apply (rule impI)
apply (simp add: le0_iff e_gr_eq id_type [THEN comp_id])
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (erule impE, assumption)
apply (simp add: e_gr_add)
apply (subst e_gr_le)
apply (assumption | rule add_le_mono nat_le_refl add_type nat_succI)+
apply (subst comp_assoc)
apply (assumption | rule comp_mono_eq refl)+
(* New direct subgoal *)
apply (simp del: add_succ_right add: add_succ_right [symmetric]
            add: e_gr_eq)
apply (subst comp_id) (* simp cannot unify/inst right, use brr below (?) . *)
apply (assumption | rule e_gr_fun add_type refl add_le_self nat_succI)+
done

lemma e_gr_split_add:
     "[| m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
      ==> e_gr(DD,ee,n#+k,n) = e_gr(DD,ee,n#+m,n) O e_gr(DD,ee,n#+k,n#+m)"
apply (blast intro: e_gr_split_add_lemma [THEN mp])
done

lemma e_less_cont:
     "[|m \<le> n; emb_chain(DD,ee); m \<in> nat; n \<in> nat|]
      ==> e_less(DD,ee,m,n):cont(DD`m,DD`n)"
apply (blast intro: emb_cont emb_e_less)
done

lemma e_gr_cont:
    "[|n \<le> m; emb_chain(DD,ee); m \<in> nat; n \<in> nat|]
     ==> e_gr(DD,ee,m,n):cont(DD`m,DD`n)"
apply (erule rev_mp)
apply (induct_tac m)
apply (simp add: le0_iff e_gr_eq nat_0I)
apply (assumption | rule impI id_cont emb_chain_cpo nat_0I)+
apply (simp add: le_succ_iff)
apply (erule disjE)
apply (erule impE, assumption)
apply (simp add: e_gr_le)
apply (blast intro: comp_pres_cont Rp_cont emb_chain_cpo emb_chain_emb)
apply (simp add: e_gr_eq)
done

(* Considerably shorter.... 57 against 26 *)

lemma e_less_e_gr_split_add:
    "[|n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> e_less(DD,ee,m,m#+n) = e_gr(DD,ee,m#+k,m#+n) O e_less(DD,ee,m,m#+k)"
(* Use mp to prepare for induction. *)
apply (erule rev_mp)
apply (induct_tac k)
apply (simp add: e_gr_eq e_less_eq id_type [THEN id_comp])
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (erule impE, assumption)
apply (simp add: e_gr_le e_less_le add_le_mono)
apply (subst comp_assoc)
apply (rule_tac s1 = "ee` (m#+x)" in comp_assoc [THEN subst])
apply (subst embRp_eq)
apply (assumption | rule emb_chain_emb add_type emb_chain_cpo nat_succI)+
apply (subst id_comp)
apply (blast intro: e_less_cont [THEN cont_fun] add_le_self)
apply (rule refl)
apply (simp del: add_succ_right add: add_succ_right [symmetric]
            add: e_gr_eq)
apply (blast intro: id_comp [symmetric] e_less_cont [THEN cont_fun]
                    add_le_self)
done

(* Again considerably shorter, and easy to obtain from the previous thm. *)

lemma e_gr_e_less_split_add:
    "[|m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> e_gr(DD,ee,n#+m,n) = e_gr(DD,ee,n#+k,n) O e_less(DD,ee,n#+m,n#+k)"
(* Use mp to prepare for induction. *)
apply (erule rev_mp)
apply (induct_tac k)
apply (simp add: e_gr_eq e_less_eq id_type [THEN id_comp])
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (erule impE, assumption)
apply (simp add: e_gr_le e_less_le add_le_self nat_le_refl add_le_mono)
apply (subst comp_assoc)
apply (rule_tac s1 = "ee` (n#+x)" in comp_assoc [THEN subst])
apply (subst embRp_eq)
apply (assumption | rule emb_chain_emb add_type emb_chain_cpo nat_succI)+
apply (subst id_comp)
apply (blast intro!: e_less_cont [THEN cont_fun] add_le_mono nat_le_refl)
apply (rule refl)
apply (simp del: add_succ_right add: add_succ_right [symmetric]
            add: e_less_eq)
apply (blast intro: comp_id [symmetric] e_gr_cont [THEN cont_fun] add_le_self)
done

lemma emb_eps:
    "[|m \<le> n; emb_chain(DD,ee); m \<in> nat; n \<in> nat|]
     ==> emb(DD`m,DD`n,eps(DD,ee,m,n))"
apply (simp add: eps_def)
apply (blast intro: emb_e_less)
done

lemma eps_fun:
    "[|emb_chain(DD,ee); m \<in> nat; n \<in> nat|]
     ==> eps(DD,ee,m,n): set(DD`m)->set(DD`n)"
apply (simp add: eps_def)
apply (auto intro: e_less_cont [THEN cont_fun]
                   not_le_iff_lt [THEN iffD1, THEN leI]
                   e_gr_fun nat_into_Ord)
done

lemma eps_id: "n \<in> nat ==> eps(DD,ee,n,n) = id(set(DD`n))"
by (simp add: eps_def e_less_eq)

lemma eps_e_less_add:
    "[|m \<in> nat; n \<in> nat|] ==> eps(DD,ee,m,m#+n) = e_less(DD,ee,m,m#+n)"
by (simp add: eps_def add_le_self)

lemma eps_e_less:
    "[|m \<le> n; m \<in> nat; n \<in> nat|] ==> eps(DD,ee,m,n) = e_less(DD,ee,m,n)"
by (simp add: eps_def)

lemma eps_e_gr_add:
    "[|n \<in> nat; k \<in> nat|] ==> eps(DD,ee,n#+k,n) = e_gr(DD,ee,n#+k,n)"
by (simp add: eps_def e_less_eq e_gr_eq)

lemma eps_e_gr:
    "[|n \<le> m; m \<in> nat; n \<in> nat|] ==> eps(DD,ee,m,n) = e_gr(DD,ee,m,n)"
apply (erule le_exists)
apply (simp_all add: eps_e_gr_add)
done

lemma eps_succ_ee:
    "[|!!n. n \<in> nat ==> emb(DD`n,DD`succ(n),ee`n); m \<in> nat|]
     ==> eps(DD,ee,m,succ(m)) = ee`m"
by (simp add: eps_e_less le_succ_iff e_less_succ_emb)

lemma eps_succ_Rp:
    "[|emb_chain(DD,ee); m \<in> nat|]
     ==> eps(DD,ee,succ(m),m) = Rp(DD`m,DD`succ(m),ee`m)"
by (simp add: eps_e_gr le_succ_iff e_gr_succ_emb)

lemma eps_cont:
  "[|emb_chain(DD,ee); m \<in> nat; n \<in> nat|] ==> eps(DD,ee,m,n): cont(DD`m,DD`n)"
apply (rule_tac i = m and j = n in nat_linear_le)
apply (simp_all add: eps_e_less e_less_cont eps_e_gr e_gr_cont)
done

(* Theorems about splitting. *)

lemma eps_split_add_left:
    "[|n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,m#+k) = eps(DD,ee,m#+n,m#+k) O eps(DD,ee,m,m#+n)"
apply (simp add: eps_e_less add_le_self add_le_mono)
apply (auto intro: e_less_split_add)
done

lemma eps_split_add_left_rev:
    "[|n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,m#+n) = eps(DD,ee,m#+k,m#+n) O eps(DD,ee,m,m#+k)"
apply (simp add: eps_e_less_add eps_e_gr add_le_self add_le_mono)
apply (auto intro: e_less_e_gr_split_add)
done

lemma eps_split_add_right:
    "[|m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,n#+k,n) = eps(DD,ee,n#+m,n) O eps(DD,ee,n#+k,n#+m)"
apply (simp add: eps_e_gr add_le_self add_le_mono)
apply (auto intro: e_gr_split_add)
done

lemma eps_split_add_right_rev:
    "[|m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,n#+m,n) = eps(DD,ee,n#+k,n) O eps(DD,ee,n#+m,n#+k)"
apply (simp add: eps_e_gr_add eps_e_less add_le_self add_le_mono)
apply (auto intro: e_gr_e_less_split_add)
done

(* Arithmetic *)

lemma le_exists_lemma:
    "[| n \<le> k; k \<le> m;
        !!p q. [|p \<le> q; k=n#+p; m=n#+q; p \<in> nat; q \<in> nat|] ==> R;
        m \<in> nat |]==>R"
apply (rule le_exists, assumption)
prefer 2 apply (simp add: lt_nat_in_nat)
apply (rule le_trans [THEN le_exists], assumption+, force+)
done

lemma eps_split_left_le:
    "[|m \<le> k; k \<le> n; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule le_exists_lemma, assumption+)
apply (auto intro: eps_split_add_left)
done

lemma eps_split_left_le_rev:
    "[|m \<le> n; n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule le_exists_lemma, assumption+)
apply (auto intro: eps_split_add_left_rev)
done

lemma eps_split_right_le:
    "[|n \<le> k; k \<le> m; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule le_exists_lemma, assumption+)
apply (auto intro: eps_split_add_right)
done

lemma eps_split_right_le_rev:
    "[|n \<le> m; m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule le_exists_lemma, assumption+)
apply (auto intro: eps_split_add_right_rev)
done

(* The desired two theorems about `splitting'. *)

lemma eps_split_left:
    "[|m \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule nat_linear_le)
apply (rule_tac [4] eps_split_right_le_rev)
prefer 4 apply assumption
apply (rule_tac [3] nat_linear_le)
apply (rule_tac [5] eps_split_left_le)
prefer 6 apply assumption
apply (simp_all add: eps_split_left_le_rev)
done

lemma eps_split_right:
    "[|n \<le> k; emb_chain(DD,ee); m \<in> nat; n \<in> nat; k \<in> nat|]
     ==> eps(DD,ee,m,n) = eps(DD,ee,k,n) O eps(DD,ee,m,k)"
apply (rule nat_linear_le)
apply (rule_tac [3] eps_split_left_le_rev)
prefer 3 apply assumption
apply (rule_tac [8] nat_linear_le)
apply (rule_tac [10] eps_split_right_le)
prefer 11 apply assumption
apply (simp_all add: eps_split_right_le_rev)
done

(*----------------------------------------------------------------------*)
(* That was eps: D_m -> D_n, NEXT rho_emb: D_n -> Dinf.                 *)
(*----------------------------------------------------------------------*)

(* Considerably shorter. *)

lemma rho_emb_fun:
    "[|emb_chain(DD,ee); n \<in> nat|]
     ==> rho_emb(DD,ee,n): set(DD`n) -> set(Dinf(DD,ee))"
apply (simp add: rho_emb_def)
apply (assumption |
       rule lam_type DinfI eps_cont [THEN cont_fun, THEN apply_type])+
apply simp
apply (rule_tac i = "succ (na) " and j = n in nat_linear_le)
   apply blast
  apply assumption
 apply (simplesubst eps_split_right_le)
    \<comment>\<open>Subst would rewrite the lhs. We want to change the rhs.\<close>
       prefer 2 apply assumption
      apply simp
     apply (assumption | rule add_le_self nat_0I nat_succI)+
 apply (simp add: eps_succ_Rp)
 apply (subst comp_fun_apply)
    apply (assumption |
           rule eps_fun nat_succI Rp_cont [THEN cont_fun]
                emb_chain_emb emb_chain_cpo refl)+
(* Now the second part of the proof. Slightly different than HOL. *)
apply (simp add: eps_e_less nat_succI)
apply (erule le_iff [THEN iffD1, THEN disjE])
apply (simp add: e_less_le)
apply (subst comp_fun_apply)
apply (assumption | rule e_less_cont cont_fun emb_chain_emb emb_cont)+
apply (subst embRp_eq_thm)
apply (assumption |
       rule emb_chain_emb e_less_cont [THEN cont_fun, THEN apply_type]
            emb_chain_cpo nat_succI)+
 apply (simp add: eps_e_less)
apply (simp add: eps_succ_Rp e_less_eq id_conv nat_succI)
done

lemma rho_emb_apply1:
    "x \<in> set(DD`n) ==> rho_emb(DD,ee,n)`x = (\<lambda>m \<in> nat. eps(DD,ee,n,m)`x)"
by (simp add: rho_emb_def)

lemma rho_emb_apply2:
    "[|x \<in> set(DD`n); m \<in> nat|] ==> rho_emb(DD,ee,n)`x`m = eps(DD,ee,n,m)`x"
by (simp add: rho_emb_def)

lemma rho_emb_id: "[| x \<in> set(DD`n); n \<in> nat|] ==> rho_emb(DD,ee,n)`x`n = x"
by (simp add: rho_emb_apply2 eps_id)

(* Shorter proof, 23 against 62. *)

lemma rho_emb_cont:
    "[|emb_chain(DD,ee); n \<in> nat|]
     ==> rho_emb(DD,ee,n): cont(DD`n,Dinf(DD,ee))"
apply (rule contI)
apply (assumption | rule rho_emb_fun)+
apply (rule rel_DinfI)
apply (simp add: rho_emb_def)
apply (assumption |
       rule eps_cont [THEN cont_mono]  Dinf_prod apply_type rho_emb_fun)+
(* Continuity, different order, slightly different proofs. *)
apply (subst lub_Dinf)
apply (rule chainI)
apply (assumption | rule lam_type rho_emb_fun [THEN apply_type]  chain_in)+
apply simp
apply (rule rel_DinfI)
apply (simp add: rho_emb_apply2 chain_in)
apply (assumption |
       rule eps_cont [THEN cont_mono]  chain_rel Dinf_prod
            rho_emb_fun [THEN apply_type]  chain_in nat_succI)+
(* Now, back to the result of applying lub_Dinf *)
apply (simp add: rho_emb_apply2 chain_in)
apply (subst rho_emb_apply1)
apply (assumption | rule cpo_lub [THEN islub_in]  emb_chain_cpo)+
apply (rule fun_extension)
apply (assumption |
       rule lam_type eps_cont [THEN cont_fun, THEN apply_type]
            cpo_lub [THEN islub_in]  emb_chain_cpo)+
apply (assumption | rule cont_chain eps_cont emb_chain_cpo)+
apply simp
apply (simp add: eps_cont [THEN cont_lub])
done

(* 32 vs 61, using safe_tac with imp in asm would be unfortunate (5steps) *)

lemma eps1_aux1:
    "[|m \<le> n; emb_chain(DD,ee); x \<in> set(Dinf(DD,ee)); m \<in> nat; n \<in> nat|]
     ==> rel(DD`n,e_less(DD,ee,m,n)`(x`m),x`n)"
apply (erule rev_mp) (* For induction proof *)
apply (induct_tac n)
apply (rule impI)
apply (simp add: e_less_eq)
apply (subst id_conv)
apply (assumption | rule apply_type Dinf_prod cpo_refl emb_chain_cpo nat_0I)+
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (drule mp, assumption)
apply (rule cpo_trans)
apply (rule_tac [2] e_less_le [THEN ssubst])
apply (assumption | rule emb_chain_cpo nat_succI)+
apply (subst comp_fun_apply)
apply (assumption |
       rule emb_chain_emb [THEN emb_cont]  e_less_cont cont_fun apply_type
            Dinf_prod)+
apply (rule_tac y = "x`xa" in emb_chain_emb [THEN emb_cont, THEN cont_mono])
apply (assumption | rule e_less_cont [THEN cont_fun]  apply_type Dinf_prod)+
apply (rule_tac x1 = x and n1 = xa in Dinf_eq [THEN subst])
apply (rule_tac [3] comp_fun_apply [THEN subst])
apply (rename_tac [5] y)
apply (rule_tac [5] P =
         "%z. rel(DD`succ(y),
                  (ee`y O Rp(DD'(y)`y,DD'(y)`succ(y),ee'(y)`y)) ` (x`succ(y)),
                  z)" for DD' ee'
       in id_conv [THEN subst])
apply (rule_tac [6] rel_cf)
(* Dinf and cont_fun doesn't go well together, both Pi(_,%x._). *)
(* solves 10 of 11 subgoals *)
apply (assumption |
       rule Dinf_prod [THEN apply_type] cont_fun Rp_cont e_less_cont
            emb_cont emb_chain_emb emb_chain_cpo apply_type embRp_rel
            disjI1 [THEN le_succ_iff [THEN iffD2]]  nat_succI)+
apply (simp add: e_less_eq)
apply (subst id_conv)
apply (auto intro: apply_type Dinf_prod emb_chain_cpo)
done

(* 18 vs 40 *)

lemma eps1_aux2:
    "[|n \<le> m; emb_chain(DD,ee); x \<in> set(Dinf(DD,ee)); m \<in> nat; n \<in> nat|]
     ==> rel(DD`n,e_gr(DD,ee,m,n)`(x`m),x`n)"
apply (erule rev_mp) (* For induction proof *)
apply (induct_tac m)
apply (rule impI)
apply (simp add: e_gr_eq)
apply (subst id_conv)
apply (assumption | rule apply_type Dinf_prod cpo_refl emb_chain_cpo nat_0I)+
apply (simp add: le_succ_iff)
apply (rule impI)
apply (erule disjE)
apply (drule mp, assumption)
apply (subst e_gr_le)
apply (rule_tac [4] comp_fun_apply [THEN ssubst])
apply (rule_tac [6] Dinf_eq [THEN ssubst])
apply (assumption |
       rule emb_chain_emb emb_chain_cpo Rp_cont e_gr_cont cont_fun emb_cont
            apply_type Dinf_prod nat_succI)+
apply (simp add: e_gr_eq)
apply (subst id_conv)
apply (auto intro: apply_type Dinf_prod emb_chain_cpo)
done

lemma eps1:
    "[|emb_chain(DD,ee); x \<in> set(Dinf(DD,ee)); m \<in> nat; n \<in> nat|]
     ==> rel(DD`n,eps(DD,ee,m,n)`(x`m),x`n)"
apply (simp add: eps_def)
apply (blast intro: eps1_aux1 not_le_iff_lt [THEN iffD1, THEN leI, THEN eps1_aux2]
                    nat_into_Ord)
done

(* The following theorem is needed/useful due to type check for rel_cfI,
   but also elsewhere.
   Look for occurrences of rel_cfI, rel_DinfI, etc to evaluate the problem. *)

lemma lam_Dinf_cont:
  "[| emb_chain(DD,ee); n \<in> nat |]
     ==> (\<lambda>x \<in> set(Dinf(DD,ee)). x`n) \<in> cont(Dinf(DD,ee),DD`n)"
apply (rule contI)
apply (assumption | rule lam_type apply_type Dinf_prod)+
apply simp
apply (assumption | rule rel_Dinf)+
apply (subst beta)
apply (auto intro: cpo_Dinf islub_in cpo_lub)
apply (simp add: chain_in lub_Dinf)
done

lemma rho_projpair:
    "[| emb_chain(DD,ee); n \<in> nat |]
     ==> projpair(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n),rho_proj(DD,ee,n))"
apply (simp add: rho_proj_def)
apply (rule projpairI)
apply (assumption | rule rho_emb_cont)+
(* lemma used, introduced because same fact needed below due to rel_cfI. *)
apply (assumption | rule lam_Dinf_cont)+
(*-----------------------------------------------*)
(* This part is 7 lines, but 30 in HOL (75% reduction!) *)
apply (rule fun_extension)
apply (rule_tac [3] id_conv [THEN ssubst])
apply (rule_tac [4] comp_fun_apply [THEN ssubst])
apply (rule_tac [6] beta [THEN ssubst])
apply (rule_tac [7] rho_emb_id [THEN ssubst])
apply (assumption |
       rule comp_fun id_type lam_type rho_emb_fun Dinf_prod [THEN apply_type]
            apply_type refl)+
(*^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*)
apply (rule rel_cfI) (* ----------------\<longrightarrow>>>Yields type cond, not in HOL *)
apply (subst id_conv)
apply (rule_tac [2] comp_fun_apply [THEN ssubst])
apply (rule_tac [4] beta [THEN ssubst])
apply (rule_tac [5] rho_emb_apply1 [THEN ssubst])
apply (rule_tac [6] rel_DinfI)
apply (rule_tac [6] beta [THEN ssubst])
(* Dinf_prod bad with lam_type *)
apply (assumption |
       rule eps1 lam_type rho_emb_fun eps_fun
            Dinf_prod [THEN apply_type] refl)+
apply (assumption |
       rule apply_type eps_fun Dinf_prod comp_pres_cont rho_emb_cont
            lam_Dinf_cont id_cont cpo_Dinf emb_chain_cpo)+
done

lemma emb_rho_emb:
  "[| emb_chain(DD,ee); n \<in> nat |] ==> emb(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n))"
by (auto simp add: emb_def intro: exI rho_projpair)

lemma rho_proj_cont: "[| emb_chain(DD,ee); n \<in> nat |]
     ==> rho_proj(DD,ee,n) \<in> cont(Dinf(DD,ee),DD`n)"
by (auto intro: rho_projpair projpair_p_cont)

(*----------------------------------------------------------------------*)
(* Commutivity and universality.                                        *)
(*----------------------------------------------------------------------*)

lemma commuteI:
  "[| !!n. n \<in> nat ==> emb(DD`n,E,r(n));
      !!m n. [|m \<le> n; m \<in> nat; n \<in> nat|] ==> r(n) O eps(DD,ee,m,n) = r(m) |]
     ==> commute(DD,ee,E,r)"
by (simp add: commute_def)

lemma commute_emb [TC]:
  "[| commute(DD,ee,E,r); n \<in> nat |] ==> emb(DD`n,E,r(n))"
by (simp add: commute_def)

lemma commute_eq:
  "[| commute(DD,ee,E,r); m \<le> n; m \<in> nat; n \<in> nat |]
     ==> r(n) O eps(DD,ee,m,n) = r(m) "
by (simp add: commute_def)

(* Shorter proof: 11 vs 46 lines. *)

lemma rho_emb_commute:
  "emb_chain(DD,ee) ==> commute(DD,ee,Dinf(DD,ee),rho_emb(DD,ee))"
apply (rule commuteI)
apply (assumption | rule emb_rho_emb)+
apply (rule fun_extension) (* Manual instantiation in HOL. *)
apply (rule_tac [3] comp_fun_apply [THEN ssubst])
apply (rule_tac [5] fun_extension) (*Next, clean up and instantiate unknowns *)
apply (assumption | rule comp_fun rho_emb_fun eps_fun Dinf_prod apply_type)+
apply (simp add: rho_emb_apply2 eps_fun [THEN apply_type])
apply (rule comp_fun_apply [THEN subst])
apply (rule_tac [3] eps_split_left [THEN subst])
apply (auto intro: eps_fun)
done

lemma le_succ: "n \<in> nat ==> n \<le> succ(n)"
by (simp add: le_succ_iff)

(* Shorter proof: 21 vs 83 (106 - 23, due to OAssoc complication) *)

lemma commute_chain:
    "[| commute(DD,ee,E,r); emb_chain(DD,ee); cpo(E) |]
     ==> chain(cf(E,E),\<lambda>n \<in> nat. r(n) O Rp(DD`n,E,r(n)))"
apply (rule chainI)
apply (blast intro: lam_type cont_cf comp_pres_cont commute_emb Rp_cont
                    emb_cont emb_chain_cpo,
       simp)
apply (rule_tac r1 = r and m1 = n in commute_eq [THEN subst])
apply (assumption | rule le_succ nat_succI)+
apply (subst Rp_comp)
apply (assumption | rule emb_eps commute_emb emb_chain_cpo le_succ nat_succI)+
apply (rule comp_assoc [THEN subst]) (* comp_assoc is simpler in Isa *)
apply (rule_tac r1 = "r (succ (n))" in comp_assoc [THEN ssubst])
apply (rule comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps commute_emb Rp_cont
                    emb_cont emb_chain_cpo le_succ)+
apply (rule_tac b="r(succ(n))" in comp_id [THEN subst]) (* 1 subst too much *)
apply (rule_tac [2] comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps emb_id commute_emb
                    Rp_cont emb_cont cont_fun emb_chain_cpo le_succ)+
apply (subst comp_id) (* Undoes "1 subst too much", typing next anyway *)
apply (blast intro: cont_fun Rp_cont emb_cont commute_emb cont_cf cpo_cf
                    emb_chain_cpo embRp_rel emb_eps le_succ)+
done

lemma rho_emb_chain:
  "emb_chain(DD,ee) ==>
   chain(cf(Dinf(DD,ee),Dinf(DD,ee)),
         \<lambda>n \<in> nat. rho_emb(DD,ee,n) O Rp(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n)))"
by (auto intro: commute_chain rho_emb_commute cpo_Dinf)

lemma rho_emb_chain_apply1:
     "[| emb_chain(DD,ee); x \<in> set(Dinf(DD,ee)) |]
      ==> chain(Dinf(DD,ee),
                \<lambda>n \<in> nat.
                 (rho_emb(DD,ee,n) O Rp(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n)))`x)"
by (drule rho_emb_chain [THEN chain_cf], assumption, simp)

lemma chain_iprod_emb_chain:
     "[| chain(iprod(DD),X); emb_chain(DD,ee); n \<in> nat |]
      ==> chain(DD`n,\<lambda>m \<in> nat. X `m `n)"
by (auto intro: chain_iprod emb_chain_cpo)

lemma rho_emb_chain_apply2:
  "[| emb_chain(DD,ee); x \<in> set(Dinf(DD,ee)); n \<in> nat |] ==>
   chain
    (DD`n,
     \<lambda>xa \<in> nat.
      (rho_emb(DD, ee, xa) O Rp(DD ` xa, Dinf(DD, ee),rho_emb(DD, ee, xa))) `
       x ` n)"
by (frule rho_emb_chain_apply1 [THEN chain_Dinf, THEN chain_iprod_emb_chain],
    auto)

(* Shorter proof: 32 vs 72 (roughly), Isabelle proof has lemmas. *)

lemma rho_emb_lub:
  "emb_chain(DD,ee) ==>
   lub(cf(Dinf(DD,ee),Dinf(DD,ee)),
       \<lambda>n \<in> nat. rho_emb(DD,ee,n) O Rp(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n))) =
   id(set(Dinf(DD,ee)))"
apply (rule cpo_antisym)
apply (rule cpo_cf) (*Instantiate variable, continued below (loops otherwise)*)
apply (assumption | rule cpo_Dinf)+
apply (rule islub_least)
apply (assumption |
       rule cpo_lub rho_emb_chain cpo_cf cpo_Dinf isubI cont_cf id_cont)+
apply simp
apply (assumption | rule embRp_rel emb_rho_emb emb_chain_cpo cpo_Dinf)+
apply (rule rel_cfI)
apply (simp add: lub_cf rho_emb_chain cpo_Dinf)
apply (rule rel_DinfI) (* Additional assumptions *)
apply (subst lub_Dinf)
apply (assumption | rule rho_emb_chain_apply1)+
defer 1
apply (assumption |
       rule Dinf_prod cpo_lub [THEN islub_in]  id_cont cpo_Dinf cpo_cf cf_cont
            rho_emb_chain rho_emb_chain_apply1 id_cont [THEN cont_cf])+
apply simp
apply (rule dominate_islub)
apply (rule_tac [3] cpo_lub)
apply (rule_tac [6] x1 = "x`n" in chain_const [THEN chain_fun])
defer 1
apply (assumption |
       rule rho_emb_chain_apply2 emb_chain_cpo islub_const apply_type
            Dinf_prod emb_chain_cpo chain_fun rho_emb_chain_apply2)+
apply (rule dominateI, assumption, simp)
apply (subst comp_fun_apply)
apply (assumption |
       rule cont_fun Rp_cont emb_cont emb_rho_emb cpo_Dinf emb_chain_cpo)+
apply (subst rho_projpair [THEN Rp_unique])
prefer 5
apply (simp add: rho_proj_def)
apply (rule rho_emb_id [THEN ssubst])
apply (auto intro: cpo_Dinf apply_type Dinf_prod emb_chain_cpo)
done

lemma theta_chain: (* almost same proof as commute_chain *)
    "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
        emb_chain(DD,ee); cpo(E); cpo(G) |]
     ==> chain(cf(E,G),\<lambda>n \<in> nat. f(n) O Rp(DD`n,E,r(n)))"
apply (rule chainI)
apply (blast intro: lam_type cont_cf comp_pres_cont commute_emb Rp_cont
                    emb_cont emb_chain_cpo,
       simp)
apply (rule_tac r1 = r and m1 = n in commute_eq [THEN subst])
apply (rule_tac [5] r1 = f and m1 = n in commute_eq [THEN subst])
apply (assumption | rule le_succ nat_succI)+
apply (subst Rp_comp)
apply (assumption | rule emb_eps commute_emb emb_chain_cpo le_succ nat_succI)+
apply (rule comp_assoc [THEN subst])
apply (rule_tac r1 = "f (succ (n))" in comp_assoc [THEN ssubst])
apply (rule comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps commute_emb Rp_cont
                     emb_cont emb_chain_cpo le_succ)+
apply (rule_tac b="f(succ(n))" in comp_id [THEN subst]) (* 1 subst too much *)
apply (rule_tac [2] comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps emb_id commute_emb
                    Rp_cont emb_cont cont_fun emb_chain_cpo le_succ)+
apply (subst comp_id) (* Undoes "1 subst too much", typing next anyway *)
apply (blast intro: cont_fun Rp_cont emb_cont commute_emb cont_cf cpo_cf
                    emb_chain_cpo embRp_rel emb_eps le_succ)+
done

lemma theta_proj_chain: (* similar proof to theta_chain *)
  "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
      emb_chain(DD,ee); cpo(E); cpo(G) |]
     ==> chain(cf(G,E),\<lambda>n \<in> nat. r(n) O Rp(DD`n,G,f(n)))"
apply (rule chainI)
apply (blast intro: lam_type cont_cf comp_pres_cont commute_emb Rp_cont
                    emb_cont emb_chain_cpo, simp)
apply (rule_tac r1 = r and m1 = n in commute_eq [THEN subst])
apply (rule_tac [5] r1 = f and m1 = n in commute_eq [THEN subst])
apply (assumption | rule le_succ nat_succI)+
apply (subst Rp_comp)
apply (assumption | rule emb_eps commute_emb emb_chain_cpo le_succ nat_succI)+
apply (rule comp_assoc [THEN subst]) (* comp_assoc is simpler in Isa *)
apply (rule_tac r1 = "r (succ (n))" in comp_assoc [THEN ssubst])
apply (rule comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps commute_emb Rp_cont
                    emb_cont emb_chain_cpo le_succ)+
apply (rule_tac b="r(succ(n))" in comp_id [THEN subst]) (* 1 subst too much *)
apply (rule_tac [2] comp_mono)
apply (blast intro: comp_pres_cont eps_cont emb_eps emb_id commute_emb
                    Rp_cont emb_cont cont_fun emb_chain_cpo le_succ)+
apply (subst comp_id) (* Undoes "1 subst too much", typing next anyway *)
apply (blast intro: cont_fun Rp_cont emb_cont commute_emb cont_cf cpo_cf
                    emb_chain_cpo embRp_rel emb_eps le_succ)+
done

(* Simplification with comp_assoc is possible inside a \<lambda>-abstraction,
   because it does not have assumptions. If it had, as the HOL-ST theorem
   too strongly has, we would be in deep trouble due to HOL's lack of proper
   conditional rewriting (a HOL contrib provides something that works). *)

(* Controlled simplification inside lambda: introduce lemmas *)

lemma commute_O_lemma:
     "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
         emb_chain(DD,ee); cpo(E); cpo(G); x \<in> nat |]
      ==> r(x) O Rp(DD ` x, G, f(x)) O f(x) O Rp(DD ` x, E, r(x)) =
          r(x) O Rp(DD ` x, E, r(x))"
apply (rule_tac s1 = "f (x) " in comp_assoc [THEN subst])
apply (subst embRp_eq)
apply (rule_tac [4] id_comp [THEN ssubst])
apply (auto intro: cont_fun Rp_cont commute_emb emb_chain_cpo)
done

(* Shorter proof (but lemmas): 19 vs 79 (103 - 24, due to OAssoc)  *)

lemma theta_projpair:
  "[| lub(cf(E,E), \<lambda>n \<in> nat. r(n) O Rp(DD`n,E,r(n))) = id(set(E));
      commute(DD,ee,E,r); commute(DD,ee,G,f);
      emb_chain(DD,ee); cpo(E); cpo(G) |]
   ==> projpair
        (E,G,
         lub(cf(E,G), \<lambda>n \<in> nat. f(n) O Rp(DD`n,E,r(n))),
         lub(cf(G,E), \<lambda>n \<in> nat. r(n) O Rp(DD`n,G,f(n))))"
apply (simp add: projpair_def rho_proj_def, safe)
apply (rule_tac [3] comp_lubs [THEN ssubst])
(* The following one line is 15 lines in HOL, and includes existentials. *)
apply (assumption |
       rule cf_cont islub_in cpo_lub cpo_cf theta_chain theta_proj_chain)+
apply (simp (no_asm) add: comp_assoc)
apply (simp add: commute_O_lemma)
apply (subst comp_lubs)
apply (assumption |
       rule cf_cont islub_in cpo_lub cpo_cf theta_chain theta_proj_chain)+
apply (simp (no_asm) add: comp_assoc)
apply (simp add: commute_O_lemma)
apply (rule dominate_islub)
defer 1
apply (rule cpo_lub)
apply (assumption |
       rule commute_chain commute_emb islub_const cont_cf id_cont
    cpo_cf chain_fun chain_const)+
apply (rule dominateI, assumption, simp)
apply (blast intro: embRp_rel commute_emb emb_chain_cpo)
done

lemma emb_theta:
    "[| lub(cf(E,E), \<lambda>n \<in> nat. r(n) O Rp(DD`n,E,r(n))) = id(set(E));
        commute(DD,ee,E,r); commute(DD,ee,G,f);
        emb_chain(DD,ee); cpo(E); cpo(G) |]
     ==> emb(E,G,lub(cf(E,G), \<lambda>n \<in> nat. f(n) O Rp(DD`n,E,r(n))))"
apply (simp add: emb_def)
apply (blast intro: theta_projpair)
done

lemma mono_lemma:
    "[| g \<in> cont(D,D'); cpo(D); cpo(D'); cpo(E) |]
     ==> (\<lambda>f \<in> cont(D',E). f O g) \<in> mono(cf(D',E),cf(D,E))"
apply (rule monoI)
apply (simp add: set_def cf_def)
apply (drule cf_cont)+
apply simp
apply (blast intro: comp_mono lam_type comp_pres_cont cpo_cf cont_cf)
done

lemma commute_lam_lemma:
     "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
         emb_chain(DD,ee); cpo(E); cpo(G); n \<in> nat |]
      ==> (\<lambda>na \<in> nat. (\<lambda>f \<in> cont(E, G). f O r(n)) `
           ((\<lambda>n \<in> nat. f(n) O Rp(DD ` n, E, r(n))) ` na))  =
          (\<lambda>na \<in> nat. (f(na) O Rp(DD ` na, E, r(na))) O r(n))"
apply (rule fun_extension)
(*something wrong here*)
apply (auto simp del: beta_if simp add: beta intro: lam_type)
done

lemma chain_lemma:
     "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
         emb_chain(DD,ee); cpo(E); cpo(G); n \<in> nat |]
      ==> chain(cf(DD`n,G),\<lambda>x \<in> nat. (f(x) O Rp(DD ` x, E, r(x))) O r(n))"
apply (rule commute_lam_lemma [THEN subst])
apply (blast intro: theta_chain emb_chain_cpo
               commute_emb [THEN emb_cont, THEN mono_lemma, THEN mono_chain])+
done

lemma suffix_lemma:
    "[| commute(DD,ee,E,r); commute(DD,ee,G,f);
        emb_chain(DD,ee); cpo(E); cpo(G); cpo(DD`x); x \<in> nat |]
     ==> suffix(\<lambda>n \<in> nat. (f(n) O Rp(DD`n,E,r(n))) O r(x),x) =
         (\<lambda>n \<in> nat. f(x))"
apply (simp add: suffix_def)
apply (rule lam_type [THEN fun_extension])
apply (blast intro: lam_type comp_fun cont_fun Rp_cont emb_cont
                    commute_emb emb_chain_cpo)+
apply simp
apply (rename_tac y)
apply (subgoal_tac
       "f(x#+y) O (Rp(DD`(x#+y), E, r(x#+y)) O r (x#+y)) O eps(DD, ee, x, x#+y)
        = f(x)")
apply (simp add: comp_assoc commute_eq add_le_self)
apply (simp add: embRp_eq eps_fun [THEN id_comp] commute_emb emb_chain_cpo)
apply (blast intro: commute_eq add_le_self)
done

lemma mediatingI:
  "[|emb(E,G,t);  !!n. n \<in> nat ==> f(n) = t O r(n) |]==>mediating(E,G,r,f,t)"
by (simp add: mediating_def)

lemma mediating_emb: "mediating(E,G,r,f,t) ==> emb(E,G,t)"
by (simp add: mediating_def)

lemma mediating_eq: "[| mediating(E,G,r,f,t); n \<in> nat |] ==> f(n) = t O r(n)"
by (simp add: mediating_def)

lemma lub_universal_mediating:
  "[| lub(cf(E,E), \<lambda>n \<in> nat. r(n) O Rp(DD`n,E,r(n))) = id(set(E));
      commute(DD,ee,E,r); commute(DD,ee,G,f);
      emb_chain(DD,ee); cpo(E); cpo(G) |]
     ==> mediating(E,G,r,f,lub(cf(E,G), \<lambda>n \<in> nat. f(n) O Rp(DD`n,E,r(n))))"
apply (assumption | rule mediatingI emb_theta)+
apply (rule_tac b = "r (n) " in lub_const [THEN subst])
apply (rule_tac [3] comp_lubs [THEN ssubst])
apply (blast intro: cont_cf emb_cont commute_emb cpo_cf theta_chain
                    chain_const emb_chain_cpo)+
apply (simp (no_asm))
apply (rule_tac n1 = n in lub_suffix [THEN subst])
apply (assumption | rule chain_lemma cpo_cf emb_chain_cpo)+
apply (simp add: suffix_lemma lub_const cont_cf emb_cont commute_emb cpo_cf
                 emb_chain_cpo)
done

lemma lub_universal_unique:
    "[| mediating(E,G,r,f,t);
        lub(cf(E,E), \<lambda>n \<in> nat. r(n) O Rp(DD`n,E,r(n))) = id(set(E));
        commute(DD,ee,E,r); commute(DD,ee,G,f);
        emb_chain(DD,ee); cpo(E); cpo(G) |]
     ==> t = lub(cf(E,G), \<lambda>n \<in> nat. f(n) O Rp(DD`n,E,r(n)))"
apply (rule_tac b = t in comp_id [THEN subst])
apply (erule_tac [2] subst)
apply (rule_tac [2] b = t in lub_const [THEN subst])
apply (rule_tac [4] comp_lubs [THEN ssubst])
prefer 9 apply (simp add: comp_assoc mediating_eq)
apply (assumption |
       rule cont_fun emb_cont mediating_emb cont_cf cpo_cf chain_const
            commute_chain emb_chain_cpo)+
done

(*---------------------------------------------------------------------*)
(* Dinf yields the inverse_limit, stated as rho_emb_commute and        *)
(* Dinf_universal.                                                     *)
(*---------------------------------------------------------------------*)

theorem Dinf_universal:
  "[| commute(DD,ee,G,f); emb_chain(DD,ee); cpo(G) |] ==>
   mediating
    (Dinf(DD,ee),G,rho_emb(DD,ee),f,
     lub(cf(Dinf(DD,ee),G),
         \<lambda>n \<in> nat. f(n) O Rp(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n)))) &
   (\<forall>t. mediating(Dinf(DD,ee),G,rho_emb(DD,ee),f,t) \<longrightarrow>
     t = lub(cf(Dinf(DD,ee),G),
         \<lambda>n \<in> nat. f(n) O Rp(DD`n,Dinf(DD,ee),rho_emb(DD,ee,n))))"
apply safe
apply (assumption |
       rule lub_universal_mediating rho_emb_commute rho_emb_lub cpo_Dinf)+
apply (auto intro: lub_universal_unique rho_emb_commute rho_emb_lub cpo_Dinf)
done

end


theory word1
  imports "Word_Lib.Word_Lib"
begin
thm word_leI word_and_le2
value "(1::5 word)!!0"

lemma b:assumes a0:"(v <  2^(((size v) - 1)))"
        shows"\<not> ((v::('a::len) word)!! ((size v) - 1))"
proof-
  {assume a00: "((v::('a::len) word)!! ((size v) - 1))"
    have "v\<ge>  2^(((size v) - 1))" using a00
      using bang_is_le by blast
    then have  ?thesis using a0 by auto
  } thus ?thesis by auto
qed

lemma a1:assumes a0:"\<not> ((v::('a::len) word)!! ((size v) - 1))"
  shows "v \<le>  2^((size v) - 1) - 1"
proof -
  have f2: "size v = Suc (size v - 1)"
    by (meson Suc_pred' word_size_gt_0)
  moreover have f3: "size (mask (size v - 1)::'a word) = size v"
    by (simp add: word_size)
  moreover have  f4: "set_bit v (size v - 1) False = v"
    by (metis (full_types) a0 word_set_nth)
  ultimately show ?thesis
    using mask_2pm1 nat_neq_iff nth_mask test_bit_set_gen
    by (metis less_SucE word_leI)
qed

lemma  a:assumes a0:"\<not> ((v::('a::len) word)!! ((size v) - 1))"
  shows "(v <  2^(((size v) - 1)))"
using  a1[OF a0] by (simp add: le_less_trans power_2_ge_iff wsst_TYs(3))

lemma c:"\<not> ((v::('a::len) word)!! ((size v) - 1)) = (v <  2^(((size v) - 1)))"
  using a b by auto

end


theory Finite_Reachable
imports Small_Step
begin

subsection "Finite number of reachable commands"

text\<open>This theory shows that in the small-step semantics one can only reach
a finite number of commands from any given command. Hence one can see the
command component of a small-step configuration as a combination of the
program to be executed and a pc.\<close>

definition reachable :: "com \<Rightarrow> com set" where
"reachable c = {c'. \<exists>s t. (c,s) \<rightarrow>* (c',t)}"

text\<open>Proofs need induction on the length of a small-step reduction sequence.\<close>

fun small_stepsn :: "com * state \<Rightarrow> nat \<Rightarrow> com * state \<Rightarrow> bool"
    ("_ \<rightarrow>'(_') _" [55,0,55] 55) where
"(cs \<rightarrow>(0) cs') = (cs' = cs)" |
"cs \<rightarrow>(Suc n) cs'' = (\<exists>cs'. cs \<rightarrow> cs' \<and> cs' \<rightarrow>(n) cs'')"

lemma stepsn_if_star: "cs \<rightarrow>* cs' \<Longrightarrow> \<exists>n. cs \<rightarrow>(n) cs'"
proof(induction rule: star.induct)
  case refl show ?case by (metis small_stepsn.simps(1))
next
  case step thus ?case by (metis small_stepsn.simps(2))
qed

lemma star_if_stepsn: "cs \<rightarrow>(n) cs' \<Longrightarrow> cs \<rightarrow>* cs'"
by(induction n arbitrary: cs) (auto elim: star.step)

lemma SKIP_starD: "(SKIP, s) \<rightarrow>* (c,t) \<Longrightarrow> c = SKIP"
by(induction SKIP s c t rule: star_induct) auto

lemma reachable_SKIP: "reachable SKIP = {SKIP}"
by(auto simp: reachable_def dest: SKIP_starD)

lemma Assign_starD: "(x::=a, s) \<rightarrow>* (c,t) \<Longrightarrow> c \<in> {x::=a, SKIP}"
by (induction "x::=a" s c t rule: star_induct) (auto dest: SKIP_starD)

lemma reachable_Assign: "reachable (x::=a) = {x::=a, SKIP}"
by(auto simp: reachable_def dest:Assign_starD)

lemma Seq_stepsnD: "(c1;; c2, s) \<rightarrow>(n) (c', t) \<Longrightarrow>
  (\<exists>c1' m. c' = c1';; c2 \<and> (c1, s) \<rightarrow>(m) (c1', t) \<and> m \<le> n) \<or>
  (\<exists>s2 m1 m2. (c1,s) \<rightarrow>(m1) (SKIP,s2) \<and> (c2, s2) \<rightarrow>(m2) (c', t) \<and> m1+m2 < n)"
proof(induction n arbitrary: c1 c2 s)
  case 0 thus ?case by auto
next
  case (Suc n)
  from Suc.prems obtain s' c12' where "(c1;;c2, s) \<rightarrow> (c12', s')"
    and n: "(c12',s') \<rightarrow>(n) (c',t)" by auto
  from this(1) show ?case
  proof
    assume "c1 = SKIP" "(c12', s') = (c2, s)"
    hence "(c1,s) \<rightarrow>(0) (SKIP, s') \<and> (c2, s') \<rightarrow>(n) (c', t) \<and> 0 + n < Suc n"
      using n by auto
    thus ?case by blast
  next
    fix c1' s'' assume 1: "(c12', s') = (c1';; c2, s'')" "(c1, s) \<rightarrow> (c1', s'')"
    hence n': "(c1';;c2,s') \<rightarrow>(n) (c',t)" using n by auto
    from Suc.IH[OF n'] show ?case
    proof
      assume "\<exists>c1'' m. c' = c1'';; c2 \<and> (c1', s') \<rightarrow>(m) (c1'', t) \<and> m \<le> n"
        (is "\<exists> a b. ?P a b")
      then obtain c1'' m where 2: "?P c1'' m" by blast
      hence "c' = c1'';;c2 \<and> (c1, s) \<rightarrow>(Suc m) (c1'',t) \<and> Suc m \<le> Suc n"
        using 1 by auto
      thus ?case by blast
    next
      assume "\<exists>s2 m1 m2. (c1',s') \<rightarrow>(m1) (SKIP,s2) \<and>
        (c2,s2) \<rightarrow>(m2) (c',t) \<and> m1+m2 < n" (is "\<exists>a b c. ?P a b c")
      then obtain s2 m1 m2 where "?P s2 m1 m2" by blast
      hence "(c1,s) \<rightarrow>(Suc m1) (SKIP,s2) \<and> (c2,s2) \<rightarrow>(m2) (c',t) \<and>
        Suc m1 + m2 < Suc n"  using 1 by auto
      thus ?case by blast
    qed
  qed
qed

corollary Seq_starD: "(c1;; c2, s) \<rightarrow>* (c', t) \<Longrightarrow>
  (\<exists>c1'. c' = c1';; c2 \<and> (c1, s) \<rightarrow>* (c1', t)) \<or>
  (\<exists>s2. (c1,s) \<rightarrow>* (SKIP,s2) \<and> (c2, s2) \<rightarrow>* (c', t))"
by(metis Seq_stepsnD star_if_stepsn stepsn_if_star)

lemma reachable_Seq: "reachable (c1;;c2) \<subseteq>
  (\<lambda>c1'. c1';;c2) ` reachable c1 \<union> reachable c2"
by(auto simp: reachable_def image_def dest!: Seq_starD)

lemma If_starD: "(IF b THEN c1 ELSE c2, s) \<rightarrow>* (c,t) \<Longrightarrow>
  c = IF b THEN c1 ELSE c2 \<or> (c1,s) \<rightarrow>* (c,t) \<or> (c2,s) \<rightarrow>* (c,t)"
by(induction "IF b THEN c1 ELSE c2" s c t rule: star_induct) auto

lemma reachable_If: "reachable (IF b THEN c1 ELSE c2) \<subseteq>
  {IF b THEN c1 ELSE c2} \<union> reachable c1 \<union> reachable c2"
by(auto simp: reachable_def dest!: If_starD)

lemma While_stepsnD: "(WHILE b DO c, s) \<rightarrow>(n) (c2,t) \<Longrightarrow>
  c2 \<in> {WHILE b DO c, IF b THEN c ;; WHILE b DO c ELSE SKIP, SKIP}
  \<or> (\<exists>c1. c2 = c1 ;; WHILE b DO c \<and> (\<exists> s1 s2. (c,s1) \<rightarrow>* (c1,s2)))"
proof(induction n arbitrary: s rule: less_induct)
  case (less n1)
  show ?case
  proof(cases n1)
    case 0 thus ?thesis using less.prems by (simp)
  next
    case (Suc n2)
    let ?w = "WHILE b DO c"
    let ?iw = "IF b THEN c ;; ?w ELSE SKIP"
    from Suc less.prems have n2: "(?iw,s) \<rightarrow>(n2) (c2,t)" by(auto elim!: WhileE)
    show ?thesis
    proof(cases n2)
      case 0 thus ?thesis using n2 by auto
    next
      case (Suc n3)
      then obtain iw' s' where "(?iw,s) \<rightarrow> (iw',s')"
        and n3: "(iw',s') \<rightarrow>(n3) (c2,t)"  using n2 by auto
      from this(1)
      show ?thesis
      proof
        assume "(iw', s') = (c;; WHILE b DO c, s)"
        with n3 have "(c;;?w, s) \<rightarrow>(n3) (c2,t)" by auto
        from Seq_stepsnD[OF this] show ?thesis
        proof
          assume "\<exists>c1' m. c2 = c1';; ?w \<and> (c,s) \<rightarrow>(m) (c1', t) \<and> m \<le> n3"
          thus ?thesis by (metis star_if_stepsn)
        next
          assume "\<exists>s2 m1 m2. (c, s) \<rightarrow>(m1) (SKIP, s2) \<and>
            (WHILE b DO c, s2) \<rightarrow>(m2) (c2, t) \<and> m1 + m2 < n3" (is "\<exists>x y z. ?P x y z")
          then obtain s2 m1 m2 where "?P s2 m1 m2" by blast
          with \<open>n2 = Suc n3\<close> \<open>n1 = Suc n2\<close>have "m2 < n1" by arith
          from less.IH[OF this] \<open>?P s2 m1 m2\<close> show ?thesis by blast
        qed
      next
        assume "(iw', s') = (SKIP, s)"
        thus ?thesis using star_if_stepsn[OF n3] by(auto dest!: SKIP_starD)
      qed
    qed
  qed
qed

lemma reachable_While: "reachable (WHILE b DO c) \<subseteq>
  {WHILE b DO c, IF b THEN c ;; WHILE b DO c ELSE SKIP, SKIP} \<union>
  (\<lambda>c'. c' ;; WHILE b DO c) ` reachable c"
apply(auto simp: reachable_def image_def)
by (metis While_stepsnD insertE singletonE stepsn_if_star)

theorem finite_reachable: "finite(reachable c)"
apply(induction c)
apply(auto simp: reachable_SKIP reachable_Assign
  finite_subset[OF reachable_Seq] finite_subset[OF reachable_If]
  finite_subset[OF reachable_While])
done

end