(* 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>
*)

header {* Models of Relation Algebra *}

theory Relation_Algebra_Models
  imports Relation_Algebra "../Kleene_Algebra/Inf_Matrix"
begin

text {* We formalise two models. First we show the obvious: binary relations
form a relation algebra. Then we show that infinite matrices (which we
formalised originally for Kleene algebras) form models of relation algebra if
we restrict their element type to @{typ bool}. *}

subsection {* Binary Relations *}

text {* Since Isabelle's libraries for binary relations are very well
developed, the proof for this model is entirely trivial. *}

interpretation rel_relation_algebra: relation_algebra "op -" uminus "op \<inter>" "op \<subseteq>" "op \<subset>" "op \<union>" "{}" UNIV "op O" Relation.converse Id
by unfold_locales auto

subsection {* Infinite Boolean Matrices *}

text {* Next we consider infinite Boolean matrices. We define the maximal
Boolean matrix (all of its entries are @{const True}), the converse or
transpose of a matrix, the intersection of two Boolean matrices and the
complement of a Boolean matrix. *}

definition mat_top :: "('a, 'b, bool) matrix" ("\<tau>")
  where "\<tau> i j \<equiv> True"

definition mat_transpose :: "('a, 'b, 'c) matrix \<Rightarrow> ('b, 'a, 'c) matrix" ("_\<^sup>\<dagger>" [101] 100)
  where "f\<^sup>\<dagger> \<equiv> (\<lambda>i j. f j i)"

definition mat_inter :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" (infixl "\<sqinter>" 70)
  where "f \<sqinter> g \<equiv> (\<lambda>i j. f i j \<cdot> g i j)"

definition mat_complement :: "('a, 'b, bool) matrix \<Rightarrow> ('a, 'b, bool) matrix" ("_\<^sup>c" [101] 100)
  where "f\<^sup>c = (\<lambda>i j. - f i j)"

text {* Next we show that the Booleans form a dioid. We state this as an
\emph{instantiation} result. The Kleene algebra files contain an
\emph{interpretation} proof, which is not sufficient for our purposes. *}

instantiation bool :: dioid_one_zero
begin

  definition zero_bool_def:
    "zero_bool \<equiv> False"

  definition one_bool_def:
    "one_bool \<equiv> True"

  definition times_bool_def:
    "times_bool \<equiv> op \<and>"

  definition plus_bool_def:
    "plus_bool \<equiv> op \<or>"

  instance
  by default (auto simp: plus_bool_def times_bool_def one_bool_def zero_bool_def)

end

text {* We now show that infinite Boolean matrices form a Boolean algebra. *}

lemma le_funI2: "(\<And>i j. f i j \<le> g i j) \<Longrightarrow> f \<le> g"
by (metis le_funI)

interpretation matrix_ba: boolean_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "op \<sqinter>" "op \<le>" "op <" mat_add mat_zero mat_top
by default (force intro!: le_funI simp: mat_inter_def plus_bool_def mat_add_def mat_zero_def zero_bool_def mat_top_def mat_complement_def)+

text {* We continue working towards the main result of this section, that
infinite Boolean matrices form a relation algebra. *}

lemma mat_mult_var: "(f \<otimes> g) = (\<lambda>i j. \<Sum> {(f i k) * (g k j) | k. k \<in> UNIV})"
by (rule ext)+ (simp add: mat_mult_def)

text {* The following fact is related to proving the last relation algebra
axiom in the matrix model. It is more complicated than necessary since finite
infima are not well developed in Isabelle. Instead we translate properties of
finite infima into properties of finite suprema by using Boolean algebra. For
finite suprema we have developed special-purpose theorems in the Kleene algebra
files. *}

lemma mat_res_pointwise:
  fixes i j :: "'a::finite"
    and x :: "('a, 'a, bool) matrix"
  shows "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j \<le> (y\<^sup>c) i j"
proof -
  have "\<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV} \<le> (y\<^sup>c) i j \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j) \<le> (y\<^sup>c) i j)"
    by (subst setsum_sup) auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> - (x \<otimes> y) k j) \<le> (y\<^sup>c) i j)"
    by (simp only: mat_complement_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> ((y\<^sup>c) i j \<or> (x \<otimes> y) k j))"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x\<^sup>\<dagger>) i k \<le> (- y i j \<or> (x \<otimes> y) k j))"
    by (simp only: mat_complement_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. ((x\<^sup>\<dagger>) i k \<and> y i j) \<le> (x \<otimes> y) k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> (x \<otimes> y) k j)"
    by (simp add: mat_transpose_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. (x k i \<and> y i j) \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
    by (simp add: mat_mult_def times_bool_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>k. \<Sum>{x k i \<and> y i j} \<le> \<Sum>{x k l \<and> y l j |l. l \<in> UNIV})"
    by simp
  also have "\<dots> \<longleftrightarrow> True"
    by (intro iffI TrueI allI setsum_intro[rule_format]) auto
  moreover have "(x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c) i j = \<Sum>{(x\<^sup>\<dagger>) i k \<and> ((x \<otimes> y)\<^sup>c) k j |k. k \<in> UNIV}"
    by (subst mat_mult_def) (simp add: times_bool_def)
  ultimately show ?thesis
    by auto
qed

text {* Finally the main result of this section. *}

interpretation matrix_ra: relation_algebra "\<lambda>f g. f \<sqinter> g\<^sup>c" mat_complement "op \<sqinter>" "op \<le>" "op <" "op \<oplus>" "\<lambda>i j. False" \<tau> "op \<otimes>" mat_transpose \<epsilon>
proof
  fix x y z :: "'a::finite \<Rightarrow> 'a \<Rightarrow> bool"
  show "(\<lambda>(i\<Colon>'a) j\<Colon>'a. False) \<le> x"
    by (metis predicate2I)
  show "x \<sqinter> x\<^sup>c = (\<lambda>i j. False)"
    by (metis matrix_ba.bot.extremum matrix_ba.inf_compl_bot rev_predicate2D)
  show "x \<oplus> x\<^sup>c = \<tau>"
    by (fact matrix_ba.sup_compl_top)
  show "x \<sqinter> y\<^sup>c = x \<sqinter> y\<^sup>c"
    by (fact refl)
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)"
    by (metis mat_mult_assoc)
  show "x \<otimes> \<epsilon> = x"
    by (fact mat_oner)
  show "x \<oplus> y \<otimes> z = (x \<otimes> z) \<oplus> (y \<otimes> z)"
    by (fact mat_distr)
  show "(x\<^sup>\<dagger>)\<^sup>\<dagger> = x"
    by (simp add: mat_transpose_def)
  show "(x \<oplus> y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<oplus> y\<^sup>\<dagger>"
    by (simp add: mat_transpose_def mat_add_def)
  show "(x \<otimes> y)\<^sup>\<dagger> = y\<^sup>\<dagger> \<otimes> x\<^sup>\<dagger>"
    by (simp add: mat_transpose_def mat_mult_var times_bool_def conj_commute)
  show "x\<^sup>\<dagger> \<otimes> (x \<otimes> y)\<^sup>c \<le> y\<^sup>c"
    by (metis le_funI2 mat_res_pointwise)
qed

end


(*  Title:      HOL/Probability/Projective_Family.thy
    Author:     Fabian Immler, TU München
    Author:     Johannes Hölzl, TU München
*)

section {*Projective Family*}

theory Projective_Family
imports Finite_Product_Measure Probability_Measure
begin

lemma (in product_prob_space) distr_restrict:
  assumes "J \<noteq> {}" "J \<subseteq> K" "finite K"
  shows "(\<Pi>\<^sub>M i\<in>J. M i) = distr (\<Pi>\<^sub>M i\<in>K. M i) (\<Pi>\<^sub>M i\<in>J. M i) (\<lambda>f. restrict f J)" (is "?P = ?D")
proof (rule measure_eqI_generator_eq)
  have "finite J" using `J \<subseteq> K` `finite K` by (auto simp add: finite_subset)
  interpret J: finite_product_prob_space M J proof qed fact
  interpret K: finite_product_prob_space M K proof qed fact

  let ?J = "{Pi\<^sub>E J E | E. \<forall>i\<in>J. E i \<in> sets (M i)}"
  let ?F = "\<lambda>i. \<Pi>\<^sub>E k\<in>J. space (M k)"
  let ?\<Omega> = "(\<Pi>\<^sub>E k\<in>J. space (M k))"
  show "Int_stable ?J"
    by (rule Int_stable_PiE)
  show "range ?F \<subseteq> ?J" "(\<Union>i. ?F i) = ?\<Omega>"
    using `finite J` by (auto intro!: prod_algebraI_finite)
  { fix i show "emeasure ?P (?F i) \<noteq> \<infinity>" by simp }
  show "?J \<subseteq> Pow ?\<Omega>" by (auto simp: Pi_iff dest: sets.sets_into_space)
  show "sets (\<Pi>\<^sub>M i\<in>J. M i) = sigma_sets ?\<Omega> ?J" "sets ?D = sigma_sets ?\<Omega> ?J"
    using `finite J` by (simp_all add: sets_PiM prod_algebra_eq_finite Pi_iff)

  fix X assume "X \<in> ?J"
  then obtain E where [simp]: "X = Pi\<^sub>E J E" and E: "\<forall>i\<in>J. E i \<in> sets (M i)" by auto
  with `finite J` have X: "X \<in> sets (Pi\<^sub>M J M)"
    by simp

  have "emeasure ?P X = (\<Prod> i\<in>J. emeasure (M i) (E i))"
    using E by (simp add: J.measure_times)
  also have "\<dots> = (\<Prod> i\<in>J. emeasure (M i) (if i \<in> J then E i else space (M i)))"
    by simp
  also have "\<dots> = (\<Prod> i\<in>K. emeasure (M i) (if i \<in> J then E i else space (M i)))"
    using `finite K` `J \<subseteq> K`
    by (intro setprod.mono_neutral_left) (auto simp: M.emeasure_space_1)
  also have "\<dots> = emeasure (Pi\<^sub>M K M) (\<Pi>\<^sub>E i\<in>K. if i \<in> J then E i else space (M i))"
    using E by (simp add: K.measure_times)
  also have "(\<Pi>\<^sub>E i\<in>K. if i \<in> J then E i else space (M i)) = (\<lambda>f. restrict f J) -` Pi\<^sub>E J E \<inter> (\<Pi>\<^sub>E i\<in>K. space (M i))"
    using `J \<subseteq> K` sets.sets_into_space E by (force simp: Pi_iff PiE_def split: split_if_asm)
  finally show "emeasure (Pi\<^sub>M J M) X = emeasure ?D X"
    using X `J \<subseteq> K` apply (subst emeasure_distr)
    by (auto intro!: measurable_restrict_subset simp: space_PiM)
qed

lemma (in product_prob_space) emeasure_prod_emb[simp]:
  assumes L: "J \<noteq> {}" "J \<subseteq> L" "finite L" and X: "X \<in> sets (Pi\<^sub>M J M)"
  shows "emeasure (Pi\<^sub>M L M) (prod_emb L M J X) = emeasure (Pi\<^sub>M J M) X"
  by (subst distr_restrict[OF L])
     (simp add: prod_emb_def space_PiM emeasure_distr measurable_restrict_subset L X)

definition
  limP :: "'i set \<Rightarrow> ('i \<Rightarrow> 'a measure) \<Rightarrow> ('i set \<Rightarrow> ('i \<Rightarrow> 'a) measure) \<Rightarrow> ('i \<Rightarrow> 'a) measure" where
  "limP I M P = extend_measure (\<Pi>\<^sub>E i\<in>I. space (M i))
    {(J, X). (J \<noteq> {} \<or> I = {}) \<and> finite J \<and> J \<subseteq> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))}
    (\<lambda>(J, X). prod_emb I M J (\<Pi>\<^sub>E j\<in>J. X j))
    (\<lambda>(J, X). emeasure (P J) (Pi\<^sub>E J X))"

abbreviation "lim\<^sub>P \<equiv> limP"

lemma space_limP[simp]: "space (limP I M P) = space (PiM I M)"
  by (auto simp add: limP_def space_PiM prod_emb_def intro!: space_extend_measure)

lemma sets_limP[simp]: "sets (limP I M P) = sets (PiM I M)"
  by (auto simp add: limP_def sets_PiM prod_algebra_def prod_emb_def intro!: sets_extend_measure)

lemma measurable_limP1[simp]: "measurable (limP I M P) M' = measurable (\<Pi>\<^sub>M i\<in>I. M i) M'"
  unfolding measurable_def by auto

lemma measurable_limP2[simp]: "measurable M' (limP I M P) = measurable M' (\<Pi>\<^sub>M i\<in>I. M i)"
  unfolding measurable_def by auto

locale projective_family =
  fixes I::"'i set" and P::"'i set \<Rightarrow> ('i \<Rightarrow> 'a) measure" and M::"('i \<Rightarrow> 'a measure)"
  assumes projective: "\<And>J H X. J \<noteq> {} \<Longrightarrow> J \<subseteq> H \<Longrightarrow> H \<subseteq> I \<Longrightarrow> finite H \<Longrightarrow> X \<in> sets (PiM J M) \<Longrightarrow>
     (P H) (prod_emb H M J X) = (P J) X"
  assumes proj_prob_space: "\<And>J. finite J \<Longrightarrow> prob_space (P J)"
  assumes proj_space: "\<And>J. finite J \<Longrightarrow> space (P J) = space (PiM J M)"
  assumes proj_sets: "\<And>J. finite J \<Longrightarrow> sets (P J) = sets (PiM J M)"
begin

lemma emeasure_limP:
  assumes "finite J"
  assumes "J \<subseteq> I"
  assumes A: "\<And>i. i\<in>J \<Longrightarrow> A i \<in> sets (M i)"
  shows "emeasure (limP J M P) (Pi\<^sub>E J A) = emeasure (P J) (Pi\<^sub>E J A)"
proof -
  have "Pi\<^sub>E J (restrict A J) \<subseteq> (\<Pi>\<^sub>E i\<in>J. space (M i))"
    using sets.sets_into_space[OF A] by (auto simp: PiE_iff) blast
  hence "emeasure (limP J M P) (Pi\<^sub>E J A) =
    emeasure (limP J M P) (prod_emb J M J (Pi\<^sub>E J A))"
    using assms(1-3) sets.sets_into_space by (auto simp add: prod_emb_id PiE_def Pi_def)
  also have "\<dots> = emeasure (P J) (Pi\<^sub>E J A)"
  proof (rule emeasure_extend_measure_Pair[OF limP_def])
    show "positive (sets (limP J M P)) (P J)" unfolding positive_def by auto
    show "countably_additive (sets (limP J M P)) (P J)" unfolding countably_additive_def
      by (auto simp: suminf_emeasure proj_sets[OF `finite J`])
    show "(J \<noteq> {} \<or> J = {}) \<and> finite J \<and> J \<subseteq> J \<and> A \<in> (\<Pi> j\<in>J. sets (M j))"
      using assms by auto
    fix K and X::"'i \<Rightarrow> 'a set"
    show "prod_emb J M K (Pi\<^sub>E K X) \<in> Pow (\<Pi>\<^sub>E i\<in>J. space (M i))"
      by (auto simp: prod_emb_def)
    assume JX: "(K \<noteq> {} \<or> J = {}) \<and> finite K \<and> K \<subseteq> J \<and> X \<in> (\<Pi> j\<in>K. sets (M j))"
    thus "emeasure (P J) (prod_emb J M K (Pi\<^sub>E K X)) = emeasure (P K) (Pi\<^sub>E K X)"
      using assms
      apply (cases "J = {}")
      apply (simp add: prod_emb_id)
      apply (fastforce simp add: intro!: projective sets_PiM_I_finite)
      done
  qed
  finally show ?thesis .
qed

lemma limP_finite[simp]:
  assumes "finite J"
  assumes "J \<subseteq> I"
  shows "limP J M P = P J" (is "?P = _")
proof (rule measure_eqI_generator_eq)
  let ?J = "{Pi\<^sub>E J E | E. \<forall>i\<in>J. E i \<in> sets (M i)}"
  let ?\<Omega> = "(\<Pi>\<^sub>E k\<in>J. space (M k))"
  interpret prob_space "P J" using proj_prob_space `finite J` by simp
  show "emeasure ?P (\<Pi>\<^sub>E k\<in>J. space (M k)) \<noteq> \<infinity>" using assms `finite J` by (auto simp: emeasure_limP)
  show "sets (limP J M P) = sigma_sets ?\<Omega> ?J" "sets (P J) = sigma_sets ?\<Omega> ?J"
    using `finite J` proj_sets by (simp_all add: sets_PiM prod_algebra_eq_finite Pi_iff)
  fix X assume "X \<in> ?J"
  then obtain E where X: "X = Pi\<^sub>E J E" and E: "\<forall>i\<in>J. E i \<in> sets (M i)" by auto
  with `finite J` have "X \<in> sets (limP J M P)" by simp
  have emb_self: "prod_emb J M J (Pi\<^sub>E J E) = Pi\<^sub>E J E"
    using E sets.sets_into_space
    by (auto intro!: prod_emb_PiE_same_index)
  show "emeasure (limP J M P) X = emeasure (P J) X"
    unfolding X using E
    by (intro emeasure_limP assms) simp
qed (auto simp: Pi_iff dest: sets.sets_into_space intro: Int_stable_PiE)

lemma emeasure_fun_emb[simp]:
  assumes L: "J \<noteq> {}" "J \<subseteq> L" "finite L" "L \<subseteq> I" and X: "X \<in> sets (PiM J M)"
  shows "emeasure (limP L M P) (prod_emb L M J X) = emeasure (limP J M P) X"
  using assms
  by (subst limP_finite) (auto simp: limP_finite finite_subset projective)

abbreviation
  "emb L K X \<equiv> prod_emb L M K X"

lemma prod_emb_injective:
  assumes "J \<subseteq> L" and sets: "X \<in> sets (Pi\<^sub>M J M)" "Y \<in> sets (Pi\<^sub>M J M)"
  assumes "emb L J X = emb L J Y"
  shows "X = Y"
proof (rule injective_vimage_restrict)
  show "X \<subseteq> (\<Pi>\<^sub>E i\<in>J. space (M i))" "Y \<subseteq> (\<Pi>\<^sub>E i\<in>J. space (M i))"
    using sets[THEN sets.sets_into_space] by (auto simp: space_PiM)
  have "\<forall>i\<in>L. \<exists>x. x \<in> space (M i)"
  proof
    fix i assume "i \<in> L"
    interpret prob_space "P {i}" using proj_prob_space by simp
    from not_empty show "\<exists>x. x \<in> space (M i)" by (auto simp add: proj_space space_PiM)
  qed
  from bchoice[OF this]
  show "(\<Pi>\<^sub>E i\<in>L. space (M i)) \<noteq> {}" by (auto simp: PiE_def)
  show "(\<lambda>x. restrict x J) -` X \<inter> (\<Pi>\<^sub>E i\<in>L. space (M i)) = (\<lambda>x. restrict x J) -` Y \<inter> (\<Pi>\<^sub>E i\<in>L. space (M i))"
    using `prod_emb L M J X = prod_emb L M J Y` by (simp add: prod_emb_def)
qed fact

definition generator :: "('i \<Rightarrow> 'a) set set" where
  "generator = (\<Union>J\<in>{J. J \<noteq> {} \<and> finite J \<and> J \<subseteq> I}. emb I J ` sets (Pi\<^sub>M J M))"

lemma generatorI':
  "J \<noteq> {} \<Longrightarrow> finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> X \<in> sets (Pi\<^sub>M J M) \<Longrightarrow> emb I J X \<in> generator"
  unfolding generator_def by auto

lemma algebra_generator:
  assumes "I \<noteq> {}" shows "algebra (\<Pi>\<^sub>E i\<in>I. space (M i)) generator" (is "algebra ?\<Omega> ?G")
  unfolding algebra_def algebra_axioms_def ring_of_sets_iff
proof (intro conjI ballI)
  let ?G = generator
  show "?G \<subseteq> Pow ?\<Omega>"
    by (auto simp: generator_def prod_emb_def)
  from `I \<noteq> {}` obtain i where "i \<in> I" by auto
  then show "{} \<in> ?G"
    by (auto intro!: exI[of _ "{i}"] image_eqI[where x="\<lambda>i. {}"]
             simp: sigma_sets.Empty generator_def prod_emb_def)
  from `i \<in> I` show "?\<Omega> \<in> ?G"
    by (auto intro!: exI[of _ "{i}"] image_eqI[where x="Pi\<^sub>E {i} (\<lambda>i. space (M i))"]
             simp: generator_def prod_emb_def)
  fix A assume "A \<in> ?G"
  then obtain JA XA where XA: "JA \<noteq> {}" "finite JA" "JA \<subseteq> I" "XA \<in> sets (Pi\<^sub>M JA M)" and A: "A = emb I JA XA"
    by (auto simp: generator_def)
  fix B assume "B \<in> ?G"
  then obtain JB XB where XB: "JB \<noteq> {}" "finite JB" "JB \<subseteq> I" "XB \<in> sets (Pi\<^sub>M JB M)" and B: "B = emb I JB XB"
    by (auto simp: generator_def)
  let ?RA = "emb (JA \<union> JB) JA XA"
  let ?RB = "emb (JA \<union> JB) JB XB"
  have *: "A - B = emb I (JA \<union> JB) (?RA - ?RB)" "A \<union> B = emb I (JA \<union> JB) (?RA \<union> ?RB)"
    using XA A XB B by auto
  show "A - B \<in> ?G" "A \<union> B \<in> ?G"
    unfolding * using XA XB by (safe intro!: generatorI') auto
qed

lemma sets_PiM_generator:
  "sets (PiM I M) = sigma_sets (\<Pi>\<^sub>E i\<in>I. space (M i)) generator"
proof cases
  assume "I = {}" then show ?thesis
    unfolding generator_def
    by (auto simp: sets_PiM_empty sigma_sets_empty_eq cong: conj_cong)
next
  assume "I \<noteq> {}"
  show ?thesis
  proof
    show "sets (Pi\<^sub>M I M) \<subseteq> sigma_sets (\<Pi>\<^sub>E i\<in>I. space (M i)) generator"
      unfolding sets_PiM
    proof (safe intro!: sigma_sets_subseteq)
      fix A assume "A \<in> prod_algebra I M" with `I \<noteq> {}` show "A \<in> generator"
        by (auto intro!: generatorI' sets_PiM_I_finite elim!: prod_algebraE)
    qed
  qed (auto simp: generator_def space_PiM[symmetric] intro!: sets.sigma_sets_subset)
qed

lemma generatorI:
  "J \<noteq> {} \<Longrightarrow> finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> X \<in> sets (Pi\<^sub>M J M) \<Longrightarrow> A = emb I J X \<Longrightarrow> A \<in> generator"
  unfolding generator_def by auto

definition mu_G ("\<mu>G") where
  "\<mu>G A =
    (THE x. \<forall>J. J \<noteq> {} \<longrightarrow> finite J \<longrightarrow> J \<subseteq> I \<longrightarrow> (\<forall>X\<in>sets (Pi\<^sub>M J M). A = emb I J X \<longrightarrow> x = emeasure (limP J M P) X))"

lemma mu_G_spec:
  assumes J: "J \<noteq> {}" "finite J" "J \<subseteq> I" "A = emb I J X" "X \<in> sets (Pi\<^sub>M J M)"
  shows "\<mu>G A = emeasure (limP J M P) X"
  unfolding mu_G_def
proof (intro the_equality allI impI ballI)
  fix K Y assume K: "K \<noteq> {}" "finite K" "K \<subseteq> I" "A = emb I K Y" "Y \<in> sets (Pi\<^sub>M K M)"
  have "emeasure (limP K M P) Y = emeasure (limP (K \<union> J) M P) (emb (K \<union> J) K Y)"
    using K J by (simp del: limP_finite)
  also have "emb (K \<union> J) K Y = emb (K \<union> J) J X"
    using K J by (simp add: prod_emb_injective[of "K \<union> J" I])
  also have "emeasure (limP (K \<union> J) M P) (emb (K \<union> J) J X) = emeasure (limP J M P) X"
    using K J by (simp del: limP_finite)
  finally show "emeasure (limP J M P) X = emeasure (limP K M P) Y" ..
qed (insert J, force)

lemma mu_G_eq:
  "J \<noteq> {} \<Longrightarrow> finite J \<Longrightarrow> J \<subseteq> I \<Longrightarrow> X \<in> sets (Pi\<^sub>M J M) \<Longrightarrow> \<mu>G (emb I J X) = emeasure (limP J M P) X"
  by (intro mu_G_spec) auto

lemma generator_Ex:
  assumes *: "A \<in> generator"
  shows "\<exists>J X. J \<noteq> {} \<and> finite J \<and> J \<subseteq> I \<and> X \<in> sets (Pi\<^sub>M J M) \<and> A = emb I J X \<and> \<mu>G A = emeasure (limP J M P) X"
proof -
  from * obtain J X where J: "J \<noteq> {}" "finite J" "J \<subseteq> I" "A = emb I J X" "X \<in> sets (Pi\<^sub>M J M)"
    unfolding generator_def by auto
  with mu_G_spec[OF this] show ?thesis by (auto simp del: limP_finite)
qed

lemma generatorE:
  assumes A: "A \<in> generator"
  obtains J X where "J \<noteq> {}" "finite J" "J \<subseteq> I" "X \<in> sets (Pi\<^sub>M J M)" "emb I J X = A" "\<mu>G A = emeasure (limP J M P) X"
  using generator_Ex[OF A] by atomize_elim auto

lemma merge_sets:
  "J \<inter> K = {} \<Longrightarrow> A \<in> sets (Pi\<^sub>M (J \<union> K) M) \<Longrightarrow> x \<in> space (Pi\<^sub>M J M) \<Longrightarrow> (\<lambda>y. merge J K (x,y)) -` A \<inter> space (Pi\<^sub>M K M) \<in> sets (Pi\<^sub>M K M)"
  by simp

lemma merge_emb:
  assumes "K \<subseteq> I" "J \<subseteq> I" and y: "y \<in> space (Pi\<^sub>M J M)"
  shows "((\<lambda>x. merge J (I - J) (y, x)) -` emb I K X \<inter> space (Pi\<^sub>M I M)) =
    emb I (K - J) ((\<lambda>x. merge J (K - J) (y, x)) -` emb (J \<union> K) K X \<inter> space (Pi\<^sub>M (K - J) M))"
proof -
  have [simp]: "\<And>x J K L. merge J K (y, restrict x L) = merge J (K \<inter> L) (y, x)"
    by (auto simp: restrict_def merge_def)
  have [simp]: "\<And>x J K L. restrict (merge J K (y, x)) L = merge (J \<inter> L) (K \<inter> L) (y, x)"
    by (auto simp: restrict_def merge_def)
  have [simp]: "(I - J) \<inter> K = K - J" using `K \<subseteq> I` `J \<subseteq> I` by auto
  have [simp]: "(K - J) \<inter> (K \<union> J) = K - J" by auto
  have [simp]: "(K - J) \<inter> K = K - J" by auto
  from y `K \<subseteq> I` `J \<subseteq> I` show ?thesis
    by (simp split: split_merge add: prod_emb_def Pi_iff PiE_def extensional_merge_sub set_eq_iff space_PiM)
       auto
qed

lemma positive_mu_G:
  assumes "I \<noteq> {}"
  shows "positive generator \<mu>G"
proof -
  interpret G!: algebra "\<Pi>\<^sub>E i\<in>I. space (M i)" generator by (rule algebra_generator) fact
  show ?thesis
  proof (intro positive_def[THEN iffD2] conjI ballI)
    from generatorE[OF G.empty_sets] guess J X . note this[simp]
    have "X = {}"
      by (rule prod_emb_injective[of J I]) simp_all
    then show "\<mu>G {} = 0" by simp
  next
    fix A assume "A \<in> generator"
    from generatorE[OF this] guess J X . note this[simp]
    show "0 \<le> \<mu>G A" by (simp add: emeasure_nonneg)
  qed
qed

lemma additive_mu_G:
  assumes "I \<noteq> {}"
  shows "additive generator \<mu>G"
proof -
  interpret G!: algebra "\<Pi>\<^sub>E i\<in>I. space (M i)" generator by (rule algebra_generator) fact
  show ?thesis
  proof (intro additive_def[THEN iffD2] ballI impI)
    fix A assume "A \<in> generator" with generatorE guess J X . note J = this
    fix B assume "B \<in> generator" with generatorE guess K Y . note K = this
    assume "A \<inter> B = {}"
    have JK: "J \<union> K \<noteq> {}" "J \<union> K \<subseteq> I" "finite (J \<union> K)"
      using J K by auto
    have JK_disj: "emb (J \<union> K) J X \<inter> emb (J \<union> K) K Y = {}"
      apply (rule prod_emb_injective[of "J \<union> K" I])
      apply (insert `A \<inter> B = {}` JK J K)
      apply (simp_all add: sets.Int prod_emb_Int)
      done
    have AB: "A = emb I (J \<union> K) (emb (J \<union> K) J X)" "B = emb I (J \<union> K) (emb (J \<union> K) K Y)"
      using J K by simp_all
    then have "\<mu>G (A \<union> B) = \<mu>G (emb I (J \<union> K) (emb (J \<union> K) J X \<union> emb (J \<union> K) K Y))"
      by simp
    also have "\<dots> = emeasure (limP (J \<union> K) M P) (emb (J \<union> K) J X \<union> emb (J \<union> K) K Y)"
      using JK J(1, 4) K(1, 4) by (simp add: mu_G_eq sets.Un del: prod_emb_Un)
    also have "\<dots> = \<mu>G A + \<mu>G B"
      using J K JK_disj by (simp add: plus_emeasure[symmetric] del: limP_finite)
    finally show "\<mu>G (A \<union> B) = \<mu>G A + \<mu>G B" .
  qed
qed

end

sublocale product_prob_space \<subseteq> projective_family I "\<lambda>J. PiM J M" M
proof (simp add: projective_family_def, safe)
  fix J::"'i set" assume [simp]: "finite J"
  interpret f: finite_product_prob_space M J proof qed fact
  show "prob_space (Pi\<^sub>M J M)"
  proof
    show "emeasure (Pi\<^sub>M J M) (space (Pi\<^sub>M J M)) = 1"
      by (simp add: space_PiM emeasure_PiM emeasure_space_1)
  qed
qed

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Lattice_FixPoint

imports
  Lattice_Class
  Lattice_Morphism
  Lattice_Instance

begin

subsection {* Fixed points *}

text {*

For any function @{term[show_types] "f::'a \<rightarrow> 'a"}, the fixed points of
@{term "f"} are those points @{term "a"} such that @{term "f a = a"}.

*}

definition
  fp_set :: "('a \<rightarrow> 'a) \<rightarrow> 'a set"
where
  fp_set_def: "fp_set \<defs> (\<olambda> f \<bullet> { x | f x = x })"

text {*

The least fixed point is the infimum of the fixed point set.

*}

definition
  llfp :: "(('a::clattice) \<rightarrow> 'a) \<rightarrow> 'a"
where
  lfp_def: "llfp f \<defs> \<lInf>(fp_set f)"

definition
  lgfp :: "(('a::clattice) \<rightarrow> 'a) \<rightarrow> 'a"
where
  gfp_def: "lgfp f \<defs> \<lSup>(fp_set f)"

syntax (xsymbols)
  "_Lattice_FixPoint\<ZZ>lLFP" :: "[pttrn, ('a::clattice)] \<rightarrow> 'a" ("(2\<lLFP> _ \<bullet>/ _)" [0,10] 10)
  "_Lattice_FixPoint\<ZZ>lGFP" :: "[pttrn, ('a::clattice)] \<rightarrow> 'a" ("(2\<lGFP> _ \<bullet>/ _)" [0,10] 10)

translations
  "_Lattice_FixPoint\<ZZ>lLFP p b" \<rightleftharpoons> "(CONST llfp) (\<olambda> p \<bullet> b)"
  "_Lattice_FixPoint\<ZZ>lGFP p b" \<rightleftharpoons> "(CONST lgfp) (\<olambda> p \<bullet> b)"

(*
syntax (xsymbols output)
  "_Lattice_FixPoint\<ZZ>lLFP" :: "[idt, ('a::clattice)] \<rightarrow> 'a" ("(2\<mu> _ \<bullet>/ _)" [0,10] 10)
  "_Lattice_FixPoint\<ZZ>lGFP" :: "[idt, ('a::clattice)] \<rightarrow> 'a" ("(2\<nu> _ \<bullet>/ _)" [0,10] 10);

syntax (zed)
  "_Lattice_FixPoint\<ZZ>lLFP" :: "[idt, ('a::clattice)] \<rightarrow> 'a" ("(2\<lLFP>_\<bullet>/ _)" [0,10] 10)
  "_Lattice_FixPoint\<ZZ>lGFP" :: "[idt, ('a::clattice)] \<rightarrow> 'a" ("(2\<lGFP>_\<bullet>/ _)" [0,10] 10);

parse_translation {* [
  mk_binder_tr("_Lattice_FixPoint\<ZZ>lLFP","\<^const>Lattice_FixPoint.llfp"),
  mk_binder_tr("_Lattice_FixPoint\<ZZ>lGFP","\<^const>Lattice_FixPoint.lgfp")
] *};

print_translation {* [
  mk_binder_tr'("\<^const>Lattice_FixPoint.llfp","_Lattice_FixPoint\<ZZ>lLFP"),
  mk_binder_tr'("\<^const>Lattice_FixPoint.lgfp","_Lattice_FixPoint\<ZZ>lGFP")
] *};

*)

text {*
The infimum of all the fixed points is a fixed point, as is the
supremum.
*}

lemma lfp_wit:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows "f (\<lINF> x | f x \<lle> x) = (\<lINF> x | f x \<lle> x)"
proof -
txt {* We follow the proof of Back and von Wright~\cite[p 18,19]{Back:Text}. *}
  from a1 [THEN mh_Inf, of "{ x | f x \<lle> x }"] have
    "f(\<lINF> x | f x \<lle> x) \<lle> (\<lINF> x | f x \<lle> x \<bullet> f x)"
    by (auto)
  also have "\<dots> \<lle> (\<lINF> x | f x \<le> x)"
  proof (rule Inf_glb, simp)
    fix x::'a assume b1: "f x \<lle> x"
    show "(\<lINF> x | f x \<lle> x \<bullet> f x) \<lle> x"
      by (rule b1 [THEN [2] order_trans])
        (rule Inf_lb, simp, rule exI [of _ x], auto intro: b1)
  qed
  finally have a2: "f(\<lINF> x | f x \<lle> x) \<lle> (\<lINF> x | f x \<le> x)" .
  from a2 have "f(f(\<lINF> x | f x \<lle> x)) \<lle> f(\<lINF> x | f x \<le> x)"
    by (auto intro: a1 [THEN mhD])
  hence "f(\<lINF> x | f x \<le> x) \<in> {x | f x \<le> x}"
    by (auto)
  hence "(\<lINF> x | f x \<lle> x) \<lle> f(\<lINF> x | f x \<lle> x)"
    by (auto intro: Inf_lb)
  with a2 show ?thesis by (rule order_antisym)
qed

lemma gfp_wit:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows "f (\<lSUP> x | x \<lle> f x) = (\<lSUP> x | x \<lle> f x)"
proof -
  have "(\<lSUP> x | x \<lle> f x) \<lle> (\<lSUP> x | x \<lle> f x \<bullet> f x)"
  proof (rule Sup_lub, simp)
    fix x::'a assume b1: "x \<lle> f x"
    show "x \<lle> (\<lSUP> x | x \<lle> f x \<bullet> f x)"
      by (rule b1 [THEN order_trans])
        (rule Sup_ub, simp, rule exI [of _ x], auto intro: b1)
  qed
  also from a1 [THEN mh_Sup, of "{ x | x \<lle> f x }"] have "\<dots> \<lle> f (\<lSUP> x | x \<lle> f x)"
    by (auto)
  finally have a2: "(\<lSUP> x | x \<lle> f x) \<lle> f (\<lSUP> x | x \<lle> f x)" .
  from a2 have "f(\<lSUP> x | x \<lle> f x) \<lle> f (f (\<lSUP> x | x \<lle> f x))"
    by (auto intro: a1 [THEN mhD])
  hence "f (\<lSUP> x | x \<lle> f x) \<in> { x | x \<lle> f x}"
    by (auto)
  hence "f (\<lSUP> x | x \<lle> f x) \<lle> (\<lSUP> x | x \<lle> f x)"
    by (auto intro: Sup_ub)
  with a2 show ?thesis
    by (auto intro: order_antisym)
qed

lemma lfp_char:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows "(\<lLFP> x \<bullet> f x) = (\<lINF> x | f x \<lle> x)"
  apply (unfold lfp_def)
  apply (rule Min_eq)
  apply (auto intro: lfp_wit [OF a1] simp add: fp_set_def)
proof -
  fix x::'a assume a2: "f x = x"
  from a2 have "f x \<lle> x" by (rule order_eq_refl)
  hence "x \<in> {x | f x \<lle> x}" by (auto)
  thus "(\<lINF> x | f x \<lle> x) \<lle> x" by (rule Inf_lb)
qed

lemma gfp_char:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows "(\<lGFP> x \<bullet> f x) = (\<lSUP> x | x \<lle> f x)"
proof (unfold gfp_def, rule Max_eq, auto intro: gfp_wit [OF a1] simp add: fp_set_def)
  fix x::'a assume a2: "f x = x"
  from a2 have "x \<lle> f x" by (rule sym [THEN order_eq_refl])
  hence "x \<in> {x | x \<lle> f x}" by (auto)
  thus "x \<lle> (\<lSUP> x | x \<lle> f x)" by (rule Sup_ub)
qed

text {*

Thus every monotonic function has a least and a greatest fixed point.

*}

theorem Knaster_Tarski:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows
    "(\<exists> x \<bullet> f x = x \<and> (\<lLFP> x \<bullet> f x) = x)"
    "(\<exists> x \<bullet> f x = x \<and> (\<lGFP> x \<bullet> f x) = x)"
proof -
  show "\<exists> x \<bullet> f x = x \<and> (\<lLFP> x \<bullet> f x) = x"
    by (witness "\<lINF> x | f x \<lle> x")
      (auto intro: a1 [THEN lfp_wit] a1 [THEN lfp_char])
  show "\<exists>x \<bullet> f x = x \<and> (\<lGFP> x \<bullet> f x) = x"
    by (witness "\<lSUP> x | x \<lle> f x")
      (auto intro: a1 [THEN gfp_wit] a1 [THEN gfp_char])
qed

text {*
Least (greatest) fixed points admit the expected unfolding and induction
rules.
*}

lemma lfp_fold:
  assumes a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows "f (\<lLFP> x \<bullet> f x) = (\<lLFP> x \<bullet> f x)"
  using a1
  by (auto simp add: lfp_char lfp_wit)

lemma lfp_induct:
  assumes
    a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>" "f x \<lle> x"
  shows
    "(\<lLFP> x \<bullet> f x) \<lle> x"
  using a1
  by (auto simp add: lfp_char intro: Inf_lb)

lemma lfp_glbfp:
  assumes
    a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>" and
    a2: "(\<And> x \<bullet> f x \<lle> x \<turnstile> z \<lle> x)"
  shows
    "z \<lle> (\<lLFP> x \<bullet> f x)"
  using a1 a2
  by (auto simp add: lfp_char intro: Inf_glb)

lemma lfp_eq:
  assumes
    a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>" and
    a2: "f z \<lle> z" and
    a3: "(\<And> y \<bullet> f y \<lle> y \<turnstile> z \<lle> y)"
  shows
    "(\<lLFP> x \<bullet> f x) = z"
  using a1 a2 a3
  by (auto simp add: lfp_char intro: Inf_eq)

lemma gfp_fold:
  assumes
    a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>"
  shows
    "f (\<lGFP> x \<bullet> f x) = (\<lGFP> x \<bullet> f x)"
  using a1
  by (auto simp add: gfp_char gfp_wit)

lemma gfp_induct:
  assumes
    a1: "(f::('a::clattice) \<rightarrow> 'a) \<in> \<mh>" "x \<lle> f x"
  shows
    "x \<lle> (\<lGFP> x \<bullet> f x)"
  using a1
  by (auto simp add: gfp_char intro: Sup_ub)

text {*

The fixed point operators are monotonic on monotonic functions.

*}

lemma lfp_mono:
 fixes f::"('a::clattice) \<rightarrow> 'a" and g::"('a::clattice) \<rightarrow> 'a"
 assumes  a1: "f \<in> \<mh>" and
    a2: "g \<in> \<mh>" and
    a3: "f \<lle> g"
  shows "(\<lLFP> x \<bullet> f x) \<lle> (\<lLFP> x \<bullet> g x)"
proof -
  from a3 have "f (\<lLFP> x \<bullet> g x) \<lle> g (\<lLFP> x \<bullet> g x)"
    by (rule fun_le)
  with a2 have "f (\<lLFP> x \<bullet> g x) \<lle> (\<lLFP> x \<bullet> g x)"
    by (simp add: lfp_fold)
  with a1 show "(\<lLFP> x \<bullet> f x) \<lle> (\<lLFP> x \<bullet> g x)"
    by (rule lfp_induct)
qed

lemma gfp_mono:
  fixes f::"('a::clattice) \<rightarrow> 'a" and g::"('a::clattice) \<rightarrow> 'a"
  assumes  a1: "f \<in> \<mh>" and
    a2: "g \<in> \<mh>" and
    a3: "f \<lle> g"
  shows "(\<lGFP> x \<bullet> f x) \<lle> (\<lGFP> x \<bullet> g x)"
proof -
  from a3 have "f (\<lGFP> x \<bullet> f x) \<lle> g (\<lGFP> x \<bullet> f x)"
    by (rule fun_le)
  with a1 have "(\<lGFP> x \<bullet> f x) \<lle> g (\<lGFP> x \<bullet> f x)"
    by (simp add: gfp_fold)
  with a2 show "(\<lGFP> x \<bullet> f x) \<lle> (\<lGFP> x \<bullet> g x)"
    by (rule gfp_induct)
qed

text {*

We can extract fold equations from tuple recursion equations.

*}

lemma split_lfp_fold:
  assumes
    a1: "(\<olambda> (a, b) \<bullet> (f a b, g a b)) \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> (a, b) \<bullet> (f a b, g a b))"
  shows
    split_lfp_fold1: "f x y = x" and
    split_lfp_fold2: "g x y = y"
proof -
  from lfp_fold [OF a1, simplified a2 [symmetric]] show
     "f x y = x"  "g x y = y"
    by (auto)
qed

lemma split_lfp_fold1':
  assumes
    a1: "f \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> ab \<bullet> f ab)"
  shows
    "\<fst> (f (x, y)) = x"
  apply (rule split_lfp_fold1 [of "(\<olambda> a b \<bullet> fst (f (a, b)))" "(\<olambda> a b \<bullet> snd (f (a, b)))" "x" "y"])
  using a1 a2
  apply (auto)
  done

lemma split_lfp_fold2':
  assumes
    a1: "f \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> ab \<bullet> f ab)"
  shows
    "\<snd> (f (x, y)) = y"
  apply (rule split_lfp_fold2 [of "(\<olambda> a b \<bullet> fst (f (a, b)))" "(\<olambda> a b \<bullet> snd (f (a, b)))" "x" "y"])
  using a1 a2
  apply (auto)
  done

lemmas split_lfp_fold' = split_lfp_fold1' split_lfp_fold2'

lemma prod_mh:
    "(\<olambda> (a, b) \<bullet> (f a b, g a b)) \<in> \<mh>
    \<Leftrightarrow> (\<forall> y \<bullet> (\<olambda> a \<bullet> f a y) \<in> \<mh>) \<and>
      (\<forall> y \<bullet> (\<olambda> a \<bullet> g a y) \<in> \<mh>) \<and>
      (\<forall> x \<bullet> (\<olambda> b \<bullet> g x b) \<in> \<mh>) \<and>
      (\<forall> x \<bullet> (\<olambda> b \<bullet> f x b) \<in> \<mh>)"
proof (msafe(inference))
  assume
    b1: "(\<olambda> (a, b) \<bullet> (f a b, g a b)) \<in> \<mh>"
{ fix x
  from b1 show
      "(\<olambda> b \<bullet> g x b) \<in> \<mh>"
      "(\<olambda> b \<bullet> f x b) \<in> \<mh>"
    by (auto elim!: mhE intro!: mhI simp add: le_prod_conv)
next
  fix y
  from b1 show
      "(\<olambda> a \<bullet> f a y) \<in> \<mh>"
      "(\<olambda> a \<bullet> g a y) \<in> \<mh>"
    by (auto elim!: mhE intro!: mhI simp add: le_prod_conv) }
next
  assume
    b1: "(\<forall> y \<bullet> (\<olambda> a \<bullet> f a y) \<in> \<mh>)" and
    b2: "(\<forall> y \<bullet> (\<olambda> a \<bullet> g a y) \<in> \<mh>)" and
    b3: "(\<forall> x \<bullet> (\<olambda> b \<bullet> g x b) \<in> \<mh>)" and
    b4: "(\<forall> x \<bullet> (\<olambda> b \<bullet> f x b) \<in> \<mh>)"
  show
      "(\<olambda> (a, b) \<bullet> (f a b, g a b)) \<in> \<mh>"
  proof (auto intro!: mhI simp add: le_prod_conv)
    fix
      x::"'a" and
      x'::"'a" and
      y::"'b" and
      y'::"'b"
    assume
      c1: "x \<le> x'" and
      c2: "y \<le> y'"
    from b4 [rule_format, of "x"] c2
    have
        "f x y
        \<le> f x y'"
      by (rule mhD)
    also from b1 [rule_format, of "y'"] c1 have "\<dots>
        \<le>  f x' y'"
      by (rule mhD)
    finally show
        "f x y \<le> f x' y'"
      by (this)
    from b3 [rule_format, of "x"] c2
    have
        "g x y
        \<le> g x y'"
      by (rule mhD)
    also from b2 [rule_format, of "y'"] c1 have "\<dots>
        \<le>  g x' y'"
      by (rule mhD)
    finally show
        "g x y \<le> g x' y'"
      by (this)
  qed
qed

lemma split_lfp:
  assumes
    a1: "(\<olambda> (a, b) \<bullet> (f a b, g a b)) \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> (a, b) \<bullet> (f a b, g a b))"
  shows
    split_lfp1: "x = (\<lLFP> a \<bullet> f a y)" and
    split_lfp2: "y = (\<lLFP> b \<bullet> g x b)"
proof -
  from a1 have
    b1: "(\<forall> b \<bullet> (\<olambda> a \<bullet> f a b) \<in> \<mh>)" and
    b2: "(\<forall> b \<bullet> (\<olambda> a \<bullet> g a b) \<in> \<mh>)" and
    b3: "(\<forall> a \<bullet> (\<olambda> b \<bullet> g a b) \<in> \<mh>)" and
    b4: "(\<forall> a \<bullet> (\<olambda> b \<bullet> f a b) \<in> \<mh>)"
    by (simp_all add: prod_mh)
  show
      "x = (\<lLFP> a \<bullet> f a y)"
      "y = (\<lLFP> b \<bullet> g x b)"
  proof (auto intro!: order_antisym)
    from split_lfp_fold1 [OF a1 a2]
    show
      c1: "(\<lLFP> a \<bullet> f a y) \<lle> x"
      apply (simp add: lfp_def fp_set_def)
      apply (rule Inf_lb)
      apply (simp)
      done
    from split_lfp_fold2 [OF a1 a2]
    show
      c2: "(\<lLFP> b \<bullet> g x b) \<lle> y"
      apply (simp add: lfp_def fp_set_def)
      apply (rule Inf_lb)
      apply (simp)
      done
    have "(x, y) \<lle> ((\<lLFP> a \<bullet> f a y), (\<lLFP> b \<bullet> g x b))"
    proof (simp add: a2, rule lfp_induct [OF a1])
      have
          "(\<olambda> (a, b) \<bullet> (f a b, g a b)) ((\<lLFP> a \<bullet> f a y), (\<lLFP> b \<bullet> g x b))
          = (f (\<lLFP> a \<bullet> f a y) (\<lLFP> b \<bullet> g x b), g (\<lLFP> a \<bullet> f a y) (\<lLFP> b \<bullet> g x b))"
        by (simp)
      also have "\<dots>
          \<lle> (f (\<lLFP> a \<bullet> f a y) y, g (\<lLFP> a \<bullet> f a y) (\<lLFP> b \<bullet> g x b))"
        by (auto simp add: le_prod_conv mhD [OF b4 [rule_format] c2])
      also have "\<dots>
          \<lle> (f (\<lLFP> a \<bullet> f a y) y, g x (\<lLFP> b \<bullet> g x b))"
        by (auto simp add: le_prod_conv mhD [OF b2 [rule_format] c1])
      also have "\<dots>
          = ((\<lLFP> a \<bullet> f a y), g x (\<lLFP> b \<bullet> g x b))"
        by (auto simp add: lfp_fold [OF b1 [rule_format]])
      also have "\<dots>
          = ((\<lLFP> a \<bullet> f a y), (\<lLFP> b \<bullet> g x b))"
        by (auto simp add: lfp_fold [OF b3 [rule_format]])
      finally show
          "(\<olambda> (a, b) \<bullet> (f a b, g a b)) ((\<lLFP> a \<bullet> f a y), (\<lLFP> b \<bullet> g x b))
          \<lle> ((\<lLFP> a \<bullet> f a y), (\<lLFP> b \<bullet> g x b))"
        by (this)
    qed
    then show
        "x \<lle> (\<lLFP> a \<bullet> f a y)"
        "y \<lle> (\<lLFP> b \<bullet> g x b)"
      by (auto simp add: le_prod_conv)
  qed
qed

lemma split_lfp1':
  assumes
    a1: "f \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> ab \<bullet> f ab)"
  shows
    "x = (\<lLFP> a \<bullet> \<fst> (f (a, y)))"
  apply (rule split_lfp1 [of "(\<olambda> a b \<bullet> fst (f (a, b)))" "(\<olambda> a b \<bullet> snd (f (a, b)))" "x" "y"])
  using a1 a2
  apply (auto)
  done

lemma split_lfp2':
  assumes
    a1: "f \<in> \<mh>" and
    a2: "(x, y) = (\<lLFP> ab \<bullet> f ab)"
  shows
    "y = (\<lLFP> b \<bullet> \<snd> (f (x, b)))"
  apply (rule split_lfp2 [of "(\<olambda> a b \<bullet> fst (f (a, b)))" "(\<olambda> a b \<bullet> snd (f (a, b)))" "x" "y"])
  using a1 a2
  apply (auto)
  done

lemmas split_lfp' = split_lfp1' split_lfp2'

(*

ML{*

MProver.mclasimpset_of ("wind", @{context})

*}

*)

end


(*  Title:      max.thy
    Author:     1f604
    Date:   8 Jun 2017

Proof for max-element search in non-zero length array
*)

theory max imports Hoare_Logic    begin

(* Search for the maximum element *)
lemma max_search: "VARS m A i
 {True}
 i := 1;
 m := A!0;
 WHILE i < length(A::(int)list)
 INV {(∀j. (j::nat)<(i::nat) ⟶ A!j ≤ (m::int)) ∧ ( ∃k. (k::nat)< length A ⟶ A!k = (m::int))  }
 DO
  IF m < A!i THEN m := A!i ELSE m := m FI;
  i := i+1
 OD
 {(∀j. (j::nat)< length A --> A!j ≤ (m::int)) ∧ ( ∃k. (k::nat)< length A ⟶ A!k = (m::int)) }"
  apply vcg_simp
    apply auto
  using less_Suc_eq by auto

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_71
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun elem :: "Nat => Nat list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

fun t2 :: "Nat => Nat => bool" where
"t2 y (Z) = False"
| "t2 (Z) (S z2) = True"
| "t2 (S x2) (S z2) = t2 x2 z2"

fun ins :: "Nat => Nat list => Nat list" where
"ins y (nil2) = cons2 y (nil2)"
| "ins y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (ins y xs))"

theorem property0 :
  "((~ (x y z)) ==> ((elem y (ins z xs)) = (elem y xs)))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_bin_nat_s
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun toNat :: "Bin => Nat" where
"toNat (One) = S Z"
| "toNat (ZeroAnd xs) = plus (toNat xs) (toNat xs)"
| "toNat (OneAnd ys) = plus (plus (S Z) (toNat ys)) (toNat ys)"

theorem property0 :
  "((toNat (s n)) = (plus (S Z) (toNat n)))"
  oops

end


theory Concrete_Semantics_2_4_ex9
imports Main
begin

fun add:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

fun itadd :: "nat => nat => nat" where
"itadd 0 n = n" |
"itadd (Suc m) n = itadd m (Suc n)"

lemma add_03[simp]: "add m (Suc n) = Suc (add m n)"
apply(induction m arbitrary: n)
apply(auto)
done

lemma "itadd m n = add m n"
apply(induction m arbitrary: n)
apply(auto)
done

end