section \<open>Lens Instances\<close>

theory Lens_Instances
  imports Lens_Order Lens_Symmetric "HOL-Eisbach.Eisbach"
  keywords "alphabet" :: "thy_defn"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function Lens\<close>

text \<open>A function lens views the valuation associated with a particular domain element @{typ "'a"}.
      We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_vwb_lens: "vwb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

text \<open>Two function lenses are independent if and only if the domain elements are different.\<close>

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

subsection \<open>Function Range Lens\<close>

text \<open>The function range lens allows us to focus on a particular region of a function's range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map Lens\<close>

text \<open>The map lens allows us to focus on a particular region of a partial function's range. It
  is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view
  is not in the domain.\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

lemma source_map_lens: "\<S>\<^bsub>map_lens x\<^esub> = {f. x \<in> dom(f)}"
  by (force simp add: map_lens_def lens_source_def)

subsection \<open>List Lens\<close>

text \<open>The list lens allows us to view a particular element of a list. In order to show it is mainly
  well-behaved we need to define to additional list functions. The following function adds
  a number undefined elements to the end of a list.\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

text \<open>The following function is like @{term "list_update"} but it adds additional elements to the
  list if the list isn't long enough first.\<close>

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

text \<open>The following function is like @{term nth} but it expressly returns @{term undefined} when
  the list isn't long enough.\<close>

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

text \<open>We can prove some additional laws about list update and append.\<close>

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

text \<open>We can also prove some laws about our new operators.\<close>

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_last [simp]:
  "list_augment (xs @ [y]) (length xs) z = xs @ [z]"
  by (induct xs, simp_all)

lemma list_augment_idem [simp]:
  "i < length xs \<Longrightarrow> list_augment xs i (xs ! i) = xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.\<close>

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

text \<open>We can also prove that we can always retrieve an element we have added to the list, since
  @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. \<close>

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

text \<open> The length is expanded if not already long enough, or otherwise left as it is. \<close>

lemma length_list_augment_1: "k \<ge> length xs \<Longrightarrow> length (list_augment xs k v) = Suc k"
  by (simp add: list_augment_def list_pad_out_def)

lemma length_list_augment_2: "k < length xs \<Longrightarrow> length (list_augment xs k v) = length xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We also have it that @{term list_augment} cancels itself.\<close>

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

text \<open>Finally we can create the list lenses, of which there are three varieties. One that allows
  us to view an index, one that allows us to view the head, and one that allows us to view the tail.
  They are all mainly well-behaved lenses.\<close>

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation hd_lens ("hd\<^sub>L") where "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" ("tl\<^sub>L") where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

text \<open> The set of constructible sources is precisely those where the length is greater than the
  given index. \<close>

lemma source_list_lens: "\<S>\<^bsub>list_lens i\<^esub> = {xs. length xs > i}"
  apply (auto simp add: lens_source_def list_lens_def)
   apply (metis length_list_augment_1 length_list_augment_2 lessI not_less)
  apply (metis list_augment_idem)
  done

lemma tail_lens_mwb:
  "mwb_lens tl\<^sub>L"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma source_tail_lens: "\<S>\<^bsub>tl\<^sub>L\<^esub> = {xs. xs \<noteq> []}"
  using list.exhaust_sel by (auto simp add: tl_lens_def lens_source_def)

text \<open>Independence of list lenses follows when the two indices are different.\<close>

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd\<^sub>L \<bowtie> tl\<^sub>L"
  apply (rule lens_indepI)
    apply (simp_all add: list_lens_def tl_lens_def)
    apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
   apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis One_nat_def diff_Suc_Suc diff_zero length_0_conv length_list_augment_1 length_tl linorder_not_less list.exhaust list.sel(2) list.sel(3) list_augment_0 not_less_zero)
done

lemma hd_tl_lens_pbij: "pbij_lens (hd\<^sub>L +\<^sub>L tl\<^sub>L)"
  by (unfold_locales, auto simp add: lens_defs)

subsection \<open>Record Field Lenses\<close>

text \<open>We also add support for record lenses. Every record created can yield a lens for each field.
  These cannot be created generically and thus must be defined case by case as new records are
  created. We thus create a new Isabelle outer syntax command \textbf{alphabet} which enables this.
  We first create syntax that allows us to obtain a lens from a given field using the internal
  record syntax translations.\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax
  "_FLDLENS" :: "id \<Rightarrow> logic"  ("FLDLENS _")
translations
  "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text \<open> We also allow the extraction of the "base lens", which characterises all the fields added
  by a record without the extension. \<close>

syntax
  "_BASELENS" :: "id \<Rightarrow> logic"  ("BASELENS _")

abbreviation (input) "base_lens t e m \<equiv> \<lparr> lens_get = t, lens_put = \<lambda> s v. e v (m s) \<rparr>"

ML \<open>
  fun baselens_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
    in
      Const (@{const_syntax "base_lens"}, dummyT) $ truncate $ extend $ more
    end
  | baselens_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_BASELENS"}, K baselens_tr)]\<close>

text \<open>We also introduce the \textbf{alphabet} command that creates a record with lenses for each field.
  For each field a lens is created together with a proof that it is very well-behaved, and for each
  pair of lenses an independence theorem is generated. Alphabets can also be extended which yields
  sublens proofs between the extension field lens and record extension lenses. \<close>

ML_file \<open>Lens_Record.ML\<close>

text \<open>The following theorem attribute stores splitting theorems for alphabet types which which is useful
  for proof automation.\<close>

named_theorems alpha_splits

subsection \<open>Type Definition Lens\<close>

text \<open> Every type defined by a \<^bold>\<open>typedef\<close> command induces a partial bijective lens constructed
  using the abstraction and representation functions. \<close>

context type_definition
begin

definition typedef_lens :: "'b \<Longrightarrow> 'a" ("typedef\<^sub>L") where
[lens_defs]: "typedef\<^sub>L = \<lparr> lens_get = Abs, lens_put = (\<lambda> s. Rep) \<rparr>"

lemma pbij_typedef_lens [simp]: "pbij_lens typedef\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs Rep_inverse)

lemma source_typedef_lens: "\<S>\<^bsub>typedef\<^sub>L\<^esub> = A"
  using Rep_cases by (auto simp add: lens_source_def lens_defs Rep)

lemma bij_typedef_lens_UNIV: "A = UNIV \<Longrightarrow> bij_lens typedef\<^sub>L"
  by (auto intro: pbij_vwb_is_bij_lens simp add: mwb_UNIV_src_is_vwb_lens source_typedef_lens)

end

subsection \<open>Mapper Lenses\<close>

definition lmap_lens ::
  "(('\<alpha> \<Rightarrow> '\<beta>) \<Rightarrow> ('\<gamma> \<Rightarrow> '\<delta>)) \<Rightarrow>
   (('\<beta> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<delta> \<Rightarrow> '\<gamma>) \<Rightarrow>
   ('\<gamma> \<Rightarrow> '\<alpha>) \<Rightarrow>
   ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow>
   ('\<delta> \<Longrightarrow> '\<gamma>)" where
  [lens_defs]:
  "lmap_lens f g h l = \<lparr>
  lens_get = f (get\<^bsub>l\<^esub>),
  lens_put = g o (put\<^bsub>l\<^esub>) o h \<rparr>"

text \<open>
  The parse translation below yields a heterogeneous mapping lens for any
  record type. This achieved through the utility function above that
  constructs a functorial lens. This takes as input a heterogeneous mapping
  function that lifts a function on a record's extension type to an update
  on the entire record, and also the record's ``more'' function. The first input
  is given twice as it has different polymorphic types, being effectively
  a type functor construction which are not explicitly supported by HOL. We note
  that the \<open>more_update\<close> function does something similar to the extension lifting,
  but is not precisely suitable here since it only considers homogeneous functions,
  namely of type \<open>'a \<Rightarrow> 'a\<close> rather than \<open>'a \<Rightarrow> 'b\<close>.
\<close>

syntax
  "_lmap" :: "id \<Rightarrow> logic" ("lmap[_]")

ML \<open>
  fun lmap_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
      val map_ext = Abs ("f", dummyT,
                    Abs ("r", dummyT,
                      extend $ (truncate $ Bound 0) $ (Bound 1 $ (more $ (Bound 0)))))

    in
      Const (@{const_syntax "lmap_lens"}, dummyT) $ map_ext $ map_ext $ more
    end
  | lmap_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_lmap"}, K lmap_tr)]\<close>

subsection \<open>Lens Interpretation\<close>

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]

end

subsection \<open> Tactic \<close>

text \<open> A simple tactic for simplifying lens expressions \<close>

declare split_paired_all [alpha_splits]

method lens_simp = (simp add: alpha_splits lens_defs prod.case_eq_if)

end


section \<open> UTP Theories \<close>

theory utp_theory
imports utp_rel_laws
begin

text \<open> Here, we mechanise a representation of UTP theories using locales~\cite{Ballarin06}. We also
  link them to the HOL-Algebra library~\cite{Ballarin17}, which allows us to import properties from
  complete lattices and Galois connections. \<close>

subsection \<open> Complete lattice of predicates \<close>

definition upred_lattice :: "('\<alpha> upred) gorder" ("\<P>") where
"upred_lattice = \<lparr> carrier = UNIV, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> @{term "\<P>"} is the complete lattice of alphabetised predicates. All other theories will
  be defined relative to it. \<close>

interpretation upred_lattice: complete_lattice \<P>
proof (unfold_locales, simp_all add: upred_lattice_def)
  fix A :: "'\<alpha> upred set"
  show "\<exists>s. is_lub \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> s A"
    apply (rule_tac x="\<Squnion> A" in exI)
    apply (rule least_UpperI)
       apply (auto intro: Inf_greatest simp add: Inf_lower Upper_def)
    done
  show "\<exists>i. is_glb \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> i A"
    apply (rule_tac x="\<Sqinter> A" in exI)
    apply (rule greatest_LowerI)
       apply (auto intro: Sup_least simp add: Sup_upper Lower_def)
    done
qed

lemma upred_weak_complete_lattice [simp]: "weak_complete_lattice \<P>"
  by (simp add: upred_lattice.weak.weak_complete_lattice_axioms)

lemma upred_lattice_eq [simp]:
  "(.=\<^bsub>\<P>\<^esub>) = (=)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_le [simp]:
  "le \<P> P Q = (P \<sqsubseteq> Q)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_carrier [simp]:
  "carrier \<P> = UNIV"
  by (simp add: upred_lattice_def)

lemma upred_lattice_Monotonic [simp]: "Mono\<^bsub>\<P>\<^esub> H = Monotonic H"
  using upred_lattice.weak_partial_order_axioms by (auto simp add: isotone_def mono_def)

subsection \<open> UTP theories hierarchy \<close>

definition utp_order :: "'\<alpha> health \<Rightarrow> '\<alpha> upred gorder" where
"utp_order H = \<lparr> carrier = {P. P is H}, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> Constant @{term utp_order} obtains the order structure associated with a UTP theory.
  Its carrier is the set of healthy predicates, equality is HOL equality, and the order is
  refinement. \<close>

lemma utp_order_carrier [simp]:
  "carrier (utp_order H) = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (simp add: utp_order_def)

lemma utp_order_eq [simp]:
  "eq (utp_order T) = (=)"
  by (simp add: utp_order_def)

lemma utp_order_le [simp]:
  "le (utp_order T) = (\<sqsubseteq>)"
  by (simp add: utp_order_def)

lemma utp_partial_order: "partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma utp_weak_partial_order: "weak_partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma mono_Monotone_utp_order:
  "mono f \<Longrightarrow> Monotone (utp_order T) f"
  apply (auto simp add: isotone_def)
   apply (metis partial_order_def utp_partial_order)
  apply (metis monoD)
  done

lemma isotone_utp_orderI: "Monotonic H \<Longrightarrow> isotone (utp_order X) (utp_order Y) H"
  by (auto simp add: mono_def isotone_def utp_weak_partial_order)

lemma Mono_utp_orderI:
  "\<lbrakk> \<And> P Q. \<lbrakk> P \<sqsubseteq> Q; P is H; Q is H \<rbrakk> \<Longrightarrow> F(P) \<sqsubseteq> F(Q) \<rbrakk> \<Longrightarrow> Mono\<^bsub>utp_order H\<^esub> F"
  by (auto simp add: isotone_def utp_weak_partial_order)

text \<open> The UTP order can equivalently be characterised as the fixed point lattice, @{const fpl}. \<close>

lemma utp_order_fpl: "utp_order H = fpl \<P> H"
  by (auto simp add: utp_order_def upred_lattice_def fps_def Healthy_def)

subsection \<open> UTP theory hierarchy \<close>

text \<open> We next define a hierarchy of locales that characterise different classes of UTP theory.
  Minimally we require that a UTP theory's healthiness condition is idempotent. \<close>

locale utp_theory =
  fixes hcond :: "'\<alpha> upred \<Rightarrow> '\<alpha> upred" ("\<H>")
  assumes HCond_Idem: "\<H>(\<H>(P)) = \<H>(P)"
begin

  abbreviation thy_order :: "'\<alpha> upred gorder" where
  "thy_order \<equiv> utp_order \<H>"

  abbreviation "umono \<equiv> Mono\<^bsub>thy_order\<^esub>"

  lemma HCond_Idempotent [closure,intro]: "Idempotent \<H>"
    by (simp add: Idempotent_def HCond_Idem)

  sublocale utp_po: partial_order "utp_order \<H>"
    by (unfold_locales, simp_all add: utp_order_def)

  text \<open> We need to remove some transitivity rules to stop them being applied in calculations \<close>

  declare utp_po.trans [trans del]

  lemma refine_monoE:
    assumes "umono F" "x is \<H>" "y is \<H>" "x \<sqsubseteq> y"
    shows "(x is \<H> \<Longrightarrow> y is \<H> \<Longrightarrow> F x \<sqsubseteq> F y \<Longrightarrow> thesis) \<Longrightarrow> thesis"
    using assms by (simp add: isotone_def)

end

locale utp_theory_lattice = utp_theory +
  assumes uthy_lattice: "complete_lattice (utp_order \<H>)"
begin

sublocale complete_lattice "utp_order \<H>"
  rewrites "le thy_order = (\<sqsubseteq>)"
  and "eq thy_order = (=)"
  and "\<And> A. A \<subseteq> carrier thy_order \<longleftrightarrow> A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  and "\<And> P. P \<in> carrier thy_order \<longleftrightarrow> P is \<H>"
  and "carrier thy_order \<rightarrow> carrier thy_order = \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  and "Lattice.sup thy_order (carrier thy_order) = Lattice.sup thy_order \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  and "Lattice.inf thy_order (carrier thy_order) = Lattice.inf thy_order \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  by (simp_all add: uthy_lattice)

declare top_closed [simp del]
declare bottom_closed [simp del]

text \<open> The healthiness conditions of a UTP theory lattice form a complete lattice, and allows us to make
  use of complete lattice results from HOL-Algebra~\cite{Ballarin17}, such as the Knaster-Tarski theorem. We can also
  retrieve lattice operators as below. \<close>

abbreviation utp_top ("\<^bold>\<top>")
where "utp_top \<equiv> top (utp_order \<H>)"

abbreviation utp_bottom ("\<^bold>\<bottom>")
where "utp_bottom \<equiv> bottom (utp_order \<H>)"

abbreviation utp_join (infixl "\<^bold>\<squnion>" 65) where
"utp_join \<equiv> join (utp_order \<H>)"

abbreviation utp_meet (infixl "\<^bold>\<sqinter>" 70) where
"utp_meet \<equiv> meet (utp_order \<H>)"

abbreviation utp_sup ("\<^bold>\<Squnion>_" [90] 90) where
"utp_sup \<equiv> Lattice.sup (utp_order \<H>)"

abbreviation utp_inf ("\<^bold>\<Sqinter>_" [90] 90) where
"utp_inf \<equiv> Lattice.inf (utp_order \<H>)"

abbreviation utp_gfp ("\<^bold>\<nu>") where
"utp_gfp \<equiv> GREATEST_FP (utp_order \<H>)"

abbreviation utp_lfp ("\<^bold>\<mu>") where
"utp_lfp \<equiv> LEAST_FP (utp_order \<H>)"

text \<open> The following theorem and proof was contributed by Yakoub Nemouchi. \<close>

(* This proof should perhaps be in HOL-Algebra. *)
lemma lfp_ordinal_induct [case_names M H step union]:
  assumes M:\<open>Mono\<^bsub>thy_order\<^esub> F\<close>
  assumes H:\<open>F \<in> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H\<close>
  assumes P_f:\<open>\<And>S. P S \<Longrightarrow> S \<sqsubseteq> \<^bold>\<mu> F \<Longrightarrow> S is \<H> \<Longrightarrow> P (F S)\<close>
  assumes P_Union:\<open>\<And>M. M \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<Longrightarrow> (\<And>S. S \<in> M \<Longrightarrow> P S) \<Longrightarrow> P (\<^bold>\<Squnion> M)\<close>
  shows \<open>P (\<^bold>\<mu> F)\<close>
proof -
  let ?M = \<open>{S. S \<sqsubseteq> \<^bold>\<mu> F \<and> P S \<and> (S is \<H>)}\<close>
  from P_Union have \<open>P (\<^bold>\<Squnion> ?M)\<close>
    by (metis (no_types, lifting) Collect_mono mem_Collect_eq)
  also have \<open>\<^bold>\<Squnion> ?M = \<^bold>\<mu> F\<close>
  proof (rule antisym)
    show \<open>\<^bold>\<Squnion> ?M \<sqsubseteq> \<^bold>\<mu> F\<close>
      by (subst sup_least, auto simp add: Collect_mono)
    then have \<open>F (\<^bold>\<Squnion> ?M) \<sqsubseteq> F (\<^bold>\<mu> F)\<close>
      by (metis (mono_tags, lifting) Collect_mono LFP_closed M sup_closed refine_monoE)
    then have \<open>F (\<^bold>\<Squnion> ?M) \<sqsubseteq> \<^bold>\<mu> F\<close>
      by (metis (no_types, lifting) H LFP_weak_unfold M)
    then have \<open>F (\<^bold>\<Squnion> ?M) \<in> ?M\<close>
      using P_Union
      apply simp
      apply (subst P_f)
         apply simp_all
         apply (simp add: calculation)
        apply (simp add: \<open>\<^bold>\<Squnion>?M \<sqsubseteq> \<^bold>\<mu> F\<close>)
       apply (simp add: Collect_mono_iff)
      using H
      apply (elim PiE)
       apply simp_all
      apply (simp add: Collect_mono)
      done
    then have "F (\<^bold>\<Squnion> ?M)  \<sqsubseteq> \<^bold>\<Squnion> ?M"
      by (simp add: Collect_mono sup_upper)
    then show "\<^bold>\<mu> F  \<sqsubseteq> \<^bold>\<Squnion> ?M"
      by (simp add: Collect_mono LFP_lowerbound)
  qed
  finally show ?thesis .
qed

end

syntax
  "_tmu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<mu>\<index> _ \<bullet> _" [0, 10] 10)
  "_tnu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<nu>\<index> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<^bold>\<mu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST LEAST_FP (CONST utp_order H) (\<lambda> X. P)"
  "\<^bold>\<nu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST GREATEST_FP (CONST utp_order H) (\<lambda> X. P)"

lemma upred_lattice_inf:
  "Lattice.inf \<P> A = \<Sqinter> A"
  by (metis Sup_least Sup_upper UNIV_I antisym_conv subsetI upred_lattice.weak.inf_greatest upred_lattice.weak.inf_lower upred_lattice_carrier upred_lattice_le)

text \<open> We can then derive a number of properties about these operators, as below. \<close>

context utp_theory_lattice
begin

  lemma LFP_healthy_comp: "\<^bold>\<mu> F = \<^bold>\<mu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} = {P. (P is \<H>) \<and> F (\<H> P) \<sqsubseteq> P}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: LEAST_FP_def)
  qed

  lemma GFP_healthy_comp: "\<^bold>\<nu> F = \<^bold>\<nu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> P \<sqsubseteq> F P} = {P. (P is \<H>) \<and> P \<sqsubseteq> F (\<H> P)}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: GREATEST_FP_def)
  qed

  lemma top_healthy [closure]: "\<^bold>\<top> is \<H>"
    using weak.top_closed by auto

  lemma bottom_healthy [closure]: "\<^bold>\<bottom> is \<H>"
    using weak.bottom_closed by auto

  lemma utp_top: "P is \<H> \<Longrightarrow> P \<sqsubseteq> \<^bold>\<top>"
    using weak.top_higher by auto

  lemma utp_bottom: "P is \<H> \<Longrightarrow> \<^bold>\<bottom> \<sqsubseteq> P"
    using weak.bottom_lower by auto

end

lemma upred_top: "\<top>\<^bsub>\<P>\<^esub> = false"
  using ball_UNIV greatest_def by fastforce

lemma upred_bottom: "\<bottom>\<^bsub>\<P>\<^esub> = true"
  by fastforce

text \<open> One way of obtaining a complete lattice is showing that the healthiness conditions
  are monotone, which the below locale characterises. \<close>

locale utp_theory_mono = utp_theory +
  assumes HCond_Mono [closure,intro]: "Monotonic \<H>"

sublocale utp_theory_mono \<subseteq> utp_theory_lattice
proof -
  interpret weak_complete_lattice "fpl \<P> \<H>"
    by (rule Knaster_Tarski, auto)

  have "complete_lattice (fpl \<P> \<H>)"
    by (unfold_locales, simp add: fps_def sup_exists, (blast intro: sup_exists inf_exists)+)

  hence "complete_lattice (utp_order \<H>)"
    by (simp add: utp_order_def, simp add: upred_lattice_def)

  thus "utp_theory_lattice \<H>"
    by (simp add: utp_theory_axioms utp_theory_lattice.intro utp_theory_lattice_axioms.intro)
qed

text \<open> In a monotone theory, the top and bottom can always be obtained by applying the healthiness
  condition to the predicate top and bottom, respectively. \<close>

context utp_theory_mono
begin

lemma healthy_top: "\<^bold>\<top> = \<H>(false)"
proof -
  have "\<^bold>\<top> = \<top>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<top>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(1)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> false"
    by (simp add: upred_top)
  finally show ?thesis .
qed

lemma healthy_bottom: "\<^bold>\<bottom> = \<H>(true)"
proof -
  have "\<^bold>\<bottom> = \<bottom>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<bottom>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(2)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> true"
    by (simp add: upred_bottom)
   finally show ?thesis .
qed

lemma healthy_inf:
  assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  shows "\<^bold>\<Sqinter> A = \<H> (\<Sqinter> A)"
  using Knaster_Tarski_idem_inf_eq[OF upred_weak_complete_lattice, of "\<H>"]
  by (simp, metis HCond_Idempotent HCond_Mono assms partial_object.simps(3) upred_lattice_def upred_lattice_inf utp_order_def)

end

locale utp_theory_continuous = utp_theory +
  assumes HCond_Cont [closure,intro]: "Continuous \<H>"

sublocale utp_theory_continuous \<subseteq> utp_theory_mono
proof
  show "Monotonic \<H>"
    by (simp add: Continuous_Monotonic HCond_Cont)
qed

context utp_theory_continuous
begin

  lemma healthy_inf_cont:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "\<^bold>\<Sqinter> A = \<Sqinter> A"
  proof -
    have "\<^bold>\<Sqinter> A = \<Sqinter> (\<H>`A)"
      using Continuous_def HCond_Cont assms(1) assms(2) healthy_inf by auto
    also have "... = \<Sqinter> A"
      by (unfold Healthy_carrier_image[OF assms(1)], simp)
    finally show ?thesis .
  qed

  lemma healthy_inf_def:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<Sqinter> A = (if (A = {}) then \<^bold>\<top> else (\<Sqinter> A))"
    using assms healthy_inf_cont weak.weak_inf_empty by auto

  lemma healthy_meet_cont:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<^bold>\<sqinter> Q = P \<sqinter> Q"
    using healthy_inf_cont[of "{P, Q}"] assms
    by (simp add: Healthy_if meet_def)

  lemma meet_is_healthy [closure]:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<sqinter> Q is \<H>"
    by (metis Continuous_Disjunctous Disjunctuous_def HCond_Cont Healthy_def' assms(1) assms(2))

  lemma disj_is_healthy [closure]:
    "\<lbrakk> P is \<H>; Q is \<H> \<rbrakk> \<Longrightarrow> (P \<or> Q) is \<H>"
    by (simp add: disj_upred_def meet_is_healthy)

  lemma meet_bottom [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<bottom> = \<^bold>\<bottom>"
      by (simp add: assms semilattice_sup_class.sup_absorb2 utp_bottom)

  lemma meet_top [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<top> = P"
      by (simp add: assms semilattice_sup_class.sup_absorb1 utp_top)

  lemma inf_empty: "\<^bold>\<Sqinter> {} = \<^bold>\<top>"
    by (simp add: healthy_inf_def)

  lemma inf_all: "\<^bold>\<Sqinter> \<lbrakk>\<H>\<rbrakk>\<^sub>H = \<^bold>\<bottom>"
    using weak_inf_carrier by auto

  text \<open> The UTP theory lfp operator can be rewritten to the alphabetised predicate lfp when
    in a continuous context. \<close>

  theorem utp_lfp_def:
    assumes "Monotonic F" "F \<in> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<mu> F = (\<mu> X \<bullet> F(\<H>(X)))"
  proof (rule antisym)
    have ne: "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<noteq> {}"
    proof -
      have "F \<^bold>\<top> \<sqsubseteq> \<^bold>\<top>"
        using assms(2) utp_top weak.top_closed by force
      thus ?thesis
        by (auto)
    qed
    show "\<^bold>\<mu> F \<sqsubseteq> (\<mu> X \<bullet> F (\<H> X))"
    proof -
      have "\<Sqinter>{P. (P is \<H>) \<and> F(P) \<sqsubseteq> P} \<sqsubseteq> \<Sqinter>{P. F(\<H>(P)) \<sqsubseteq> P}"
      proof -
        have 1: "\<And> P. F(\<H>(P)) = \<H>(F(\<H>(P)))"
          by (metis HCond_Idem Healthy_def assms(2) funcset_mem mem_Collect_eq)
        show ?thesis
        proof (rule Sup_least, auto)
          fix P
          assume a: "F (\<H> P) \<sqsubseteq> P"
          hence F: "(F (\<H> P)) \<sqsubseteq> (\<H> P)"
            by (metis 1 HCond_Mono mono_def)
          show "\<Sqinter>{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<sqsubseteq> P"
          proof (rule Sup_upper2[of "F (\<H> P)"])
            show "F (\<H> P) \<in> {P. (P is \<H>) \<and> F P \<sqsubseteq> P}"
            proof (auto)
              show "F (\<H> P) is \<H>"
                by (metis 1 Healthy_def)
              show "F (F (\<H> P)) \<sqsubseteq> F (\<H> P)"
                using F mono_def assms(1) by blast
            qed
            show "F (\<H> P) \<sqsubseteq> P"
              by (simp add: a)
          qed
        qed
      qed

      with ne show ?thesis
        by (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
    qed
    from ne show "(\<mu> X \<bullet> F (\<H> X)) \<sqsubseteq> \<^bold>\<mu> F"
      apply (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
      apply (rule Sup_least)
      apply (auto simp add: Healthy_def Sup_upper)
      done
  qed

  lemma UINF_ind_Healthy [closure]:
    assumes "\<And> i. P(i) is \<H>"
    shows "(\<Sqinter> i \<bullet> P(i)) is \<H>"
    by (simp add: closure assms)

end

text \<open> In another direction, we can also characterise UTP theories that are relational. Minimally
  this requires that the healthiness condition is closed under sequential composition. \<close>

locale utp_theory_rel =
  utp_theory hcond for hcond :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("\<H>") +
  assumes Healthy_Sequence [closure]: "\<lbrakk> P is \<H>; Q is \<H> \<rbrakk> \<Longrightarrow> (P ;; Q) is \<H>"
begin

lemma upower_Suc_Healthy [closure]:
  assumes "P is \<H>"
  shows "P \<^bold>^ Suc n is \<H>"
  by (induct n, simp_all add: closure assms upred_semiring.power_Suc)

end

locale utp_theory_cont_rel =
  utp_theory_rel hcond + utp_theory_continuous
begin

  lemma seq_cont_Sup_distl:
    assumes "P is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "P ;; (\<^bold>\<Sqinter> A) = \<^bold>\<Sqinter> {P ;; Q | Q. Q \<in> A }"
  proof -
    have "{P ;; Q | Q. Q \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distl setcompr_eq_image assms)
  qed

  lemma seq_cont_Sup_distr:
    assumes "Q is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "(\<^bold>\<Sqinter> A) ;; Q = \<^bold>\<Sqinter> {P ;; Q | P. P \<in> A }"
  proof -
    have "{P ;; Q | P. P \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distr setcompr_eq_image assms)
  qed

  lemma uplus_healthy [closure]:
    assumes "P is \<H>"
    shows "P\<^sup>+ is \<H>"
    by (simp add: uplus_power_def closure assms)

end

text \<open> There also exist UTP theories with units. Not all theories have both a left and a right unit
  (e.g. H1-H2 designs) and so we split up the locale into two cases. \<close>

locale utp_theory_units =
  utp_theory_rel +
  fixes utp_unit ("\<I>\<I>")
  assumes Healthy_Unit [closure]: "\<I>\<I> is \<H>"
begin

text \<open> We can characterise the theory Kleene star by lifting the relational one. \<close>

definition utp_star ("_\<^bold>\<star>" [999] 999) where
[upred_defs]: "utp_star P = (P\<^sup>\<star> ;; utp_unit)"

text \<open> We can then characterise tests as refinements of units. \<close>

definition utp_test :: "'a hrel \<Rightarrow> bool" where
[upred_defs]: "utp_test b = (\<I>\<I> \<sqsubseteq> b)"

end

locale utp_theory_left_unital =
  utp_theory_units +
  assumes Unit_Left: "P is \<H> \<Longrightarrow> (\<I>\<I> ;; P) = P"

locale utp_theory_right_unital =
  utp_theory_units +
  assumes Unit_Right: "P is \<H> \<Longrightarrow> (P ;; \<I>\<I>) = P"

locale utp_theory_unital =
  utp_theory_left_unital + utp_theory_right_unital
begin

lemma Unit_self [simp]:
  "\<I>\<I> ;; \<I>\<I> = \<I>\<I>"
  by (simp add: Healthy_Unit Unit_Right)

lemma utest_intro:
  "\<I>\<I> \<sqsubseteq> P \<Longrightarrow> utp_test P"
  by (simp add: utp_test_def)

lemma utest_Unit [closure]:
  "utp_test \<I>\<I>"
  by (simp add: utp_test_def)

end

locale utp_theory_mono_unital =
  utp_theory_unital \<H> \<I>\<I> + utp_theory_mono for \<I>\<I>
begin

lemma utest_Top [closure]: "utp_test \<^bold>\<top>"
  by (simp add: Healthy_Unit utp_test_def utp_top)

end

locale utp_theory_cont_unital = utp_theory_cont_rel + utp_theory_unital hcond
begin

sublocale utp_theory_mono_unital \<H> \<I>\<I>
  by (simp add: utp_theory_mono_axioms utp_theory_mono_unital_def utp_theory_unital_axioms)

end

locale utp_theory_unital_zerol =
  utp_theory_unital +
  utp_theory_lattice +
  assumes Top_Left_Zero: "P is \<H> \<Longrightarrow> \<^bold>\<top> ;; P = \<^bold>\<top>"

locale utp_theory_cont_unital_zerol =
  utp_theory_unital_zerol + utp_theory_cont_unital hcond utp_unit
begin

lemma Top_test_Right_Zero:
  assumes "b is \<H>" "utp_test b"
  shows "b ;; \<^bold>\<top> = \<^bold>\<top>"
proof -
  have "b \<sqinter> \<I>\<I> = \<I>\<I>"
    by (meson assms(2) semilattice_sup_class.le_iff_sup utp_test_def)
  then show ?thesis
    by (metis (no_types) Top_Left_Zero Unit_Left assms(1) meet_top top_healthy upred_semiring.distrib_right)
qed

end

subsection \<open> Theory of relations \<close>

interpretation rel_theory: utp_theory_mono_unital id skip_r
  rewrites "rel_theory.utp_top = false"
  and "rel_theory.utp_bottom = true"
  and "carrier (utp_order id) = UNIV"
  and "(P is id) = True"
proof -
  show "utp_theory_mono_unital id II"
    by (unfold_locales, simp_all add: Healthy_def)
  then interpret utp_theory_mono_unital id skip_r
    by simp
  show "utp_top = false" "utp_bottom = true"
    by (simp_all add: healthy_top healthy_bottom)
  show "carrier (utp_order id) = UNIV" "(P is id) = True"
    by (auto simp add: utp_order_def Healthy_def)
qed

subsection \<open> Theory links \<close>

text \<open> We can also describe links between theories, such a Galois connections and retractions,
  using the following notation. \<close>

definition mk_conn ("_ \<Leftarrow>\<langle>_,_\<rangle>\<Rightarrow> _" [90,0,0,91] 91) where
"H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2 \<equiv> \<lparr> orderA = utp_order H1, orderB = utp_order H2, lower = \<H>\<^sub>2, upper = \<H>\<^sub>1 \<rparr>"

lemma mk_conn_orderA [simp]: "\<X>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H1"
  by (simp add:mk_conn_def)

lemma mk_conn_orderB [simp]: "\<Y>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H2"
  by (simp add:mk_conn_def)

lemma mk_conn_lower [simp]:  "\<pi>\<^sub>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>1"
  by (simp add: mk_conn_def)

lemma mk_conn_upper [simp]:  "\<pi>\<^sup>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>2"
  by (simp add: mk_conn_def)

lemma galois_comp: "(H\<^sub>2 \<Leftarrow>\<langle>\<H>\<^sub>3,\<H>\<^sub>4\<rangle>\<Rightarrow> H\<^sub>3) \<circ>\<^sub>g (H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>2) = H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1\<circ>\<H>\<^sub>3,\<H>\<^sub>4\<circ>\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>3"
  by (simp add: comp_galcon_def mk_conn_def)

text \<open> Example Galois connection / retract: Existential quantification \<close>

lemma Idempotent_ex: "mwb_lens x \<Longrightarrow> Idempotent (ex x)"
  by (simp add: Idempotent_def exists_twice)

lemma Monotonic_ex: "mwb_lens x \<Longrightarrow> Monotonic (ex x)"
  by (simp add: mono_def ex_mono)

lemma ex_closed_unrest:
  "vwb_lens x \<Longrightarrow> \<lbrakk>ex x\<rbrakk>\<^sub>H = {P. x \<sharp> P}"
  by (simp add: Healthy_def unrest_as_exists)

text \<open> Any theory can be composed with an existential quantification to produce a Galois connection \<close>

theorem ex_retract:
  assumes "vwb_lens x" "Idempotent H" "ex x \<circ> H = H \<circ> ex x"
  shows "retract ((ex x \<circ> H) \<Leftarrow>\<langle>ex x, H\<rangle>\<Rightarrow> H)"
proof (unfold_locales, simp_all)
  show "H \<in> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
    using Healthy_Idempotent assms by blast
  from assms(1) assms(3)[THEN sym] show "ex x \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H"
    by (simp add: Pi_iff Healthy_def fun_eq_iff exists_twice)
  fix P Q
  assume "P is (ex x \<circ> H)" "Q is H"
  thus "(H P \<sqsubseteq> Q) = (P \<sqsubseteq> (\<exists> x \<bullet> Q))"
    by (metis (no_types, lifting) Healthy_Idempotent Healthy_if assms comp_apply dual_order.trans ex_weakens utp_pred_laws.ex_mono vwb_lens_wb)
next
  fix P
  assume "P is (ex x \<circ> H)"
  thus "(\<exists> x \<bullet> H P) \<sqsubseteq> P"
    by (simp add: Healthy_def)
qed

corollary ex_retract_id:
  assumes "vwb_lens x"
  shows "retract (ex x \<Leftarrow>\<langle>ex x, id\<rangle>\<Rightarrow> id)"
  using assms ex_retract[where H="id"] by (auto)
end


theory Network_View
imports Network
begin

text{*the view for a fixed packet header*}

section{*The view of a fixed packet*}
  text{*For a fixed packet with a fixed header, its global network view is defined.
        For any start interface the packet is set out, the interfaces the packet can go next is recoreded.

        Essentially, view is a relation or the edges of a graph. This graph describes how the packet can move.
          The forwarding (and transfer) function is removed, the packet can directly move along the edges!

        It is the view a packet has from the network.
        *}
  definition view :: "'v network \<Rightarrow> 'v hdr \<Rightarrow> (('v interface) \<times> ('v interface)) set" where
    "view N hdr = {(src, dst). src \<in> interfaces N \<and> dst \<in> traverse N hdr src}"

  text{*Alternative definition of view: For all interfaces in the network, collect the next hops. *}
  lemma view_alt: "view N hdr = (\<Union>src \<in> interfaces N. {src} \<times> traverse N hdr src)"
    apply(simp add: view_def)
    apply(rule)
    apply blast
    apply(rule)
    by(clarify)

 lemma view_subseteq_interfaces_x_interfaces: assumes wf_N: "wellformed_network N"
    shows "view N hdr \<subseteq> interfaces N \<times> interfaces N"
    apply(simp add: view_alt)
    using traverse_subseteq_interfaces[OF wf_N] by blast

  lemma view_finite: assumes wf_N: "wellformed_network N"
    shows "finite (view N hdr)"
    apply(simp add: view_alt)
    apply(subst finite_UN[OF wellformed_network.finite_interfaces[OF wf_N]])
    apply(clarify)
    apply(rule finite_cartesian_product)
    apply simp
    using traverse_finite[OF wf_N] by simp
  lemma finite_view_trancl: assumes wf_N: "wellformed_network N" shows "finite ((view N hdr)\<^sup>+)"
    using view_finite[OF wf_N] finite_trancl by simp

  text{*The (bounded) reflexive transitive closure*}
  (*In isabelle, saying only ^* would be transitive closure plus all reflexive elementes of type 'v interface. We only want all (interface N).
    For infinite types, ^* is infinite as it contains ALL {(a,a) | a of tpye}*)
  definition view_rtrancl :: "'v network \<Rightarrow> 'v hdr \<Rightarrow> (('v interface) \<times> ('v interface)) set" where
    "view_rtrancl N hdr \<equiv> {(src,dst). src \<in> interfaces N \<and> dst \<in> interfaces N \<and> (src, dst) \<in> (view N hdr)\<^sup>*}"

  lemma assumes wf_N: "wellformed_network N" shows "finite (view_rtrancl N hdr)"
    proof -
      have "{(src,dst). src \<in> interfaces N \<and> dst \<in> interfaces N \<and> (src, dst) \<in> (view N hdr)\<^sup>*} \<subseteq> interfaces N \<times> interfaces N" by blast
      thus ?thesis using wellformed_network.finite_interfaces[OF wf_N] unfolding view_rtrancl_def by (metis (lifting, no_types) finite_SigmaI rev_finite_subset)
    qed

  lemma view_rtrancl_alt:
    assumes wf_N: "wellformed_network N" shows "view_rtrancl N hdr = (view N hdr)\<^sup>+ \<union> {(a,a) | a . a \<in> interfaces N}"
    unfolding view_rtrancl_def
    apply(rule equalityI)
    apply(clarify)
    apply (metis rtranclD)
    (* r to l*)
    apply(clarify)
    apply(rule)
    apply(erule Set.UnE)
    using view_subseteq_interfaces_x_interfaces[OF wf_N] apply (metis SigmaE2 converse_tranclE trancl_mono)
    apply fastforce
    apply(rule)
    apply(erule Set.UnE)
    using view_subseteq_interfaces_x_interfaces[OF wf_N] apply (metis mem_Sigma_iff r_into_trancl' subsetI subset_antisym trancl_mono trancl_subset_Sigma)
    apply fastforce
    apply(erule Set.UnE)
    apply(simp)
    apply(simp)
    done

  lemma start_view_rtrancl:
    assumes wf_N: "wellformed_network N"
    shows "{dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*} = (\<Union> first_hop \<in> succ N start. {dst. (first_hop, dst) \<in> (view N hdr)\<^sup>+}) \<union> (succ N start)" (is "?LHS = ?RHS")
    proof -
      have view_interfaces: "(view N hdr) `` (interfaces N) \<subseteq> (interfaces N)"
        using view_subseteq_interfaces_x_interfaces[OF wf_N] by blast
      have "?LHS \<subseteq> interfaces N"
        apply(auto)
        using succ_subseteq_interfaces[OF wf_N] Image_closed_trancl[OF view_interfaces] by auto
      have "?LHS = {dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> view_rtrancl N hdr}"
        apply(simp add: view_rtrancl_def)
        apply(rule Set.Collect_cong)
        apply(rule iffI)
        apply(erule bexE)
        apply(rule_tac x="first_hop" in bexI)
        apply(rule)
        using succ_subseteq_interfaces[OF wf_N] apply blast
        apply(rule)
        using `?LHS \<subseteq> interfaces N` apply blast
        apply(simp_all)
        apply(erule bexE)
        apply(rule_tac x="first_hop" in bexI)
        by(simp_all)
      also have "\<dots> = {dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>+} \<union> (succ N start)"
        apply(subst view_rtrancl_alt[OF wf_N])
        apply(rule)
        apply fastforce
        apply(rule)
        apply(simp)
        apply(erule disjE)
        apply(erule bexE)
        apply(rule_tac x="first_hop" in bexI)
        apply(simp_all)
        apply(rule_tac x="x" in bexI)
        apply(simp_all)
        using succ_subseteq_interfaces[OF wf_N] by blast
      also have "\<dots> = (\<Union> first_hop \<in> succ N start. {dst. (first_hop, dst) \<in> (view N hdr)\<^sup>+}) \<union> (succ N start)"
        by(simp add: Complete_Lattices.Collect_bex_eq)
     finally show "?LHS = ?RHS" .
   qed
  (*lemma star_view_rtrancl:
    assumes wf_N: "wellformed_network N"
    and     start_iface: "start \<in> interfaces N"
    shows "{dst. (start, dst) \<in> (view N hdr)\<^sup>*} = {dst. (start, dst) \<in> (view N hdr)\<^sup>+} \<union> {start}" (is "?LHS = ?RHS")
    proof -
      have "?LHS = {dst. (start, dst) \<in> view_rtrancl N hdr}"
        unfolding view_rtrancl_def
        apply(simp)
        apply(auto simp add: start_iface)
        using view_subseteq_interfaces_x_interfaces[OF wf_N] by (metis Image_closed_trancl Image_subset rev_ImageI start_iface)
      also have "{dst. (start, dst) \<in> view_rtrancl N hdr} = ?RHS"
       apply(subst view_rtrancl_alt[OF wf_N])
       apply(rule)
       apply fastforce
       apply(rule)
       apply(simp)
       using start_iface apply fastforce
       done
     finally show "?LHS = ?RHS" .
   qed*)

section{*Reachable and view*}
  text{*intuitive reachable definition and defining reachability by the rtrancl over the view relation is equal. *}
  theorem reachable_eq_rtrancl_view:
      assumes wf_N: "wellformed_network N"
      shows "reachable N hdr start = {dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*}"
    proof(rule equalityI)
      show "reachable N hdr start \<subseteq> {dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*}"
        proof(rule, simp)
          fix x show "x \<in> reachable N hdr start \<Longrightarrow> \<exists>first_hop\<in>succ N start. (first_hop, x) \<in> (view N hdr)\<^sup>*"
            proof(induction x rule:reachable_induct)
              case(Start first_hop)
                hence "first_hop\<in>succ N start \<and> (first_hop, first_hop) \<in> (view N hdr)\<^sup>*" by(simp add: view_def)
                thus ?case by blast
            next
              case(Step hop next_hop)
                from reachable_subseteq_interfaces[OF wf_N] Step(1) have "hop \<in> interfaces N" by blast
                hence  "(hop, next_hop) \<in> {(src, dst). src \<in> interfaces N \<and> dst \<in> traverse N hdr src}"
                  by(simp add: Step(2))
                hence  next_rtran: "(hop, next_hop) \<in> view N hdr"
                  by(simp add: view_def)
                from Step(3) obtain first_hop where "first_hop\<in>succ N start" and first_rtran: "(first_hop, hop) \<in> (view N hdr)\<^sup>*" by blast
                from `first_hop\<in>succ N start` rtrancl.rtrancl_into_rtrancl[OF first_rtran next_rtran]
                show ?case by blast
            qed
       qed
    next
    show "{dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*} \<subseteq> reachable N hdr start"
      proof(rule, clarify)
        fix x first_hop
        assume "first_hop \<in> succ N start"
        show "(first_hop, x) \<in> (view N hdr)\<^sup>* \<Longrightarrow> x \<in> reachable N hdr start"
          proof(induction rule: rtrancl_induct)
            case base
              thus ?case using reachable.intros(1) `first_hop \<in> succ N start` .
            case(step y z)
              thus ?case by(auto intro: reachable.intros(2) simp add: view_def)
            qed
          qed
   qed
  text{*reachability is exactly:
    the first hop plus everything that can be transitively reached via the first hop. *}
  corollary reachable_eq_rtrancl_view2:
   "\<lbrakk> wellformed_network N \<rbrakk> \<Longrightarrow> reachable N hdr start = (\<Union> first_hop \<in> succ N start. {dst. (first_hop, dst) \<in> (view N hdr)\<^sup>+}) \<union> (succ N start)"
   by(simp add: reachable_eq_rtrancl_view start_view_rtrancl)

  text{*Different versions to express reachability using (succ N start) under the packet view relation*}
  corollary reachable_eq_rtrancl_view3:
   "\<lbrakk> wellformed_network N \<rbrakk> \<Longrightarrow> reachable N hdr start = ((view N hdr)\<^sup>+``(succ N start)) \<union> (succ N start)"
   using reachable_eq_rtrancl_view2 by blast
  corollary reachable_eq_rtrancl_view4:
   "\<lbrakk> wellformed_network N \<rbrakk> \<Longrightarrow> reachable N hdr start = (view N hdr)\<^sup>*``(succ N start)"
   using reachable_eq_rtrancl_view by blast

subsection{*About reachability*}
  text{*With the view, a property of reachability can be shown*}
  lemma reachable_subset_start_iff:
    assumes wf_N: "wellformed_network N"
    shows "reachable N hdr start \<subseteq> succ N start \<longleftrightarrow> (\<forall>first_hop \<in> succ N start. traverse N hdr first_hop \<subseteq> succ N start)"
    proof
      assume only_reach_succ: "reachable N hdr start \<subseteq> succ N start"
      show "\<forall>first_hop\<in>succ N start. traverse N hdr first_hop \<subseteq> succ N start"
        proof
        fix first_hop
        assume f: "first_hop \<in> succ N start"
        from only_reach_succ have reach_eq_succ: "reachable N hdr start = succ N start"
          using succ_subseteq_reachable by fast

        have view_dst_simp: "\<And> first_hop. {dst. first_hop \<in> interfaces N \<and> dst \<in> traverse N hdr first_hop} =
          {dst \<in> (\<Union>p\<in>forward N hdr first_hop. succ N \<lparr>entity = entity first_hop, port = p\<rparr>). first_hop \<in> interfaces N}"
          by(simp only: traverse_def, blast)

        have "{dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*} =
            (\<Union> first_hop \<in> succ N start. {dst. (first_hop, dst) \<in> (view N hdr)\<^sup>*})" by blast

        from this reach_eq_succ f have "{dst. (first_hop, dst) \<in> (view N hdr)\<^sup>*} \<subseteq> succ N start"
          using reachable_eq_rtrancl_view[OF wf_N] by auto

        hence "{dst. (first_hop, dst) \<in> (view N hdr)} \<subseteq> succ N start" using f  by blast
        hence "(\<Union>p\<in>forward N hdr first_hop. succ N \<lparr>entity = entity first_hop, port = p\<rparr>) \<subseteq> succ N start" using f
          apply(simp add: view_def)
          apply(simp only: view_dst_simp)
          by (metis reach_eq_succ reachable.simps subsetI traverse_def)
        thus "traverse N hdr first_hop \<subseteq> succ N start"
          by(simp add: traverse_def)
        qed
      next
      assume only_traverse_succ: "\<forall>first_hop \<in> succ N start. traverse N hdr first_hop \<subseteq> succ N start"
      {
        fix x
        have "x \<in> reachable N hdr start \<Longrightarrow> x \<in> succ N start"
        proof(induction rule: reachable_induct)
          case Start thus ?case by simp
          next
          case Step thus ?case using only_traverse_succ by fast
        qed
      }
      thus "reachable N hdr start \<subseteq> succ N start" by blast
    qed

  lemma reachable_subseteq_X_imp:
    assumes wf_N: "wellformed_network N"
    and only_reach_succ: "reachable N hdr start \<subseteq> X"
    shows "\<forall>first_hop \<in> succ N start. traverse N hdr first_hop \<subseteq> X"
      proof (*TODO*)
      fix first_hop
      assume f: "first_hop \<in> succ N start"
      from only_reach_succ have reach_eq_succ: "succ N start \<subseteq> X"
        using Network.succ_subseteq_reachable by fast

      have view_dst_simp: "\<And> first_hop. {dst. first_hop \<in> interfaces N \<and> dst \<in> traverse N hdr first_hop} =
        {dst \<in> (\<Union>p\<in>forward N hdr first_hop. succ N \<lparr>entity = entity first_hop, port = p\<rparr>). first_hop \<in> interfaces N}"
        by(simp only: traverse_def, blast)

      have "{dst. \<exists>first_hop \<in> succ N start. (first_hop, dst) \<in> (view N hdr)\<^sup>*} =
          (\<Union> first_hop \<in> succ N start. {dst. (first_hop, dst) \<in> (view N hdr)\<^sup>*})" by blast

      from this f only_reach_succ have "{dst. (first_hop, dst) \<in> (view N hdr)\<^sup>*} \<subseteq> X"
        using reachable_eq_rtrancl_view[OF wf_N] by auto

      hence "{dst. (first_hop, dst) \<in> (view N hdr)} \<subseteq> X" using f  by blast
      hence "(\<Union>p\<in>forward N hdr first_hop. succ N \<lparr>entity = entity first_hop, port = p\<rparr>) \<subseteq> X" using f
        apply(simp add: view_def)
        apply(simp only: view_dst_simp)
        by (smt in_mono mem_Collect_eq subsetI succ_subseteq_interfaces wf_N)
      thus "traverse N hdr first_hop \<subseteq> X"
        by(simp add: traverse_def)
    qed

end


(*  Title:      ZF/Finite.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

prove:  b \<in> Fin(A) ==> inj(b,b) \<subseteq> surj(b,b)
*)

section{*Finite Powerset Operator and Finite Function Space*}

theory Finite imports Inductive_ZF Epsilon Nat_ZF begin

(*The natural numbers as a datatype*)
rep_datatype
  elimination    natE
  induction      nat_induct
  case_eqns      nat_case_0 nat_case_succ
  recursor_eqns  recursor_0 recursor_succ

consts
  Fin       :: "i=>i"
  FiniteFun :: "[i,i]=>i"         ("(_ -||>/ _)" [61, 60] 60)

inductive
  domains   "Fin(A)" \<subseteq> "Pow(A)"
  intros
    emptyI:  "0 \<in> Fin(A)"
    consI:   "[| a \<in> A;  b \<in> Fin(A) |] ==> cons(a,b) \<in> Fin(A)"
  type_intros  empty_subsetI cons_subsetI PowI
  type_elims   PowD [elim_format]

inductive
  domains   "FiniteFun(A,B)" \<subseteq> "Fin(A*B)"
  intros
    emptyI:  "0 \<in> A -||> B"
    consI:   "[| a \<in> A;  b \<in> B;  h \<in> A -||> B;  a \<notin> domain(h) |]
              ==> cons(<a,b>,h) \<in> A -||> B"
  type_intros Fin.intros

subsection {* Finite Powerset Operator *}

lemma Fin_mono: "A<=B ==> Fin(A) \<subseteq> Fin(B)"
apply (unfold Fin.defs)
apply (rule lfp_mono)
apply (rule Fin.bnd_mono)+
apply blast
done

(* @{term"A \<in> Fin(B) ==> A \<subseteq> B"} *)
lemmas FinD = Fin.dom_subset [THEN subsetD, THEN PowD]

(** Induction on finite sets **)

(*Discharging @{term"x\<notin>y"} entails extra work*)
lemma Fin_induct [case_names 0 cons, induct set: Fin]:
    "[| b \<in> Fin(A);
        P(0);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x\<notin>y;  P(y) |] ==> P(cons(x,y))
     |] ==> P(b)"
apply (erule Fin.induct, simp)
apply (case_tac "a \<in> b")
 apply (erule cons_absorb [THEN ssubst], assumption) (*backtracking!*)
apply simp
done

(** Simplification for Fin **)
declare Fin.intros [simp]

lemma Fin_0: "Fin(0) = {0}"
by (blast intro: Fin.emptyI dest: FinD)

(*The union of two finite sets is finite.*)
lemma Fin_UnI [simp]: "[| b \<in> Fin(A);  c \<in> Fin(A) |] ==> b \<union> c \<in> Fin(A)"
apply (erule Fin_induct)
apply (simp_all add: Un_cons)
done

(*The union of a set of finite sets is finite.*)
lemma Fin_UnionI: "C \<in> Fin(Fin(A)) ==> \<Union>(C) \<in> Fin(A)"
by (erule Fin_induct, simp_all)

(*Every subset of a finite set is finite.*)
lemma Fin_subset_lemma [rule_format]: "b \<in> Fin(A) ==> \<forall>z. z<=b \<longrightarrow> z \<in> Fin(A)"
apply (erule Fin_induct)
apply (simp add: subset_empty_iff)
apply (simp add: subset_cons_iff distrib_simps, safe)
apply (erule_tac b = z in cons_Diff [THEN subst], simp)
done

lemma Fin_subset: "[| c<=b;  b \<in> Fin(A) |] ==> c \<in> Fin(A)"
by (blast intro: Fin_subset_lemma)

lemma Fin_IntI1 [intro,simp]: "b \<in> Fin(A) ==> b \<inter> c \<in> Fin(A)"
by (blast intro: Fin_subset)

lemma Fin_IntI2 [intro,simp]: "c \<in> Fin(A) ==> b \<inter> c \<in> Fin(A)"
by (blast intro: Fin_subset)

lemma Fin_0_induct_lemma [rule_format]:
    "[| c \<in> Fin(A);  b \<in> Fin(A); P(b);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y) |] ==> P(y-{x})
     |] ==> c<=b \<longrightarrow> P(b-c)"
apply (erule Fin_induct, simp)
apply (subst Diff_cons)
apply (simp add: cons_subset_iff Diff_subset [THEN Fin_subset])
done

lemma Fin_0_induct:
    "[| b \<in> Fin(A);
        P(b);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y) |] ==> P(y-{x})
     |] ==> P(0)"
apply (rule Diff_cancel [THEN subst])
apply (blast intro: Fin_0_induct_lemma)
done

(*Functions from a finite ordinal*)
lemma nat_fun_subset_Fin: "n \<in> nat ==> n->A \<subseteq> Fin(nat*A)"
apply (induct_tac "n")
apply (simp add: subset_iff)
apply (simp add: succ_def mem_not_refl [THEN cons_fun_eq])
apply (fast intro!: Fin.consI)
done

subsection{*Finite Function Space*}

lemma FiniteFun_mono:
    "[| A<=C;  B<=D |] ==> A -||> B  \<subseteq>  C -||> D"
apply (unfold FiniteFun.defs)
apply (rule lfp_mono)
apply (rule FiniteFun.bnd_mono)+
apply (intro Fin_mono Sigma_mono basic_monos, assumption+)
done

lemma FiniteFun_mono1: "A<=B ==> A -||> A  \<subseteq>  B -||> B"
by (blast dest: FiniteFun_mono)

lemma FiniteFun_is_fun: "h \<in> A -||>B ==> h \<in> domain(h) -> B"
apply (erule FiniteFun.induct, simp)
apply (simp add: fun_extend3)
done

lemma FiniteFun_domain_Fin: "h \<in> A -||>B ==> domain(h) \<in> Fin(A)"
by (erule FiniteFun.induct, simp, simp)

lemmas FiniteFun_apply_type = FiniteFun_is_fun [THEN apply_type]

(*Every subset of a finite function is a finite function.*)
lemma FiniteFun_subset_lemma [rule_format]:
     "b \<in> A-||>B ==> \<forall>z. z<=b \<longrightarrow> z \<in> A-||>B"
apply (erule FiniteFun.induct)
apply (simp add: subset_empty_iff FiniteFun.intros)
apply (simp add: subset_cons_iff distrib_simps, safe)
apply (erule_tac b = z in cons_Diff [THEN subst])
apply (drule spec [THEN mp], assumption)
apply (fast intro!: FiniteFun.intros)
done

lemma FiniteFun_subset: "[| c<=b;  b \<in> A-||>B |] ==> c \<in> A-||>B"
by (blast intro: FiniteFun_subset_lemma)

(** Some further results by Sidi O. Ehmety **)

lemma fun_FiniteFunI [rule_format]: "A \<in> Fin(X) ==> \<forall>f. f \<in> A->B \<longrightarrow> f \<in> A-||>B"
apply (erule Fin.induct)
 apply (simp add: FiniteFun.intros, clarify)
apply (case_tac "a \<in> b")
 apply (simp add: cons_absorb)
apply (subgoal_tac "restrict (f,b) \<in> b -||> B")
 prefer 2 apply (blast intro: restrict_type2)
apply (subst fun_cons_restrict_eq, assumption)
apply (simp add: restrict_def lam_def)
apply (blast intro: apply_funtype FiniteFun.intros
                    FiniteFun_mono [THEN [2] rev_subsetD])
done

lemma lam_FiniteFun: "A \<in> Fin(X) ==> (\<lambda>x\<in>A. b(x)) \<in> A -||> {b(x). x \<in> A}"
by (blast intro: fun_FiniteFunI lam_funtype)

lemma FiniteFun_Collect_iff:
     "f \<in> FiniteFun(A, {y \<in> B. P(y)})
      \<longleftrightarrow> f \<in> FiniteFun(A,B) & (\<forall>x\<in>domain(f). P(f`x))"
apply auto
apply (blast intro: FiniteFun_mono [THEN [2] rev_subsetD])
apply (blast dest: Pair_mem_PiD FiniteFun_is_fun)
apply (rule_tac A1="domain(f)" in
       subset_refl [THEN [2] FiniteFun_mono, THEN subsetD])
 apply (fast dest: FiniteFun_domain_Fin Fin.dom_subset [THEN subsetD])
apply (rule fun_FiniteFunI)
apply (erule FiniteFun_domain_Fin)
apply (rule_tac B = "range (f) " in fun_weaken_type)
 apply (blast dest: FiniteFun_is_fun range_of_fun range_type apply_equality)+
done

subsection{*The Contents of a Singleton Set*}

definition
  contents :: "i=>i"  where
   "contents(X) == THE x. X = {x}"

lemma contents_eq [simp]: "contents ({x}) = x"
by (simp add: contents_def)

end


(*  Title:      ZF/Constructible/Wellorderings.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Relativized Wellorderings\<close>

theory Wellorderings imports Relative begin

text\<open>We define functions analogous to \<^term>\<open>ordermap\<close> \<^term>\<open>ordertype\<close>
      but without using recursion.  Instead, there is a direct appeal
      to Replacement.  This will be the basis for a version relativized
      to some class \<open>M\<close>.  The main result is Theorem I 7.6 in Kunen,
      page 17.\<close>

subsection\<open>Wellorderings\<close>

definition
  irreflexive :: "[i=>o,i,i]=>o" where
    "irreflexive(M,A,r) == \<forall>x[M]. x\<in>A \<longrightarrow> <x,x> \<notin> r"

definition
  transitive_rel :: "[i=>o,i,i]=>o" where
    "transitive_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> (\<forall>z[M]. z\<in>A \<longrightarrow>
                          <x,y>\<in>r \<longrightarrow> <y,z>\<in>r \<longrightarrow> <x,z>\<in>r))"

definition
  linear_rel :: "[i=>o,i,i]=>o" where
    "linear_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> <x,y>\<in>r | x=y | <y,x>\<in>r)"

definition
  wellfounded :: "[i=>o,i]=>o" where
    \<comment> \<open>EVERY non-empty set has an \<open>r\<close>-minimal element\<close>
    "wellfounded(M,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"
definition
  wellfounded_on :: "[i=>o,i,i]=>o" where
    \<comment> \<open>every non-empty SUBSET OF \<open>A\<close> has an \<open>r\<close>-minimal element\<close>
    "wellfounded_on(M,A,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> x\<subseteq>A \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"

definition
  wellordered :: "[i=>o,i,i]=>o" where
    \<comment> \<open>linear and wellfounded on \<open>A\<close>\<close>
    "wellordered(M,A,r) ==
        transitive_rel(M,A,r) & linear_rel(M,A,r) & wellfounded_on(M,A,r)"

subsubsection \<open>Trivial absoluteness proofs\<close>

lemma (in M_basic) irreflexive_abs [simp]:
     "M(A) ==> irreflexive(M,A,r) \<longleftrightarrow> irrefl(A,r)"
by (simp add: irreflexive_def irrefl_def)

lemma (in M_basic) transitive_rel_abs [simp]:
     "M(A) ==> transitive_rel(M,A,r) \<longleftrightarrow> trans[A](r)"
by (simp add: transitive_rel_def trans_on_def)

lemma (in M_basic) linear_rel_abs [simp]:
     "M(A) ==> linear_rel(M,A,r) \<longleftrightarrow> linear(A,r)"
by (simp add: linear_rel_def linear_def)

lemma (in M_basic) wellordered_is_trans_on:
    "[| wellordered(M,A,r); M(A) |] ==> trans[A](r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_linear:
    "[| wellordered(M,A,r); M(A) |] ==> linear(A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_wellfounded_on:
    "[| wellordered(M,A,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellfounded_imp_wellfounded_on:
    "[| wellfounded(M,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellfounded_def wellfounded_on_def)

lemma (in M_basic) wellfounded_on_subset_A:
     "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (simp add: wellfounded_on_def, blast)

subsubsection \<open>Well-founded relations\<close>

lemma  (in M_basic) wellfounded_on_iff_wellfounded:
     "wellfounded_on(M,A,r) \<longleftrightarrow> wellfounded(M, r \<inter> A*A)"
apply (simp add: wellfounded_on_def wellfounded_def, safe)
 apply force
apply (drule_tac x=x in rspec, assumption, blast)
done

lemma (in M_basic) wellfounded_on_imp_wellfounded:
     "[|wellfounded_on(M,A,r); r \<subseteq> A*A|] ==> wellfounded(M,r)"
by (simp add: wellfounded_on_iff_wellfounded subset_Int_iff)

lemma (in M_basic) wellfounded_on_field_imp_wellfounded:
     "wellfounded_on(M, field(r), r) ==> wellfounded(M,r)"
by (simp add: wellfounded_def wellfounded_on_iff_wellfounded, fast)

lemma (in M_basic) wellfounded_iff_wellfounded_on_field:
     "M(r) ==> wellfounded(M,r) \<longleftrightarrow> wellfounded_on(M, field(r), r)"
by (blast intro: wellfounded_imp_wellfounded_on
                 wellfounded_on_field_imp_wellfounded)

(*Consider the least z in domain(r) such that P(z) does not hold...*)
lemma (in M_basic) wellfounded_induct:
     "[| wellfounded(M,r); M(a); M(r); separation(M, \<lambda>x. ~P(x));
         \<forall>x. M(x) & (\<forall>y. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_def)
apply (drule_tac x="{z \<in> domain(r). ~P(z)}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellfounded_on_induct:
     "[| a\<in>A;  wellfounded_on(M,A,r);  M(A);
       separation(M, \<lambda>x. x\<in>A \<longrightarrow> ~P(x));
       \<forall>x\<in>A. M(x) & (\<forall>y\<in>A. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_on_def)
apply (drule_tac x="{z\<in>A. z\<in>A \<longrightarrow> ~P(z)}" in rspec)
apply (blast intro: transM)+
done

subsubsection \<open>Kunen's lemma IV 3.14, page 123\<close>

lemma (in M_basic) linear_imp_relativized:
     "linear(A,r) ==> linear_rel(M,A,r)"
by (simp add: linear_def linear_rel_def)

lemma (in M_basic) trans_on_imp_relativized:
     "trans[A](r) ==> transitive_rel(M,A,r)"
by (unfold transitive_rel_def trans_on_def, blast)

lemma (in M_basic) wf_on_imp_relativized:
     "wf[A](r) ==> wellfounded_on(M,A,r)"
apply (simp add: wellfounded_on_def wf_def wf_on_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) wf_imp_relativized:
     "wf(r) ==> wellfounded(M,r)"
apply (simp add: wellfounded_def wf_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) well_ord_imp_relativized:
     "well_ord(A,r) ==> wellordered(M,A,r)"
by (simp add: wellordered_def well_ord_def tot_ord_def part_ord_def
       linear_imp_relativized trans_on_imp_relativized wf_on_imp_relativized)

text\<open>The property being well founded (and hence of being well ordered) is not absolute:
the set that doesn't contain a minimal element may not exist in the class M.
However, every set that is well founded in a transitive model M is well founded (page 124).\<close>

subsection\<open>Relativized versions of order-isomorphisms and order types\<close>

lemma (in M_basic) order_isomorphism_abs [simp]:
     "[| M(A); M(B); M(f) |]
      ==> order_isomorphism(M,A,r,B,s,f) \<longleftrightarrow> f \<in> ord_iso(A,r,B,s)"
by (simp add: order_isomorphism_def ord_iso_def)

lemma (in M_basic) pred_set_abs [simp]:
     "[| M(r); M(B) |] ==> pred_set(M,A,x,r,B) \<longleftrightarrow> B = Order.pred(A,x,r)"
apply (simp add: pred_set_def Order.pred_def)
apply (blast dest: transM)
done

lemma (in M_basic) pred_closed [intro,simp]:
     "[| M(A); M(r); M(x) |] ==> M(Order.pred(A,x,r))"
apply (simp add: Order.pred_def)
apply (insert pred_separation [of r x], simp)
done

lemma (in M_basic) membership_abs [simp]:
     "[| M(r); M(A) |] ==> membership(M,A,r) \<longleftrightarrow> r = Memrel(A)"
apply (simp add: membership_def Memrel_def, safe)
  apply (rule equalityI)
   apply clarify
   apply (frule transM, assumption)
   apply blast
  apply clarify
  apply (subgoal_tac "M(<xb,ya>)", blast)
  apply (blast dest: transM)
 apply auto
done

lemma (in M_basic) M_Memrel_iff:
     "M(A) ==>
      Memrel(A) = {z \<in> A*A. \<exists>x[M]. \<exists>y[M]. z = \<langle>x,y\<rangle> & x \<in> y}"
apply (simp add: Memrel_def)
apply (blast dest: transM)
done

lemma (in M_basic) Memrel_closed [intro,simp]:
     "M(A) ==> M(Memrel(A))"
apply (simp add: M_Memrel_iff)
apply (insert Memrel_separation, simp)
done

subsection \<open>Main results of Kunen, Chapter 1 section 6\<close>

text\<open>Subset properties-- proved outside the locale\<close>

lemma linear_rel_subset:
    "[| linear_rel(M,A,r);  B<=A |] ==> linear_rel(M,B,r)"
by (unfold linear_rel_def, blast)

lemma transitive_rel_subset:
    "[| transitive_rel(M,A,r);  B<=A |] ==> transitive_rel(M,B,r)"
by (unfold transitive_rel_def, blast)

lemma wellfounded_on_subset:
    "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (unfold wellfounded_on_def subset_def, blast)

lemma wellordered_subset:
    "[| wellordered(M,A,r);  B<=A |] ==> wellordered(M,B,r)"
apply (unfold wellordered_def)
apply (blast intro: linear_rel_subset transitive_rel_subset
                    wellfounded_on_subset)
done

lemma (in M_basic) wellfounded_on_asym:
     "[| wellfounded_on(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
apply (simp add: wellfounded_on_def)
apply (drule_tac x="{x,a}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellordered_asym:
     "[| wellordered(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
by (simp add: wellordered_def, blast dest: wellfounded_on_asym)

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Vectors\<close>

theory Relation_Algebra_Vectors
  imports Relation_Algebra
begin

text \<open>Vectors can be used for modelling sets of states. In this section we
follow Maddux's book to derive some of their most important properties.\<close>

context relation_algebra
begin

definition is_vector :: "'a \<Rightarrow> bool"
  where "is_vector x \<equiv> x = x ; 1"

lemma vector_compl: "is_vector x \<Longrightarrow> is_vector (-x)"
by (metis one_compl is_vector_def)

lemma vector_add: "\<lbrakk>is_vector x; is_vector y\<rbrakk> \<Longrightarrow> is_vector (x + y)"
by (metis comp_distr is_vector_def)

lemma vector_mult: "\<lbrakk>is_vector x; is_vector y\<rbrakk> \<Longrightarrow> is_vector (x \<cdot> y)"
by (metis ra_1 is_vector_def)

lemma vector_comp: "\<lbrakk>is_vector x; is_vector y\<rbrakk> \<Longrightarrow> is_vector (x ; y)"
by (metis comp_assoc is_vector_def)

lemma vector_1: "is_vector x \<Longrightarrow> (x \<cdot> y) ; z = x \<cdot> y ; z"
by (metis inf.commute ra_1 is_vector_def)

lemma vector_1_comm: "is_vector y \<Longrightarrow> (x \<cdot> y) ; z = x ; z \<cdot> y"
by (metis ra_1 is_vector_def)

lemma vector_2_var: "is_vector y \<Longrightarrow> (x \<cdot> y\<^sup>\<smile>) ; z = (x \<cdot> y\<^sup>\<smile>) ; (y \<cdot> z)"
by (metis inf.left_idem vector_2)

lemma vector_idem [simp]: "is_vector x \<Longrightarrow> x ; x = x"
by (metis inf_absorb2 inf_top_left maddux_21 vector_1_comm)

lemma vector_rectangle [simp]: "is_vector x \<Longrightarrow> x ; 1 ; x = x"
by (metis vector_idem is_vector_def)

lemma vector_3 [simp]: "is_vector x \<Longrightarrow> (x \<cdot> 1') ; y = x \<cdot> y"
by (metis inf.commute mult.left_neutral vector_1)

end (* relation_algebra *)

end