theory Weak_Expressive_Completeness
imports
  Weak_Bisimilarity_Implies_Equivalence
  Weak_Equivalence_Implies_Bisimilarity
  Disjunction
begin

section \<open>Weak Expressive Completeness\<close>

context indexed_weak_nominal_ts
begin

  subsection \<open>Distinguishing weak formulas\<close>

  text \<open>Lemma \emph{distinguished\_bounded\_support} only shows the existence of a distinguishing
    weak formula, without stating what this formula looks like. We now define an explicit function
    that returns a distinguishing weak formula, in a way that this function is equivariant (on pairs
    of non-weakly-equivalent states).

    Note that this definition uses Hilbert's choice operator~$\varepsilon$, which is not necessarily
    equivariant. This is immediately remedied by a hull construction.\<close>

  definition distinguishing_weak_formula :: "'state \<Rightarrow> 'state \<Rightarrow> ('idx, 'pred, 'act) formula" where
    "distinguishing_weak_formula P Q \<equiv> Conj (Abs_bset {-p \<bullet> (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True})"

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma distinguishing_weak_formula_card_aux:
    "|{-p \<bullet> (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True}| <o natLeq +c |UNIV :: 'idx set|"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    have "?B \<subseteq> (\<lambda>p. -p \<bullet> ?some p) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: perm set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: perm set| <o |UNIV :: 'idx set|"
      by (metis card_idx_perm)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally show ?thesis .
  qed

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma distinguishing_weak_formula_supp_aux:
    assumes "\<not> (P \<equiv>\<cdot> Q)"
    shows "supp (Abs_bset {-p \<bullet> (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))|p. True} :: _ set['idx]) \<subseteq> supp P"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    {
      fix p
      from assms have "\<not> (p \<bullet> P \<equiv>\<cdot> p \<bullet> Q)"
        by (metis weakly_logically_equivalent_eqvt permute_minus_cancel(2))
      then have "supp (?some p) \<subseteq> supp (p \<bullet> P)"
        using distinguished_bounded_support by (metis (mono_tags, lifting) weakly_equivalent_iff_not_distinguished someI_ex)
    }
    note supp_some = this

    {
      fix x
      assume "x \<in> ?B"
      then obtain p where "x = -p \<bullet> ?some p"
        by blast
      with supp_some have "supp (p \<bullet> x) \<subseteq> supp (p \<bullet> P)"
        by simp
      then have "supp x \<subseteq> supp P"
        by (metis (full_types) permute_boolE subset_eqvt supp_eqvt)
    }
    note "*" = this
    have supp_B: "supp ?B \<subseteq> supp P"
      by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)

    from supp_B and distinguishing_weak_formula_card_aux show ?thesis
      using supp_Abs_bset by blast
  qed

  lemma distinguishing_weak_formula_eqvt [simp]:
    assumes "\<not> (P \<equiv>\<cdot> Q)"
    shows "p \<bullet> distinguishing_weak_formula P Q = distinguishing_weak_formula (p \<bullet> P) (p \<bullet> Q)"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{-p \<bullet> ?some p|p. True}"

    from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (rule distinguishing_weak_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    with distinguishing_weak_formula_card_aux have *: "p \<bullet> Conj (Abs_bset ?B) = Conj (Abs_bset (p \<bullet> ?B))"
      by simp

    let ?some' = "\<lambda>p'. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p' \<bullet> p \<bullet> P) \<and> x distinguishes (p' \<bullet> p \<bullet> P) from (p' \<bullet> p \<bullet> Q))"
    let ?B' = "{-p' \<bullet> ?some' p'|p'. True}"

    have "p \<bullet> ?B = ?B'"
    proof
      {
        fix px
        assume "px \<in> p \<bullet> ?B"
        then obtain x where 1: "px = p \<bullet> x" and 2: "x \<in> ?B"
          by (metis (no_types, lifting) image_iff permute_set_eq_image)
        from 2 obtain p' where 3: "x = -p' \<bullet> ?some p'"
          by blast
        from 1 and 3 have "px = -(p' - p) \<bullet> ?some' (p' - p)"
          by simp
        then have "px \<in> ?B'"
          by blast
      }
      then show "p \<bullet> ?B \<subseteq> ?B'"
        by blast
    next
      {
        fix x
        assume "x \<in> ?B'"
        then obtain p' where "x = -p' \<bullet> ?some' p'"
          by blast
        then have "x = p \<bullet> -(p' + p) \<bullet> ?some (p' + p)"
          by (simp add: add.inverse_distrib_swap)
        then have "x \<in> p \<bullet> ?B"
          using mem_permute_iff by blast
      }
      then show "?B' \<subseteq> p \<bullet> ?B"
        by blast
    qed

    with "*" show ?thesis
      unfolding distinguishing_weak_formula_def by simp
  qed

  lemma supp_distinguishing_weak_formula:
    assumes "\<not> (P \<equiv>\<cdot> Q)"
    shows "supp (distinguishing_weak_formula P Q) \<subseteq> supp P"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{- p \<bullet> ?some p|p. True}"

    from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (rule distinguishing_weak_formula_supp_aux)
    moreover from this have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    ultimately show ?thesis
      unfolding distinguishing_weak_formula_def by simp
  qed

  lemma distinguishing_weak_formula_distinguishes:
    assumes "\<not> (P \<equiv>\<cdot> Q)"
    shows "(distinguishing_weak_formula P Q) distinguishes P from Q"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{- p \<bullet> ?some p|p. True}"

    {
      fix p
      from assms have "\<not> (p \<bullet> P) \<equiv>\<cdot> (p \<bullet> Q)"
        by (metis permute_minus_cancel(2) weakly_logically_equivalent_eqvt)
      then have "(?some p) distinguishes (p \<bullet> P) from (p \<bullet> Q)"
        by (metis (mono_tags, lifting) distinguished_bounded_support weakly_equivalent_iff_not_distinguished someI_ex)
    }
    note some_distinguishes = this

    {
      fix P'
      from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
        by (rule distinguishing_weak_formula_supp_aux)
      then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
        using finite_supp rev_finite_subset by blast
      with distinguishing_weak_formula_card_aux have "P' \<Turnstile> distinguishing_weak_formula P Q \<longleftrightarrow> (\<forall>x\<in>?B. P' \<Turnstile> x)"
        unfolding distinguishing_weak_formula_def by simp
    }
    note valid_distinguishing_formula = this

    {
      fix p
      have "P \<Turnstile> -p \<bullet> ?some p"
        by (metis (mono_tags) is_distinguishing_formula_def permute_minus_cancel(2) some_distinguishes valid_eqvt)
    }
    then have "P \<Turnstile> distinguishing_weak_formula P Q"
      using valid_distinguishing_formula by blast

    moreover have "\<not> Q \<Turnstile> distinguishing_weak_formula P Q"
      using valid_distinguishing_formula by (metis (mono_tags, lifting) is_distinguishing_formula_def mem_Collect_eq permute_minus_cancel(1) some_distinguishes valid_eqvt)

    ultimately show "(distinguishing_weak_formula P Q) distinguishes P from Q"
      using is_distinguishing_formula_def by blast
  qed

  lemma distinguishing_weak_formula_is_weak:
    assumes "\<not> (P \<equiv>\<cdot> Q)"
    shows "weak_formula (distinguishing_weak_formula P Q)"
  proof -
    let ?some = "\<lambda>p. (\<some>x. weak_formula x \<and> supp x \<subseteq> supp (p \<bullet> P) \<and> x distinguishes (p \<bullet> P) from (p \<bullet> Q))"
    let ?B = "{- p \<bullet> ?some p|p. True}"

    from assms have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (rule distinguishing_weak_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast

    moreover have "set_bset (Abs_bset ?B :: _ set['idx]) = ?B"
      using distinguishing_weak_formula_card_aux Abs_bset_inverse' by simp

    moreover
    {
      fix x
      assume "x \<in> ?B"
      then obtain p where "x = -p \<bullet> ?some p"
        by blast
      moreover from assms have "\<not> (p \<bullet> P) \<equiv>\<cdot> (p \<bullet> Q)"
        by (metis permute_minus_cancel(2) weakly_logically_equivalent_eqvt)
      then have "weak_formula (?some p)"
        by (metis (mono_tags, lifting) distinguished_bounded_support weakly_equivalent_iff_not_distinguished someI_ex)
      ultimately have "weak_formula x"
        by simp
    }

    ultimately show ?thesis
      unfolding distinguishing_weak_formula_def using wf_Conj by blast
  qed

  subsection \<open>Characteristic weak formulas\<close>

  text \<open>A \emph{characteristic weak formula} for a state~$P$ is valid for (exactly) those states
    that are weakly bisimilar to~$P$.\<close>

  definition characteristic_weak_formula :: "'state \<Rightarrow> ('idx, 'pred, 'act) formula" where
    "characteristic_weak_formula P \<equiv> Conj (Abs_bset {distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)})"

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma characteristic_weak_formula_card_aux:
    "|{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}| <o natLeq +c |UNIV :: 'idx set|"
  proof -
    let ?B = "{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}"

    have "?B \<subseteq> (distinguishing_weak_formula P) ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: 'state set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
      by (metis card_idx_state)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally show ?thesis .
  qed

  \<comment> \<open>just an auxiliary lemma that will be useful further below\<close>
  lemma characteristic_weak_formula_supp_aux:
    shows "supp (Abs_bset {distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)} :: _ set['idx]) \<subseteq> supp P"
  proof -
    let ?B = "{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}"

    {
      fix x
      assume "x \<in> ?B"
      then obtain Q where "x = distinguishing_weak_formula P Q" and "\<not> (P \<equiv>\<cdot> Q)"
        by blast
      with supp_distinguishing_weak_formula have "supp x \<subseteq> supp P"
        by metis
    }
    note "*" = this
    have supp_B: "supp ?B \<subseteq> supp P"
      by (rule set_bounded_supp, fact finite_supp, cut_tac "*", blast)

    from supp_B and characteristic_weak_formula_card_aux show ?thesis
      using supp_Abs_bset by blast
  qed

  lemma characteristic_weak_formula_eqvt (*[eqvt]*) [simp]:
    "p \<bullet> characteristic_weak_formula P = characteristic_weak_formula (p \<bullet> P)"
  proof -
    let ?B = "{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}"

    have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (fact characteristic_weak_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast
    with characteristic_weak_formula_card_aux have *: "p \<bullet> Conj (Abs_bset ?B) = Conj (Abs_bset (p \<bullet> ?B))"
      by simp

    let ?B' = "{distinguishing_weak_formula (p \<bullet> P) Q|Q. \<not> ((p \<bullet> P) \<equiv>\<cdot> Q)}"

    have "p \<bullet> ?B = ?B'"
    proof
      {
        fix px
        assume "px \<in> p \<bullet> ?B"
        then obtain x where 1: "px = p \<bullet> x" and 2: "x \<in> ?B"
          by (metis (no_types, lifting) image_iff permute_set_eq_image)
        from 2 obtain Q where 3: "x = distinguishing_weak_formula P Q" and 4: "\<not> (P \<equiv>\<cdot> Q)"
          by blast
        with 1 have "px = distinguishing_weak_formula (p \<bullet> P) (p \<bullet> Q)"
          by simp
        moreover from 4 have "\<not> (p \<bullet> P) \<equiv>\<cdot> (p \<bullet> Q)"
          by (metis weakly_logically_equivalent_eqvt permute_minus_cancel(2))
        ultimately have "px \<in> ?B'"
          by blast
      }
      then show "p \<bullet> ?B \<subseteq> ?B'"
        by blast
    next
      {
        fix x
        assume "x \<in> ?B'"
        then obtain Q where 1: "x = distinguishing_weak_formula (p \<bullet> P) Q" and 2: "\<not> (p \<bullet> P) \<equiv>\<cdot> Q"
          by blast
        from 2 have "\<not> P \<equiv>\<cdot> (-p \<bullet> Q)"
          by (metis weakly_logically_equivalent_eqvt permute_minus_cancel(1))
        moreover from this and 1 have "x = p \<bullet> distinguishing_weak_formula P (-p \<bullet> Q)"
          by simp
        ultimately have "x \<in> p \<bullet> ?B"
          using mem_permute_iff by blast
      }
      then show "?B' \<subseteq> p \<bullet> ?B"
        by blast
    qed

    with "*" show ?thesis
      unfolding characteristic_weak_formula_def by simp
  qed

  lemma characteristic_weak_formula_eqvt_raw [simp]:
    "p \<bullet> characteristic_weak_formula = characteristic_weak_formula"
    by (simp add: permute_fun_def)

  lemma characteristic_weak_formula_is_weak:
    "weak_formula (characteristic_weak_formula P)"
  proof -
    let ?B = "{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}"

    have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
      by (fact characteristic_weak_formula_supp_aux)
    then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast

    moreover have "set_bset (Abs_bset ?B :: _ set['idx]) = ?B"
      using characteristic_weak_formula_card_aux Abs_bset_inverse' by simp

    moreover
    {
      fix x
      assume "x \<in> ?B"
      then have "weak_formula x"
        using distinguishing_weak_formula_is_weak by blast
    }

    ultimately show ?thesis
      unfolding characteristic_weak_formula_def using wf_Conj by presburger
  qed

  lemma characteristic_weak_formula_is_characteristic':
    "Q \<Turnstile> characteristic_weak_formula P \<longleftrightarrow> P \<equiv>\<cdot> Q"
  proof -
    let ?B = "{distinguishing_weak_formula P Q|Q. \<not> (P \<equiv>\<cdot> Q)}"

    {
      fix P'
      have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp P"
        by (fact characteristic_weak_formula_supp_aux)
      then have "finite (supp (Abs_bset ?B :: _ set['idx]))"
        using finite_supp rev_finite_subset by blast
      with characteristic_weak_formula_card_aux have "P' \<Turnstile> characteristic_weak_formula P \<longleftrightarrow> (\<forall>x\<in>?B. P' \<Turnstile> x)"
        unfolding characteristic_weak_formula_def by simp
    }
    note valid_characteristic_formula = this

    show ?thesis
    proof
      assume *: "Q \<Turnstile> characteristic_weak_formula P"
      show "P \<equiv>\<cdot> Q"
      proof (rule ccontr)
        assume "\<not> (P \<equiv>\<cdot> Q)"
        with "*" show False
          using distinguishing_weak_formula_distinguishes is_distinguishing_formula_def valid_characteristic_formula by auto
      qed
    next
      assume "P \<equiv>\<cdot> Q"
      moreover have "P \<Turnstile> characteristic_weak_formula P"
        using distinguishing_weak_formula_distinguishes is_distinguishing_formula_def valid_characteristic_formula by auto
      ultimately show "Q \<Turnstile> characteristic_weak_formula P"
        using weakly_logically_equivalent_def characteristic_weak_formula_is_weak by blast
    qed
  qed

  lemma characteristic_weak_formula_is_characteristic:
    "Q \<Turnstile> characteristic_weak_formula P \<longleftrightarrow> P \<approx>\<cdot> Q"
    using characteristic_weak_formula_is_characteristic' by (meson weak_bisimilarity_implies_weak_equivalence weak_equivalence_implies_weak_bisimilarity)

  subsection \<open>Weak expressive completeness\<close>

  text \<open>Every finitely supported set of states that is closed under weak bisimulation can be
    described by a weak formula; namely, by a disjunction of characteristic weak formulas.\<close>

  theorem weak_expressive_completeness:
    assumes "finite (supp S)"
    and "\<And>P Q. P \<in> S \<Longrightarrow> P \<approx>\<cdot> Q \<Longrightarrow> Q \<in> S"
    shows "P \<Turnstile> Disj (Abs_bset (characteristic_weak_formula ` S)) \<longleftrightarrow> P \<in> S"
    and "weak_formula (Disj (Abs_bset (characteristic_weak_formula ` S)))"
  proof -
    let ?B = "characteristic_weak_formula ` S"

    have "?B \<subseteq> characteristic_weak_formula ` UNIV"
      by auto
    then have "|?B| \<le>o |UNIV :: 'state set|"
      by (rule surj_imp_ordLeq)
    also have "|UNIV :: 'state set| <o |UNIV :: 'idx set|"
      by (metis card_idx_state)
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally have card_B: "|?B| <o natLeq +c |UNIV :: 'idx set|" .

    have "eqvt image" and "eqvt characteristic_weak_formula"
      by (simp add: eqvtI)+
    then have supp_B: "supp ?B \<subseteq> supp S"
      using supp_fun_eqvt supp_fun_app supp_fun_app_eqvt by blast
    with card_B have "supp (Abs_bset ?B :: _ set['idx]) \<subseteq> supp S"
      using supp_Abs_bset by blast
    with \<open>finite (supp S)\<close> have "finite (supp (Abs_bset ?B :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast

    with card_B have "P \<Turnstile> Disj (Abs_bset (characteristic_weak_formula ` S)) \<longleftrightarrow> (\<exists>x\<in>?B. P \<Turnstile> x)"
      by simp

    with \<open>\<And>P Q. P \<in> S \<Longrightarrow> P \<approx>\<cdot> Q \<Longrightarrow> Q \<in> S\<close> show "P \<Turnstile> Disj (Abs_bset (characteristic_weak_formula ` S)) \<longleftrightarrow> P \<in> S"
      using characteristic_weak_formula_is_characteristic characteristic_weak_formula_is_characteristic' weakly_logically_equivalent_def by fastforce

    \<comment> \<open>it remains to show that the disjunction is a weak formula\<close>

    have "eqvt Formula.Not"
      by (simp add: eqvtI)
    with supp_B and \<open>eqvt image\<close> have supp_Not_B: "supp (Formula.Not ` ?B) \<subseteq> supp S"
      using supp_fun_eqvt supp_fun_app supp_fun_app_eqvt by blast

    have "|Formula.Not ` ?B| \<le>o |?B|"
      by simp
    also note card_B
    finally have card_not_B: "|Formula.Not ` ?B| <o natLeq +c |UNIV :: 'idx set|" .

    with supp_Not_B have "supp (Abs_bset (Formula.Not ` ?B) :: _ set['idx]) \<subseteq> supp S"
      using supp_Abs_bset by blast
    with \<open>finite (supp S)\<close> have "finite (supp (Abs_bset (Formula.Not ` ?B) :: _ set['idx]))"
      using finite_supp rev_finite_subset by blast

    moreover have "\<And>x. x \<in> Formula.Not ` ?B \<Longrightarrow> weak_formula x"
      using characteristic_weak_formula_is_weak wf_Not by auto

    moreover from card_B have *: "map_bset Formula.Not (Abs_bset ?B :: _ set['idx]) = (Abs_bset (Formula.Not ` ?B) :: _ set['idx])"
      using map_bset.abs_eq[unfolded eq_onp_def] by blast

    moreover from card_not_B have "set_bset (Abs_bset (Formula.Not ` ?B) :: _ set['idx]) = Formula.Not ` ?B"
      by simp

    ultimately show "weak_formula (Disj (Abs_bset (characteristic_weak_formula ` S)))"
      unfolding Disj_def by (metis wf_Conj wf_Not)
  qed

end

end


theory regexp_Star
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (s :: A list) .
     (recognise (Star p) s) = (recognise (Plus Eps (Seq p (Star p))) s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      HOL/HOLCF/IOA/Simulations.thy
    Author:     Olaf Müller
*)

section \<open>Simulations in HOLCF/IOA\<close>

theory Simulations
imports RefCorrectness
begin

default_sort type

definition is_simulation :: "('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_simulation R C A \<longleftrightarrow>
    (\<forall>s \<in> starts_of C. R``{s} \<inter> starts_of A \<noteq> {}) \<and>
    (\<forall>s s' t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<and> (s, s') \<in> R
      \<longrightarrow> (\<exists>t' ex. (t, t') \<in> R \<and> move A ex s' a t'))"

definition is_backward_simulation :: "('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_backward_simulation R C A \<longleftrightarrow>
    (\<forall>s \<in> starts_of C. R``{s} \<subseteq> starts_of A) \<and>
    (\<forall>s t t' a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<and> (t, t') \<in> R
      \<longrightarrow> (\<exists>ex s'. (s,s') \<in> R \<and> move A ex s' a t'))"

definition is_forw_back_simulation ::
    "('s1 \<times> 's2 set) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_forw_back_simulation R C A \<longleftrightarrow>
    (\<forall>s \<in> starts_of C. \<exists>S'. (s, S') \<in> R \<and> S' \<subseteq> starts_of A) \<and>
    (\<forall>s S' t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<and> (s, S') \<in> R
      \<longrightarrow> (\<exists>T'. (t, T') \<in> R \<and> (\<forall>t' \<in> T'. \<exists>s' \<in> S'. \<exists>ex. move A ex s' a t')))"

definition is_back_forw_simulation ::
    "('s1 \<times> 's2 set) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_back_forw_simulation R C A \<longleftrightarrow>
    ((\<forall>s \<in> starts_of C. \<forall>S'. (s, S') \<in> R \<longrightarrow> S' \<inter> starts_of A \<noteq> {}) \<and>
    (\<forall>s t T' a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<and> (t, T') \<in> R
      \<longrightarrow> (\<exists>S'. (s, S') \<in> R \<and> (\<forall>s' \<in> S'. \<exists>t' \<in> T'. \<exists>ex. move A ex s' a t'))))"

definition is_history_relation :: "('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_history_relation R C A \<longleftrightarrow>
    is_simulation R C A \<and> is_ref_map (\<lambda>x. (SOME y. (x, y) \<in> R\<inverse>)) A C"

definition is_prophecy_relation :: "('s1 \<times> 's2) set \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_prophecy_relation R C A \<longleftrightarrow>
    is_backward_simulation R C A \<and> is_ref_map (\<lambda>x. (SOME y. (x, y) \<in> R\<inverse>)) A C"

lemma set_non_empty: "A \<noteq> {} \<longleftrightarrow> (\<exists>x. x \<in> A)"
  by auto

lemma Int_non_empty: "A \<inter> B \<noteq> {} \<longleftrightarrow> (\<exists>x. x \<in> A \<and> x \<in> B)"
  by (simp add: set_non_empty)

lemma Sim_start_convert [simp]: "R``{x} \<inter> S \<noteq> {} \<longleftrightarrow> (\<exists>y. (x, y) \<in> R \<and> y \<in> S)"
  by (simp add: Image_def Int_non_empty)

lemma ref_map_is_simulation: "is_ref_map f C A \<Longrightarrow> is_simulation {p. snd p = f (fst p)} C A"
  by (simp add: is_ref_map_def is_simulation_def)

end


theory Tensor_Product_Code
  imports Tensor_Product Complex_Bounded_Operators.Cblinfun_Code
begin

unbundle cblinfun_notation

definition "matrix_tensor (A::'a::times mat) (B::'a mat) =
  mat (dim_row A*dim_row B) (dim_col A*dim_col B)
  (\<lambda>(r,c). index_mat A (r div dim_row B, c div dim_col B) *
           index_mat B (r mod dim_row B, c mod dim_col B))"

lemma bounded_of_mat_tensorOp[code]:
  "mat_of_cblinfun (tensorOp A B) = matrix_tensor (mat_of_cblinfun A) (mat_of_cblinfun B)"
  for A :: "('a::enum,'b::enum) l2bounded"
    and B :: "('c::enum,'d::enum) l2bounded"
  sorry

lemma bounded_of_mat_assoc_op[code]:
  "mat_of_cblinfun (assoc_op :: ('a::enum*'b::enum*'c::enum,_) l2bounded) = one_mat (Enum.card_UNIV TYPE('a)*Enum.card_UNIV TYPE('b)*Enum.card_UNIV TYPE('c))"
  sorry

definition "comm_op_mat TYPE('a::enum) TYPE('b::enum) =
  (let da = Enum.card_UNIV TYPE('a); db = Enum.card_UNIV TYPE('b) in
  mat (da*db) (da*db)
  (\<lambda>(r,c). (if (r div da = c mod db \<and>
                r mod da = c div db) then 1 else 0)))"

lemma bounded_of_mat_comm_op[code]:
  "mat_of_cblinfun (comm_op :: ('a::enum*'b::enum,_) l2bounded) = comm_op_mat TYPE('a) TYPE('b)"
  sorry

definition "vec_tensor (A::'a::times vec) (B::'a vec) =
  vec (dim_vec A*dim_vec B)
  (\<lambda>r. vec_index A (r div dim_vec B) *
       vec_index B (r mod dim_vec B))"

lemma tensorVec_code[code]: "vec_of_ell2 (\<psi> \<otimes> \<phi>) = vec_tensor (vec_of_ell2 \<psi>) (vec_of_ell2 \<phi>)"
  for \<psi>::"'a::enum ell2" and \<phi>::"'b::enum ell2"
  sorry

(* See comment at definition of remove_qvar_unit_op before proving *)
lemma mat_of_cblinfun_remove_qvar_unit_op[code]:
  "mat_of_cblinfun (remove_qvar_unit_op::(_,'a::enum) l2bounded) = mat_of_cblinfun (id_cblinfun::(_,'a) l2bounded)"
  sorry

(* TODO: more direct code equation (w/o remove_qvar_unit_op) *)
lemma addState_remove_qvar_unit_op[code]: "addState \<psi> = id_cblinfun \<otimes> (vector_to_cblinfun \<psi>) o\<^sub>C\<^sub>L remove_qvar_unit_op*"
  sorry

lemma tensorSpace_SPAN[code]: "tensorSpace (SPAN A) (SPAN B) = SPAN [vec_tensor a b. a<-A, b<-B]"
  sorry

unbundle no_cblinfun_notation

end


(*  Title:      HOL/Semiring_Normalization.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section {* Semiring normalization *}

theory Semiring_Normalization
imports Numeral_Simprocs Nat_Transfer
begin

text {* Prelude *}

class comm_semiring_1_cancel_crossproduct = comm_semiring_1_cancel +
  assumes crossproduct_eq: "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
begin

lemma crossproduct_noteq:
  "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> a * c + b * d \<noteq> a * d + b * c"
  by (simp add: crossproduct_eq)

lemma add_scale_eq_noteq:
  "r \<noteq> 0 \<Longrightarrow> a = b \<and> c \<noteq> d \<Longrightarrow> a + r * c \<noteq> b + r * d"
proof (rule notI)
  assume nz: "r\<noteq> 0" and cnd: "a = b \<and> c\<noteq>d"
    and eq: "a + (r * c) = b + (r * d)"
  have "(0 * d) + (r * c) = (0 * c) + (r * d)"
    using add_imp_eq eq mult_zero_left by (simp add: cnd)
  then show False using crossproduct_eq [of 0 d] nz cnd by simp
qed

lemma add_0_iff:
  "b = b + a \<longleftrightarrow> a = 0"
  using add_imp_eq [of b a 0] by auto

end

subclass (in idom) comm_semiring_1_cancel_crossproduct
proof
  fix w x y z
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
  proof
    assume "w * y + x * z = w * z + x * y"
    then have "w * y + x * z - w * z - x * y = 0" by (simp add: algebra_simps)
    then have "w * (y - z) - x * (y - z) = 0" by (simp add: algebra_simps)
    then have "(y - z) * (w - x) = 0" by (simp add: algebra_simps)
    then have "y - z = 0 \<or> w - x = 0" by (rule divisors_zero)
    then show "w = x \<or> y = z" by auto
  qed (auto simp add: ac_simps)
qed

instance nat :: comm_semiring_1_cancel_crossproduct
proof
  fix w x y z :: nat
  have aux: "\<And>y z. y < z \<Longrightarrow> w * y + x * z = w * z + x * y \<Longrightarrow> w = x"
  proof -
    fix y z :: nat
    assume "y < z" then have "\<exists>k. z = y + k \<and> k \<noteq> 0" by (intro exI [of _ "z - y"]) auto
    then obtain k where "z = y + k" and "k \<noteq> 0" by blast
    assume "w * y + x * z = w * z + x * y"
    then have "(w * y + x * y) + x * k = (w * y + x * y) + w * k" by (simp add: `z = y + k` algebra_simps)
    then have "x * k = w * k" by simp
    then show "w = x" using `k \<noteq> 0` by simp
  qed
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
    by (auto simp add: neq_iff dest!: aux)
qed

text {* Semiring normalization proper *}

ML_file "Tools/semiring_normalizer.ML"

context comm_semiring_1
begin

lemma normalizing_semiring_ops:
  shows "TERM (x + y)" and "TERM (x * y)" and "TERM (x ^ n)"
    and "TERM 0" and "TERM 1" .

lemma normalizing_semiring_rules:
  "(a * m) + (b * m) = (a + b) * m"
  "(a * m) + m = (a + 1) * m"
  "m + (a * m) = (a + 1) * m"
  "m + m = (1 + 1) * m"
  "0 + a = a"
  "a + 0 = a"
  "a * b = b * a"
  "(a + b) * c = (a * c) + (b * c)"
  "0 * a = 0"
  "a * 0 = 0"
  "1 * a = a"
  "a * 1 = a"
  "(lx * ly) * (rx * ry) = (lx * rx) * (ly * ry)"
  "(lx * ly) * (rx * ry) = lx * (ly * (rx * ry))"
  "(lx * ly) * (rx * ry) = rx * ((lx * ly) * ry)"
  "(lx * ly) * rx = (lx * rx) * ly"
  "(lx * ly) * rx = lx * (ly * rx)"
  "lx * (rx * ry) = (lx * rx) * ry"
  "lx * (rx * ry) = rx * (lx * ry)"
  "(a + b) + (c + d) = (a + c) + (b + d)"
  "(a + b) + c = a + (b + c)"
  "a + (c + d) = c + (a + d)"
  "(a + b) + c = (a + c) + b"
  "a + c = c + a"
  "a + (c + d) = (a + c) + d"
  "(x ^ p) * (x ^ q) = x ^ (p + q)"
  "x * (x ^ q) = x ^ (Suc q)"
  "(x ^ q) * x = x ^ (Suc q)"
  "x * x = x\<^sup>2"
  "(x * y) ^ q = (x ^ q) * (y ^ q)"
  "(x ^ p) ^ q = x ^ (p * q)"
  "x ^ 0 = 1"
  "x ^ 1 = x"
  "x * (y + z) = (x * y) + (x * z)"
  "x ^ (Suc q) = x * (x ^ q)"
  "x ^ (2*n) = (x ^ n) * (x ^ n)"
  "x ^ (Suc (2*n)) = x * ((x ^ n) * (x ^ n))"
  by (simp_all add: algebra_simps power_add power2_eq_square
    power_mult_distrib power_mult del: one_add_one)

lemmas normalizing_comm_semiring_1_axioms =
  comm_semiring_1_axioms [normalizer
    semiring ops: normalizing_semiring_ops
    semiring rules: normalizing_semiring_rules]

declaration
  {* Semiring_Normalizer.semiring_funs @{thm normalizing_comm_semiring_1_axioms} *}

end

context comm_ring_1
begin

lemma normalizing_ring_ops: shows "TERM (x- y)" and "TERM (- x)" .

lemma normalizing_ring_rules:
  "- x = (- 1) * x"
  "x - y = x + (- y)"
  by simp_all

lemmas normalizing_comm_ring_1_axioms =
  comm_ring_1_axioms [normalizer
    semiring ops: normalizing_semiring_ops
    semiring rules: normalizing_semiring_rules
    ring ops: normalizing_ring_ops
    ring rules: normalizing_ring_rules]

declaration
  {* Semiring_Normalizer.semiring_funs @{thm normalizing_comm_ring_1_axioms} *}

end

context comm_semiring_1_cancel_crossproduct
begin

declare
  normalizing_comm_semiring_1_axioms [normalizer del]

lemmas
  normalizing_comm_semiring_1_cancel_crossproduct_axioms =
  comm_semiring_1_cancel_crossproduct_axioms [normalizer
    semiring ops: normalizing_semiring_ops
    semiring rules: normalizing_semiring_rules
    idom rules: crossproduct_noteq add_scale_eq_noteq]

declaration
  {* Semiring_Normalizer.semiring_funs @{thm normalizing_comm_semiring_1_cancel_crossproduct_axioms} *}

end

context idom
begin

declare normalizing_comm_ring_1_axioms [normalizer del]

lemmas normalizing_idom_axioms = idom_axioms [normalizer
  semiring ops: normalizing_semiring_ops
  semiring rules: normalizing_semiring_rules
  ring ops: normalizing_ring_ops
  ring rules: normalizing_ring_rules
  idom rules: crossproduct_noteq add_scale_eq_noteq
  ideal rules: right_minus_eq add_0_iff]

declaration
  {* Semiring_Normalizer.semiring_funs @{thm normalizing_idom_axioms} *}

end

context field
begin

lemma normalizing_field_ops:
  shows "TERM (x / y)" and "TERM (inverse x)" .

lemmas normalizing_field_rules = divide_inverse inverse_eq_divide

lemmas normalizing_field_axioms =
  field_axioms [normalizer
    semiring ops: normalizing_semiring_ops
    semiring rules: normalizing_semiring_rules
    ring ops: normalizing_ring_ops
    ring rules: normalizing_ring_rules
    field ops: normalizing_field_ops
    field rules: normalizing_field_rules
    idom rules: crossproduct_noteq add_scale_eq_noteq
    ideal rules: right_minus_eq add_0_iff]

declaration
  {* Semiring_Normalizer.field_funs @{thm normalizing_field_axioms} *}

end

hide_fact (open) normalizing_comm_semiring_1_axioms
  normalizing_comm_semiring_1_cancel_crossproduct_axioms normalizing_semiring_ops normalizing_semiring_rules

hide_fact (open) normalizing_comm_ring_1_axioms
  normalizing_idom_axioms normalizing_ring_ops normalizing_ring_rules

hide_fact (open) normalizing_field_axioms normalizing_field_ops normalizing_field_rules

code_identifier
  code_module Semiring_Normalization \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


text\<open>
Interpreter.thy defines a simple programming language over interval-valued variables and executable
semantics (interpreter) for that language. We then prove that the interpretation of interval terms
is a sound over-approximation of a real-valued semantics of the same language.

Our language is a version of first order dynamic logic-style regular programs.
We use a finite identifier space for compatibility with Differential-Dynamic-Logic, where identifier
finiteness is required to treat program states as Banach spaces to enable differentiation.
\<close>
(* Author:     Brandon Bohrer *)
theory Interpreter
imports
  Complex_Main
  Finite_String
  Interval_Word32
begin

section\<open>Syntax\<close>
text\<open>Our term language supports variables, polynomial arithmetic, and extrema. This choice was made
   based on the needs of the original paper and could be extended if necessary.\<close>
datatype  trm =
  Var fin_string
| Const lit
| Plus trm trm
| Times trm trm
| Neg trm
| Max trm trm
| Min trm trm
| Abs trm

text\<open>Our statement language is nondeterministic first-order regular programs.
 This coincides with the discrete subset of hybrid programs from the dL entry.

Our assertion language are the formulas of first-order dynamic logic\<close>
datatype prog =
  Assign fin_string "trm"     (infixr ":=" 10)
| AssignAny fin_string
| Test "formula"              ("?")
| Choice "prog" "prog"        (infixl "\<union>\<union>" 10)
| Sequence "prog"  "prog"     (infixr ";;" 8)
| Loop "prog"                 ("_**")

and formula =
  Geq "trm" "trm"
| Not "formula"                        ("!")
| And "formula" "formula"              (infixl "&&" 8)
| Exists fin_string "formula"
| Diamond "prog" "formula"               ("(\<langle> _ \<rangle> _)" 10)

text\<open>Derived forms\<close>
definition Or :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixl "||" 7)
where or_simp[simp]:"Or P Q = Not (And (Not P) (Not Q))"

definition Equals :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where equals_simp[simp]:"Equals \<theta> \<theta>' = (And (Geq \<theta> \<theta>') (Geq \<theta>' \<theta>))"

definition Greater :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where greater_simp[simp]:"Greater \<theta> \<theta>' = Not (Geq \<theta>' \<theta>)"

definition Leq :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where leq_simp[simp]:"Leq \<theta> \<theta>' = (Geq \<theta>' \<theta>)"

definition Less :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where less_simp[simp]:"Less \<theta> \<theta>' = (Not (Geq \<theta> \<theta>'))"

section \<open>Semantics\<close>
text\<open> States over reals vs. word intervals which contain them\<close>
type_synonym rstate = "fin_string \<Rightarrow> real"
type_synonym wstate = "(fin_string + fin_string) \<Rightarrow> word"

definition wstate::"wstate \<Rightarrow> prop"
where wstate_def[simp]:"wstate \<nu> \<equiv> (\<And>i. word (\<nu> (Inl i)) \<and> word (\<nu> (Inr i)))"

text\<open>Interpretation of a term in a state\<close>
inductive rtsem :: "trm \<Rightarrow> rstate \<Rightarrow> real  \<Rightarrow> bool"  ("([_]_ \<down> _)" 10)
  where
  rtsem_Const:"Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> ([Const w]\<nu> \<down> r)"
| rtsem_Var:"([Var x]\<nu> \<down> \<nu> x)"
| rtsem_Plus:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 + r2))"
| rtsem_Times:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 * r2))"
| rtsem_Max:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Max \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (max r1 r2))"
| rtsem_Min:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Min \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (min r1 r2))"
| rtsem_Abs:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1)\<rbrakk> \<Longrightarrow> ([Abs \<theta>\<^sub>1]\<nu> \<down> (abs r1))"
| rtsem_Neg:"([\<theta>]\<nu> \<down> r) \<Longrightarrow> ([Neg \<theta>]\<nu> \<down> -r)"

inductive_simps
    rtsem_Const_simps[simp] : "([(Const w)]\<nu> \<down> r)"
and rtsem_Var_simps[simp] : "([Var x]\<nu> \<down> r)"
and rtsem_PlusU_simps[simp] : "([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_TimesU_simps[simp] : "([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_Max_simps[simp] : "([Max \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Min_simps[simp] : "([Min \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Abs_simps[simp] : "([Abs \<theta>] \<nu> \<down> r)"
and rtsem_Neg_simps[simp] : "([Neg \<theta>] \<nu> \<down> r)"

definition set_less :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "<\<^sub>S" 10)
where "set_less A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x < y)"

definition set_geq :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "\<ge>\<^sub>S" 10)
where "set_geq A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x \<ge> y)"

text\<open>Interpretation of an assertion in a state\<close>
inductive rfsem :: "formula \<Rightarrow> rstate \<Rightarrow> bool \<Rightarrow> bool" ("([_]_) \<downharpoonright> _" 20)
where
  rGreaterT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 > r2 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGreaterF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 \<ge> r1 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rGeqT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<ge> r2 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGeqF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 > r1 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rEqualsT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 = r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rEqualsF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<noteq> r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rAndT:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); ([\<psi>]\<nu> \<downharpoonright> True)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rAndF1:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rAndF2:"([\<psi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rOrT1:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrT2:"([\<psi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrF:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> False) ;([\<psi>]\<nu> \<downharpoonright> False)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rNotT:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> True)"
| rNotF:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> False)"

inductive_simps
    rfsem_Greater_simps[simp]: "([Greater \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Geq_simps[simp]: "([Geq \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Equals_simps[simp]: "([Equals \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_And_simps[simp]: "([And \<phi>  \<psi>]\<nu> \<downharpoonright> b)"
and rfsem_Or_simps[simp]: "([(Or \<phi> \<psi>)]\<nu> \<downharpoonright> b)"
and rfsem_Not_simps[simp]: "([Not \<phi>]\<nu> \<downharpoonright> b)"

text\<open>Interpretation of a program is a transition relation on states\<close>
inductive rpsem :: "prog \<Rightarrow> rstate \<Rightarrow>  rstate \<Rightarrow> bool" ("([_]_) \<downharpoonleft> _" 20)
where
  rTest[simp]:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); \<nu> = \<omega>\<rbrakk> \<Longrightarrow> ([? \<phi>]\<nu> \<downharpoonleft> \<omega>)"
| rSeq[simp]:"\<lbrakk>([\<alpha>]\<nu> \<downharpoonleft> \<mu>); ([\<beta>]\<mu> \<downharpoonleft> \<omega>)\<rbrakk> \<Longrightarrow> ([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rAssign[simp]:"\<lbrakk>([\<theta>]\<nu> \<down> r); \<omega> = (\<nu> (x := r))\<rbrakk> \<Longrightarrow> ([Assign x \<theta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice1[simp]:"([\<alpha>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice2[simp]:"([\<beta>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"

inductive_simps
    rpsem_Test_simps[simp]: "([? \<phi>]\<nu> \<downharpoonleft> b)"
and rpsem_Seq_simps[simp]: "([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> b)"
and rpsem_Assign_simps[simp]: "([Assign x \<theta>]\<nu> \<downharpoonleft> b)"
and rpsem_Choice_simps[simp]: "([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> b)"

text\<open>Upper bound of arbitrary term\<close>
fun wtsemU :: "trm \<Rightarrow> wstate \<Rightarrow>  word * word " ("([_]<>_)" 20)
where "([Const r]<>\<nu>) = (Rep_bword r::word, Rep_bword r)"
| wVarU:"([Var x]<>\<nu>) = (\<nu> (Inl x), \<nu> (Inr x))"
| wPlusU:"([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (pl l1 l2, pu u1 u2))"
| wTimesU:"([(Times \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (tl l1 u1 l2 u2, tu l1 u1 l2 u2))"
| wMaxU:"([(Max \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmax l1 l2, wmax u1 u2))"
| wMinU:"([(Min \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmin l1 l2, wmin u1 u2))"
| wNegU:"([(Neg \<theta>)]<> \<nu>) =
  (let (l, u) = [\<theta>]<> \<nu> in
   (wneg u, wneg l))"
| wAbsU:"([(Abs \<theta>\<^sub>1)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
  (wmax l1 (wneg u1), wmax u1 (wneg l1)))"

inductive wfsem :: "formula \<Rightarrow> wstate \<Rightarrow> bool \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wGreaterT:"wgreater (fst ([\<theta>\<^sub>1]<>\<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGreaterF:"wgeq (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wGeqT:"wgeq (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGeqF:"wgreater (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wEqualsT:"\<lbrakk>(fst ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>2]<>\<nu>)); (snd ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>1]<>\<nu>));
             (snd ([\<theta>\<^sub>1]<>\<nu>) = fst ([\<theta>\<^sub>1]<>\<nu>)); (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> NEG_INF);
             (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> POS_INF)\<rbrakk>
         \<Longrightarrow> ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> True)"
| wEqualsF1:"wgreater (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wEqualsF2:"wgreater (fst ([\<theta>\<^sub>2]<> \<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wAndT:"\<lbrakk>[[\<phi>]]\<nu> \<down> True; [[\<psi>]]\<nu> \<down> True\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> True)"
| wAndF1:"[[\<phi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wAndF2:"[[\<psi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wOrT1:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrT2:"([[\<psi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrF:"\<lbrakk>[[\<phi>]]\<nu> \<down> False; [[\<psi>]]\<nu> \<down> False\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wNotT:"([[\<phi>]]\<nu> \<down> False) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> True)"
| wNotF:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> False)"

inductive_simps
    wfsem_Gr_simps[simp]: "([[Le \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"
and wfsem_And_simps[simp]: "([[And \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Or_simps[simp]: "([[Or \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Not_simps[simp]: "([[Not \<phi>]]\<nu> \<down> b)"
and wfsem_Equals_simps[simp]: "([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"

text\<open>Program semantics\<close>
inductive wpsem :: "prog \<Rightarrow>  wstate \<Rightarrow> wstate \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wTest:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> \<nu> = \<omega> \<Longrightarrow> ([[? \<phi>]] \<nu> \<down> \<omega>)"
| wSeq:"([[\<alpha>]]\<nu> \<down> \<mu>) \<Longrightarrow> ([[\<beta>]] \<mu> \<down> \<omega>) \<Longrightarrow> ([[\<alpha>;; \<beta>]] \<nu> \<down> \<omega>)"
| wAssign:"\<omega> = ((\<nu> ((Inr x) := snd([\<theta>]<>\<nu>))) ((Inl x) := fst([\<theta>]<>\<nu>))) \<Longrightarrow> ([[Assign x \<theta>]] \<nu> \<down> \<omega>)"
| wChoice1[simp]:"([[\<alpha>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"
| wChoice2[simp]:"([[\<beta>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"

inductive_simps
    wpsem_Test_simps[simp]: "([[Test \<phi>]]\<nu> \<down> b)"
and wpsem_Seq_simps[simp]: "([[\<alpha>;; \<beta>]]\<nu> \<down> b)"
and wpsem_Assign_simps[simp]: "([[Assign x \<theta>]]\<nu> \<down> b)"
and wpsem_Choice_simps[simp]: "([[Choice \<alpha> \<beta>]]\<nu> \<down> b)"

lemmas real_max_mono =  Lattices.linorder_class.max.mono
lemmas real_minus_le_minus = Groups.ordered_ab_group_add_class.neg_le_iff_le

text\<open>Interval state consists of upper and lower bounds for each real variable\<close>
inductive represents_state::"wstate \<Rightarrow> rstate \<Rightarrow> bool" (infix "REP" 10)
where REPI:"(\<And>x. (\<nu> (Inl x) \<equiv>\<^sub>L \<nu>' x) \<and> (\<nu> (Inr x) \<equiv>\<^sub>U \<nu>' x)) \<Longrightarrow> (\<nu> REP \<nu>')"

inductive_simps repstate_simps:"\<nu> REP \<nu>'"

section\<open>Soundness proofs\<close>
text\<open>Interval term valuation soundly contains real valuation\<close>
lemma trm_sound:
  fixes \<theta>::"trm"
  shows "([\<theta>]\<nu>' \<down> r) \<Longrightarrow> (\<nu> REP \<nu>') \<Longrightarrow>   ([\<theta>]<>\<nu>) \<equiv>\<^sub>P r"
proof (induction rule: rtsem.induct)
 case rtsem_Const
   fix w r \<nu>'
   show "Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> [Const w]<>\<nu> \<equiv>\<^sub>P r"
     using repU_def repL_def repP_def repe.simps rep_simps repstate_simps
     by auto
next
 case rtsem_Var
   fix x \<nu>'
   show "\<nu> REP \<nu>' \<Longrightarrow> [Var x]<>\<nu> \<equiv>\<^sub>P \<nu>' x"
   by(auto simp add: repU_def repL_def repP_def repe.simps rep_simps repstate_simps)
next
 case rtsem_Plus
   fix \<theta>\<^sub>1 :: "trm" and \<nu>':: "rstate" and r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume rep:"\<nu> REP \<nu>'"
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"(l1, u1) = ([\<theta>\<^sub>1]<> \<nu>)"
    and lu2:"(l2, u2) = ([\<theta>\<^sub>2]<> \<nu>)"
    using IH1 IH2 repP_def by auto
   from lu1 and lu2 have
        lu1':"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2':"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Plus \<theta>\<^sub>1 \<theta>\<^sub>2)]<>\<nu>) = (pl l1 l2, pu u1 u2)"
   using lu1' lu2' by auto
  have lBound:"(pl l1 l2 \<equiv>\<^sub>L r1 + r2)"
    using l1 l2 pl_lemma by auto
  have uBound:"(pu u1 u2 \<equiv>\<^sub>U r1 + r2)"
    using pu_lemma[OF u1 u2] by auto
  have "(pl l1 l2, pu u1 u2) \<equiv>\<^sub>P (r1 + r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show"[Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 + r2"
    using lu1' lu2' by auto
next
 case rtsem_Times
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and r2
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1))"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2))"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
    obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1) "
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Times \<theta>\<^sub>1  \<theta>\<^sub>2)]<>\<nu>) = (tl l1 u1 l2 u2, tu l1 u1 l2 u2)"
   using lu1 lu2 unfolding wTimesU Let_def by auto
  have lBound:"(tl l1 u1 l2 u2 \<equiv>\<^sub>L r1 * r2)"
    using l1 u1 l2 u2 tl_lemma by auto
  have uBound:"(tu l1 u1 l2 u2 \<equiv>\<^sub>U r1 * r2)"
    using l1 u1 l2 u2 tu_lemma by auto
  have "(tl l1 u1 l2 u2, tu l1 u1 l2 u2) \<equiv>\<^sub>P (r1 * r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show "[Times \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 * r2"
    using lu1 lu2 by auto
next
 case rtsem_Max
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using repP_def repU_def repL_def by auto
   have lbound:"wmax l1 l2 \<equiv>\<^sub>L max r1 r2"
     by (metis dual_order.trans fst_conv le_cases lrep1 lrep2 lu1 lu2 max_def repL_def wmax.elims)
   have ubound:"wmax u1 u2 \<equiv>\<^sub>U max r1 r2"
     by (metis real_max_mono lu1 lu2 repU_def snd_conv urep1 urep2 wmax_lemma)
   have "([trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmax l1 l2, wmax u1 u2)"
     using lu1 lu2 unfolding wMaxU Let_def
     by (simp)
   then show "[trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P max r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Min
    fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using prod.case_eq_if repP_def  repU_def repL_def by auto
   have lbound:"wmin l1 l2 \<equiv>\<^sub>L min r1 r2"
     by (metis fst_conv lrep1 lrep2 lu1 lu2 min.mono repL_def wmin_lemma)
   have ubound:"wmin u1 u2 \<equiv>\<^sub>U min r1 r2"
     using lu1 lu2 min_le_iff_disj repU_def urep1 urep2 by auto
   have "([Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmin l1 l2, wmin u1 u2)"
     using lu1 lu2 unfolding wMinU Let_def by auto
  then show "[Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P min r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Neg
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using  repP_def repU_def repL_def by auto
  have ubound:"((wneg u1) \<equiv>\<^sub>L (uminus r))"
    by (metis real_minus_le_minus lu repL_def snd_conv urep wneg_lemma)
  have lbound:"((wneg l1) \<equiv>\<^sub>U (uminus r))"
    using real_minus_le_minus lu repU_def lrep wneg_lemma
    by (metis fst_conv)
  show "[Neg \<theta>]<>\<nu> \<equiv>\<^sub>P - r"
    unfolding repP_def Let_def using ubound lbound lu
    by (auto)
next
  case rtsem_Abs
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using prod.case_eq_if repP_def  repU_def repL_def by auto
  have lbound:"wmax l1 (wneg u1) \<equiv>\<^sub>L (abs r)"
    apply(simp only: repL_def)
    apply(rule exI[where x="max lb (- ub)"])
    apply(rule conjI)
    using lrep wmax_lemma lu urep wneg_lemma by auto
  have ubound:"(wmax u1 (wneg l1) \<equiv>\<^sub>U (abs r))"
    apply(simp only: repU_def)
    apply(rule exI[where x="max ub (- lb)"])
    using lrep wmax_lemma lu urep wneg_lemma by auto
  show "[Abs \<theta>]<>\<nu> \<equiv>\<^sub>P abs r"
    using repP_def Let_def ubound lbound lu lu wAbsU by auto
qed

text\<open>Every word represents some real\<close>
lemma word_rep:"\<And>bw::bword. \<exists>r::real. Rep_bword bw \<equiv>\<^sub>E r"
proof -
  fix bw
  obtain w where weq:"w = Rep_bword bw" by auto
  have negInfCase:"w = NEG_INF \<Longrightarrow> ?thesis bw"
   apply(rule exI[where x="-((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have posInfCase:"w = POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x="((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have boundU:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint (Rep_bword bw) < sint POS_INF"
    using Rep_bword [of bw]
    by (auto simp: less_le weq [symmetric] dest: sint_dist)
  have boundL:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint NEG_INF < sint (Rep_bword bw)"
    using Rep_bword [of bw]
    by (auto simp: less_le weq [symmetric] dest: sint_dist)
  have intCase:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x=" (real_of_int (sint (Rep_bword bw)))"])
    apply(rule repINT)
    using boundU boundL by(auto)
  then show "?thesis bw"
    apply(cases "w = POS_INF")
     apply(cases "w = NEG_INF")
      using posInfCase intCase negInfCase by auto
  qed

text\<open>Every term has a value\<close>
lemma eval_tot:"(\<exists>r. ([\<theta>::trm]\<nu>' \<down> r))"
proof (induction "\<theta>")
qed (auto simp add: Min_def word_rep bword_neg_one_def, blast?)

text\<open>Interval formula semantics soundly implies real semantics\<close>
lemma fml_sound:
  fixes \<phi>::"formula" and \<nu>::"wstate"
  shows "(wfsem \<phi> \<nu> b) \<Longrightarrow>  (\<nu> REP \<nu>') \<Longrightarrow> (rfsem \<phi> \<nu>'  b)"
proof (induction arbitrary: \<nu>' rule: wfsem.induct)
case (wGreaterT t1 v t2 w)
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP w"
  obtain r1 and r2 where eval1:"[t1]w \<down> r1" and  eval2:"[t2]w \<down> r2"
    using eval_tot[of t1 w] eval_tot[of t2 w] by (auto)
  note rep1 = trm_sound[of t1 w r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 w r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]w \<downharpoonright> True"
    apply(rule rGreaterT[where ?r1.0 = r1, where ?r2.0 = r2])
    prefer 3
    apply(rule wgreater_lemma[where ?w1.0="fst([t1]<> v)", where ?w2.0="snd([t2]<> v)"])
    using rep1 rep2 wle repP_def repL_def repU_def  eval1 eval2
    by ((simp add: prod.case_eq_if | blast)+)
next
  case (wGreaterF t2 v t1 v')
  assume wl:"wgeq (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]v' \<downharpoonright> False"
    apply(rule rGreaterF [of t1 v' r1 t2 r2])
    apply(rule eval1)
     apply(rule eval2)
    apply(rule wgeq_lemma[where ?w1.0="fst([t2]<> v)", where ?w2.0="snd([t1]<> v)"])
    using rep1 rep2 repP_def wgeq_lemma wl rep
    by auto
next
  case (wGeqT t1 v t2 v')
  assume a1:"wgeq (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> True"
    apply(rule rGeqT)
      apply(rule eval1)
    apply(rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma prod.case_eq_if a1
  by auto
next
  case (wGeqF t2 v t1 v')
  assume a1:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> False"
    apply(rule rGeqF, rule eval1, rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma rGreaterF prod.case_eq_if a1 rGreaterF by auto
next
  case (wEqualsT t2 v t1 v')
  assume eq1:"fst ([t2]<>v) = snd ([t2]<>v)"
  assume eq2:"snd ([t2]<>v) = snd ([t1]<>v)"
  assume eq3:"snd ([t1]<>v) = fst ([t1]<>v)"
  assume rep:"v REP v'"
  assume neq1:"fst ([t2]<>v) \<noteq> NEG_INF"
  assume neq2:"fst ([t2]<>v) \<noteq> POS_INF"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
        eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> True"
    apply(rule rEqualsT, rule eval1, rule eval2)
    using eq1 eq2 eq3 eval1 eval2 rep1 rep2
    unfolding repP_def Let_def repL_def repU_def repe.simps using neq1 neq2 by auto
next
  case (wEqualsF1 t1 v t2 v')
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
  apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2 wgreater_lemma rGreaterF  prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
next
  case (wEqualsF2 t2 v t1 v')
  assume wle:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
    apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2  wgreater_lemma rGreaterF prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
qed (auto)

lemma rep_upd:"\<omega> = (\<nu>(Inr x := snd([\<theta>]<>\<nu>)))(Inl x := fst([\<theta>]<>\<nu>))
\<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> ([\<theta>::trm]\<nu>' \<down> r) \<Longrightarrow> \<omega> REP \<nu>'(x := r)"
  apply(rule REPI)
  apply(rule conjI)
   apply(unfold repL_def)
   using trm_sound prod.case_eq_if repP_def repstate_simps repL_def
   apply(metis (no_types, lifting) Inl_Inr_False fun_upd_apply sum.inject(1))
  using repP_def repstate_simps repU_def
  apply(auto simp add: repU_def)
  by (metis (full_types) surjective_pairing trm_sound)

text\<open>Interval program semantics soundly contains real semantics existentially\<close>
theorem interval_program_sound:
  fixes \<alpha>::"prog"
  shows "([[\<alpha>]] \<nu> \<down> \<omega>)  \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> (\<exists>\<omega>'. (\<omega> REP \<omega>') \<and> ([\<alpha>] \<nu>' \<downharpoonleft> \<omega>'))"
proof (induction arbitrary: \<nu>' rule: wpsem.induct)
  case (wTest \<phi> \<nu> \<omega> \<nu>')
  assume sem:"[[\<phi>]]\<nu> \<down> True"
  and eq:"\<nu> = \<omega>"
  and rep:"\<nu> REP \<nu>'"
  show ?case
    apply(rule exI[where x=\<nu>'])
    using sem rep by (auto simp add: eq fml_sound rep)
next
  case (wAssign \<omega> \<nu> x \<theta> \<nu>')
  assume eq:"\<omega> = \<nu>(Inr x := snd ([\<theta>]<>\<nu>), Inl x := fst ([\<theta>]<>\<nu>))"
  and rep:"\<nu> REP \<nu>'"
  obtain r::real where eval:"([\<theta>::trm]\<nu>' \<down> r)" using eval_tot  by auto
  show ?case
    apply(rule exI[where x="\<nu>'(x := r)"])
    apply(rule conjI)
    apply(rule rep_upd[OF eq rep eval])
    apply auto
    apply(rule exI[where x=r])
    by (auto simp add: eval)
next case (wSeq \<alpha> \<nu> \<mu> \<beta> \<omega> \<nu>') then show ?case by (simp, blast)
next case (wChoice1 a v w b v') then show ?case by auto
next case (wChoice2 a v w b v') then show ?case by auto
qed

end


(* Author: Tobias Nipkow *)

theory Abs_Int0_ITP
imports
  "~~/src/HOL/Library/While_Combinator"
  Collecting_ITP
begin

subsection "Orderings"

class preord =
fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
assumes le_refl[simp]: "x \<sqsubseteq> x"
and le_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
begin

definition mono where "mono f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"

lemma monoD: "mono f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y" by(simp add: mono_def)

lemma mono_comp: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (g o f)"
by(simp add: mono_def)

declare le_trans[trans]

end

text{* Note: no antisymmetry. Allows implementations where some abstract
element is implemented by two different values @{prop "x \<noteq> y"}
such that @{prop"x \<sqsubseteq> y"} and @{prop"y \<sqsubseteq> x"}. Antisymmetry is not
needed because we never compare elements for equality but only for @{text"\<sqsubseteq>"}.
*}

class SL_top = preord +
fixes join :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)
fixes Top :: "'a" ("\<top>")
assumes join_ge1 [simp]: "x \<sqsubseteq> x \<squnion> y"
and join_ge2 [simp]: "y \<sqsubseteq> x \<squnion> y"
and join_least: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
and top[simp]: "x \<sqsubseteq> \<top>"
begin

lemma join_le_iff[simp]: "x \<squnion> y \<sqsubseteq> z \<longleftrightarrow> x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
by (metis join_ge1 join_ge2 join_least le_trans)

lemma le_join_disj: "x \<sqsubseteq> y \<or> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<squnion> z"
by (metis join_ge1 join_ge2 le_trans)

end

instantiation "fun" :: (type, SL_top) SL_top
begin

definition "f \<sqsubseteq> g = (ALL x. f x \<sqsubseteq> g x)"
definition "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"
definition "\<top> = (\<lambda>x. \<top>)"

lemma join_apply[simp]: "(f \<squnion> g) x = f x \<squnion> g x"
by (simp add: join_fun_def)

instance
proof
  case goal2 thus ?case by (metis le_fun_def preord_class.le_trans)
qed (simp_all add: le_fun_def Top_fun_def)

end

instantiation acom :: (preord) preord
begin

fun le_acom :: "('a::preord)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"le_acom (SKIP {S}) (SKIP {S'}) = (S \<sqsubseteq> S')" |
"le_acom (x ::= e {S}) (x' ::= e' {S'}) = (x=x' \<and> e=e' \<and> S \<sqsubseteq> S')" |
"le_acom (c1;;c2) (c1';;c2') = (le_acom c1 c1' \<and> le_acom c2 c2')" |
"le_acom (IF b THEN c1 ELSE c2 {S}) (IF b' THEN c1' ELSE c2' {S'}) =
  (b=b' \<and> le_acom c1 c1' \<and> le_acom c2 c2' \<and> S \<sqsubseteq> S')" |
"le_acom ({Inv} WHILE b DO c {P}) ({Inv'} WHILE b' DO c' {P'}) =
  (b=b' \<and> le_acom c c' \<and> Inv \<sqsubseteq> Inv' \<and> P \<sqsubseteq> P')" |
"le_acom _ _ = False"

lemma [simp]: "x ::= e {S} \<sqsubseteq> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<sqsubseteq> S')"
by (cases c) auto

lemma [simp]: "c1;;c2 \<sqsubseteq> c \<longleftrightarrow> (\<exists>c1' c2'. c = c1';;c2' \<and> c1 \<sqsubseteq> c1' \<and> c2 \<sqsubseteq> c2')"
by (cases c) auto

lemma [simp]: "IF b THEN c1 ELSE c2 {S} \<sqsubseteq> c \<longleftrightarrow>
  (\<exists>c1' c2' S'. c = IF b THEN c1' ELSE c2' {S'} \<and> c1 \<sqsubseteq> c1' \<and> c2 \<sqsubseteq> c2' \<and> S \<sqsubseteq> S')"
by (cases c) auto

lemma [simp]: "{Inv} WHILE b DO c {P} \<sqsubseteq> w \<longleftrightarrow>
  (\<exists>Inv' c' P'. w = {Inv'} WHILE b DO c' {P'} \<and> c \<sqsubseteq> c' \<and> Inv \<sqsubseteq> Inv' \<and> P \<sqsubseteq> P')"
by (cases w) auto

instance
proof
  case goal1 thus ?case by (induct x) auto
next
  case goal2 thus ?case
  apply(induct x y arbitrary: z rule: le_acom.induct)
  apply (auto intro: le_trans)
  done
qed

end

subsubsection "Lifting"

instantiation option :: (preord)preord
begin

fun le_option where
"Some x \<sqsubseteq> Some y = (x \<sqsubseteq> y)" |
"None \<sqsubseteq> y = True" |
"Some _ \<sqsubseteq> None = False"

lemma [simp]: "(x \<sqsubseteq> None) = (x = None)"
by (cases x) simp_all

lemma [simp]: "(Some x \<sqsubseteq> u) = (\<exists>y. u = Some y & x \<sqsubseteq> y)"
by (cases u) auto

instance proof
  case goal1 show ?case by(cases x, simp_all)
next
  case goal2 thus ?case
    by(cases z, simp, cases y, simp, cases x, auto intro: le_trans)
qed

end

instantiation option :: (SL_top)SL_top
begin

fun join_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

lemma join_None2[simp]: "x \<squnion> None = x"
by (cases x) simp_all

definition "\<top> = Some \<top>"

instance proof
  case goal1 thus ?case by(cases x, simp, cases y, simp_all)
next
  case goal2 thus ?case by(cases y, simp, cases x, simp_all)
next
  case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
next
  case goal4 thus ?case by(cases x, simp_all add: Top_option_def)
qed

end

definition bot_acom :: "com \<Rightarrow> ('a::SL_top)option acom" ("\<bottom>\<^sub>c") where
"\<bottom>\<^sub>c = anno None"

lemma strip_bot_acom[simp]: "strip(\<bottom>\<^sub>c c) = c"
by(simp add: bot_acom_def)

lemma bot_acom[rule_format]: "strip c' = c \<longrightarrow> \<bottom>\<^sub>c c \<sqsubseteq> c'"
apply(induct c arbitrary: c')
apply (simp_all add: bot_acom_def)
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
done

subsubsection "Post-fixed point iteration"

definition
  pfp :: "(('a::preord) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<sqsubseteq> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<sqsubseteq> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma pfp_least:
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
and "f p \<sqsubseteq> p" and "x0 \<sqsubseteq> p" and "pfp f x0 = Some x" shows "x \<sqsubseteq> p"
proof-
  { fix x assume "x \<sqsubseteq> p"
    hence  "f x \<sqsubseteq> f p" by(rule mono)
    from this `f p \<sqsubseteq> p` have "f x \<sqsubseteq> p" by(rule le_trans)
  }
  thus "x \<sqsubseteq> p" using assms(2-) while_option_rule[where P = "%x. x \<sqsubseteq> p"]
    unfolding pfp_def by blast
qed

definition
 lpfp\<^sub>c :: "(('a::SL_top)option acom \<Rightarrow> 'a option acom) \<Rightarrow> com \<Rightarrow> 'a option acom option" where
"lpfp\<^sub>c f c = pfp f (\<bottom>\<^sub>c c)"

lemma lpfpc_pfp: "lpfp\<^sub>c f c0 = Some c \<Longrightarrow> f c \<sqsubseteq> c"
by(simp add: pfp_pfp lpfp\<^sub>c_def)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using assms while_option_rule[where P = "%x. g x = g x0" and c = f]
unfolding pfp_def by metis

lemma strip_lpfpc: assumes "\<And>c. strip(f c) = strip c" and "lpfp\<^sub>c f c = Some c'"
shows "strip c' = c"
using assms(1) strip_pfp[OF _ assms(2)[simplified lpfp\<^sub>c_def]]
by(metis strip_bot_acom)

lemma lpfpc_least:
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
and "strip p = c0" and "f p \<sqsubseteq> p" and lp: "lpfp\<^sub>c f c0 = Some c" shows "c \<sqsubseteq> p"
using pfp_least[OF _ _ bot_acom[OF `strip p = c0`] lp[simplified lpfp\<^sub>c_def]]
  mono `f p \<sqsubseteq> p`
by blast

subsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text{* The interface for abstract values: *}

locale Val_abs =
fixes \<gamma> :: "'av::SL_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<sqsubseteq> b \<Longrightarrow> \<gamma> a \<subseteq> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "val \<Rightarrow> 'av"
and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  assumes gamma_num': "n : \<gamma>(num' n)"
  and gamma_plus':
 "n1 : \<gamma> a1 \<Longrightarrow> n2 : \<gamma> a2 \<Longrightarrow> n1+n2 : \<gamma>(plus' a1 a2)"

type_synonym 'av st = "(vname \<Rightarrow> 'av)"

locale Abs_Int_Fun = Val_abs \<gamma> for \<gamma> :: "'av::SL_top \<Rightarrow> val set"
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N n) S = num' n" |
"aval' (V x) S = S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

fun step' :: "'av st option \<Rightarrow> 'av st option acom \<Rightarrow> 'av st option acom"
 where
"step' S (SKIP {P}) = (SKIP {S})" |
"step' S (x ::= e {P}) =
  x ::= e {case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S))}" |
"step' S (c1;; c2) = step' S c1;; step' (post c1) c2" |
"step' S (IF b THEN c1 ELSE c2 {P}) =
   IF b THEN step' S c1 ELSE step' S c2 {post c1 \<squnion> post c2}" |
"step' S ({Inv} WHILE b DO c {P}) =
  {S \<squnion> post c} WHILE b DO (step' Inv c) {Inv}"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI = lpfp\<^sub>c (step' \<top>)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(induct c arbitrary: S) (simp_all add: Let_def)

abbreviation \<gamma>\<^sub>f :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>f == \<gamma>_fun \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>f"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_f_Top[simp]: "\<gamma>\<^sub>f Top = UNIV"
by(simp add: Top_fun_def \<gamma>_fun_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o Top = UNIV"
by (simp add: Top_option_def)

(* FIXME (maybe also le \<rightarrow> sqle?) *)

lemma mono_gamma_f: "f \<sqsubseteq> g \<Longrightarrow> \<gamma>\<^sub>f f \<subseteq> \<gamma>\<^sub>f g"
by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)

lemma mono_gamma_o:
  "sa \<sqsubseteq> sa' \<Longrightarrow> \<gamma>\<^sub>o sa \<subseteq> \<gamma>\<^sub>o sa'"
by(induction sa sa' rule: le_option.induct)(simp_all add: mono_gamma_f)

lemma mono_gamma_c: "ca \<sqsubseteq> ca' \<Longrightarrow> \<gamma>\<^sub>c ca \<le> \<gamma>\<^sub>c ca'"
by (induction ca ca' rule: le_acom.induct) (simp_all add:mono_gamma_o)

text{* Soundness: *}

lemma aval'_sound: "s : \<gamma>\<^sub>f S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)

lemma in_gamma_update:
  "\<lbrakk> s : \<gamma>\<^sub>f S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>f(S(x := a))"
by(simp add: \<gamma>_fun_def)

lemma step_preserves_le:
  "\<lbrakk> S \<subseteq> \<gamma>\<^sub>o S'; c \<le> \<gamma>\<^sub>c c' \<rbrakk> \<Longrightarrow> step S c \<le> \<gamma>\<^sub>c (step' S' c')"
proof(induction c arbitrary: c' S S')
  case SKIP thus ?case by(auto simp:SKIP_le map_acom_SKIP)
next
  case Assign thus ?case
    by (fastforce simp: Assign_le  map_acom_Assign intro: aval'_sound in_gamma_update
      split: option.splits del:subsetD)
next
  case Seq thus ?case apply (auto simp: Seq_le map_acom_Seq)
    by (metis le_post post_map_acom)
next
  case (If b c1 c2 P)
  then obtain c1' c2' P' where
      "c' = IF b THEN c1' ELSE c2' {P'}"
      "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'" "c2 \<le> \<gamma>\<^sub>c c2'"
    by (fastforce simp: If_le map_acom_If)
  moreover have "post c1 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c1 \<le> \<gamma>\<^sub>c c1'` join_ge1 le_post mono_gamma_o order_trans post_map_acom)
  moreover have "post c2 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c2 \<le> \<gamma>\<^sub>c c2'` join_ge2 le_post mono_gamma_o order_trans post_map_acom)
  ultimately show ?case using `S \<subseteq> \<gamma>\<^sub>o S'` by (simp add: If.IH subset_iff)
next
  case (While I b c1 P)
  then obtain c1' I' P' where
    "c' = {I'} WHILE b DO c1' {P'}"
    "I \<subseteq> \<gamma>\<^sub>o I'" "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'"
    by (fastforce simp: map_acom_While While_le)
  moreover have "S \<union> post c1 \<subseteq> \<gamma>\<^sub>o (S' \<squnion> post c1')"
    using `S \<subseteq> \<gamma>\<^sub>o S'` le_post[OF `c1 \<le> \<gamma>\<^sub>c c1'`, simplified]
    by (metis (no_types) join_ge1 join_ge2 le_sup_iff mono_gamma_o order_trans)
  ultimately show ?case by (simp add: While.IH subset_iff)
qed

lemma AI_sound: "AI c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_def)
  assume 1: "lpfp\<^sub>c (step' \<top>) c = Some c'"
  have 2: "step' \<top> c' \<sqsubseteq> c'" by(rule lpfpc_pfp[OF 1])
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c"
    by(simp add: strip_lpfpc[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  with 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

subsubsection "Monotonicity"

lemma mono_post: "c \<sqsubseteq> c' \<Longrightarrow> post c \<sqsubseteq> post c'"
by(induction c c' rule: le_acom.induct) (auto)

locale Abs_Int_Fun_mono = Abs_Int_Fun +
assumes mono_plus': "a1 \<sqsubseteq> b1 \<Longrightarrow> a2 \<sqsubseteq> b2 \<Longrightarrow> plus' a1 a2 \<sqsubseteq> plus' b1 b2"
begin

lemma mono_aval': "S \<sqsubseteq> S' \<Longrightarrow> aval' e S \<sqsubseteq> aval' e S'"
by(induction e)(auto simp: le_fun_def mono_plus')

lemma mono_update: "a \<sqsubseteq> a' \<Longrightarrow> S \<sqsubseteq> S' \<Longrightarrow> S(x := a) \<sqsubseteq> S'(x := a')"
by(simp add: le_fun_def)

lemma mono_step': "S \<sqsubseteq> S' \<Longrightarrow> c \<sqsubseteq> c' \<Longrightarrow> step' S c \<sqsubseteq> step' S' c'"
apply(induction c c' arbitrary: S S' rule: le_acom.induct)
apply (auto simp: Let_def mono_update mono_aval' mono_post le_join_disj
            split: option.split)
done

end

text{* Problem: not executable because of the comparison of abstract states,
i.e. functions, in the post-fixedpoint computation. *}

end


(*
  Title:  Derivations and Maximal Consistent Sets
  Author: Asta Halkjær From
*)

chapter \<open>Derivations\<close>

theory Derivations imports Maximal_Consistent_Sets begin

section \<open>Rearranging Assumptions\<close>

locale Derivations =
  fixes derive :: \<open>'a list \<Rightarrow> 'a \<Rightarrow> bool\<close>
  assumes derive_struct: \<open>\<And>A B p. derive A p \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> derive B p\<close>
begin

theorem derive_split:
  assumes \<open>set A \<subseteq> set B \<union> X\<close> \<open>derive A p\<close>
  shows \<open>\<exists>C. set C \<subseteq> X \<and> derive (B @ C) p\<close>
  using struct_split[where P=\<open>\<lambda>A. derive A p\<close>] derive_struct assms by blast

corollary derive_split1:
  assumes \<open>set A \<subseteq> {q} \<union> X\<close> \<open>derive A p\<close>
  shows \<open>\<exists>C. set C \<subseteq> X \<and> derive (q # C) p\<close>
  using assms derive_split[where B=\<open>[q]\<close>] by simp

end

section \<open>MCSs and Deriving Falsity\<close>

locale Derivations_MCS = Derivations + MCS_Base +
  fixes fls
  assumes consistent_derive_fls: \<open>\<And>S. consistent S = (\<nexists>S'. set S' \<subseteq> S \<and> derive S' fls)\<close>
begin

theorem MCS_derive_fls:
  assumes \<open>consistent S\<close> \<open>maximal S\<close>
  shows \<open>p \<notin> S \<longleftrightarrow> (\<exists>S'. set S' \<subseteq> S \<and> derive (p # S') fls)\<close>
proof
  assume \<open>p \<notin> S\<close>
  then show \<open>\<exists>S'. set S' \<subseteq> S \<and> derive (p # S') fls\<close>
    using assms derive_split1 consistent_derive_fls unfolding maximal_def by metis
next
  assume \<open>\<exists>S'. set S' \<subseteq> S \<and> derive (p # S') fls\<close>
  then show \<open>p \<notin> S\<close>
    using assms consistent_derive_fls by fastforce
qed

end

section \<open>MCSs and Derivability\<close>

locale Derivations_MCS_Cut = Derivations_MCS +
  assumes derive_assm: \<open>\<And>A p. p \<in> set A \<Longrightarrow> derive A p\<close>
    and derive_cut: \<open>\<And>A B p q. derive A p \<Longrightarrow> derive (p # B) q \<Longrightarrow> derive (A @ B) q\<close>
begin

theorem MCS_derive:
  assumes \<open>consistent S\<close> \<open>maximal S\<close>
  shows \<open>p \<in> S \<longleftrightarrow> (\<exists>S'. set S' \<subseteq> S \<and> derive S' p)\<close>
proof
  assume \<open>p \<in> S\<close>
  then show \<open>\<exists>S'. set S' \<subseteq> S \<and> derive S' p\<close>
    using derive_assm by (metis List.set_insert empty_set empty_subsetI insert_subset singletonI)
next
  assume \<open>\<exists>A. set A \<subseteq> S \<and> derive A p\<close>
  then obtain A where A: \<open>set A \<subseteq> S\<close> \<open>derive A p\<close>
    by blast
  have \<open>consistent ({p} \<union> S)\<close>
    unfolding consistent_derive_fls
  proof safe
    fix B
    assume B: \<open>set B \<subseteq> {p} \<union> S\<close> \<open>derive B fls\<close>
    then obtain C where C: \<open>derive (p # C) fls\<close> \<open>set C \<subseteq> S\<close>
      using derive_split1 by blast
    then have \<open>derive (A @ C) fls\<close>
      using A derive_cut by blast
    then show False
      using A(1) B(1) C assms(1) consistent_derive_fls by simp
  qed
  then show \<open>p \<in> S\<close>
    using assms unfolding maximal_def by auto
qed

end

end


theory Poly_Types imports Types begin

subsection "Type Variables"

datatype ty = Ity | Rty | TV nat

text{* Everything else remains the same. *}

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>p/ (_ :/ _))" [50,0,50] 50)
where
"\<Gamma> \<turnstile>p Ic i : Ity" |
"\<Gamma> \<turnstile>p Rc r : Rty" |
"\<Gamma> \<turnstile>p V x : \<Gamma> x" |
"\<Gamma> \<turnstile>p a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile>p a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile>p Plus a1 a2 : \<tau>"

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>p" 50)
where
"\<Gamma> \<turnstile>p Bc v" |
"\<Gamma> \<turnstile>p b \<Longrightarrow> \<Gamma> \<turnstile>p Not b" |
"\<Gamma> \<turnstile>p b1 \<Longrightarrow> \<Gamma> \<turnstile>p b2 \<Longrightarrow> \<Gamma> \<turnstile>p And b1 b2" |
"\<Gamma> \<turnstile>p a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile>p a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile>p Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>p" 50) where
"\<Gamma> \<turnstile>p SKIP" |
"\<Gamma> \<turnstile>p a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile>p x ::= a" |
"\<Gamma> \<turnstile>p c1 \<Longrightarrow> \<Gamma> \<turnstile>p c2 \<Longrightarrow> \<Gamma> \<turnstile>p c1;;c2" |
"\<Gamma> \<turnstile>p b \<Longrightarrow> \<Gamma> \<turnstile>p c1 \<Longrightarrow> \<Gamma> \<turnstile>p c2 \<Longrightarrow> \<Gamma> \<turnstile>p IF b THEN c1 ELSE c2" |
"\<Gamma> \<turnstile>p b \<Longrightarrow> \<Gamma> \<turnstile>p c \<Longrightarrow> \<Gamma> \<turnstile>p WHILE b DO c"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>p" 50)
where "\<Gamma> \<turnstile>p s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

fun tsubst :: "(nat \<Rightarrow> ty) \<Rightarrow> ty \<Rightarrow> ty" where
"tsubst S (TV n) = S n" |
"tsubst S t = t"

subsection{* Typing is Preserved by Substitution *}

lemma subst_atyping: "E \<turnstile>p a : t \<Longrightarrow> tsubst S \<circ> E \<turnstile>p a : tsubst S t"
apply(induction rule: atyping.induct)
apply(auto intro: atyping.intros)
done

lemma subst_btyping: "E \<turnstile>p (b::bexp) \<Longrightarrow> tsubst S \<circ> E \<turnstile>p b"
apply(induction rule: btyping.induct)
apply(auto intro: btyping.intros)
apply(drule subst_atyping[where S=S])
apply(drule subst_atyping[where S=S])
apply(simp add: o_def btyping.intros)
done

lemma subst_ctyping: "E \<turnstile>p (c::com) \<Longrightarrow> tsubst S \<circ> E \<turnstile>p c"
apply(induction rule: ctyping.induct)
apply(auto intro: ctyping.intros)
apply(drule subst_atyping[where S=S])
apply(simp add: o_def ctyping.intros)
apply(drule subst_btyping[where S=S])
apply(simp add: o_def ctyping.intros)
apply(drule subst_btyping[where S=S])
apply(simp add: o_def ctyping.intros)
done

end


theory basics
imports Main
begin

thm impI
thm conjI
(* thm assumption *)

(* Introduction proofs *)

lemma proof1: "A \<longrightarrow> A"
  thm impI
  apply (rule impI)
  apply assumption
  done

lemma proof2: "A \<Longrightarrow> A"
  apply assumption
  done

lemma proof3: "A \<longrightarrow> (B \<longrightarrow> (B \<and> A))"
  thm impI
  apply (rule impI)
  apply (rule impI)
  apply (rule conjI)
  apply assumption
  apply assumption
  done

(* Elimination proofs *)

lemma proof4: "A \<and> B \<longrightarrow> A \<or> B"
  thm impI
  apply (rule impI)
  thm disjI1
  apply (rule disjI1)
  thm conjE
  apply (erule conjE)
  apply (assumption)
  done

lemma proof5: "(A \<longrightarrow> B) \<longrightarrow> ( ( B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C) )"
  thm impI
  apply (rule impI)
  apply (rule impI)
  apply (rule impI)
  thm impE
  apply (erule impE)
   apply assumption
  apply (erule impE)
  apply assumption
  apply assumption
  done


theory Confluent_Quotient imports
  Confluence
begin

section \<open>Subdistributivity for quotients via confluence\<close>

locale confluent_quotient =
  fixes R :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
    and Ea :: "'Fa \<Rightarrow> 'Fa \<Rightarrow> bool"
    and Eb :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
    and Ec :: "'Fc \<Rightarrow> 'Fc \<Rightarrow> bool"
    and Eab :: "'Fab \<Rightarrow> 'Fab \<Rightarrow> bool"
    and Ebc :: "'Fbc \<Rightarrow> 'Fbc \<Rightarrow> bool"
    and \<pi>_Faba :: "'Fab \<Rightarrow> 'Fa"
    and \<pi>_Fabb :: "'Fab \<Rightarrow> 'Fb"
    and \<pi>_Fbcb :: "'Fbc \<Rightarrow> 'Fb"
    and \<pi>_Fbcc :: "'Fbc \<Rightarrow> 'Fc"
    and rel_Fab :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fb \<Rightarrow> bool"
    and rel_Fbc :: "('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fb \<Rightarrow> 'Fc \<Rightarrow> bool"
    and rel_Fac :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fc \<Rightarrow> bool"
    and set_Fab :: "'Fab \<Rightarrow> ('a \<times> 'b) set"
    and set_Fbc :: "'Fbc \<Rightarrow> ('b \<times> 'c) set"
  assumes confluent: "confluentp R"
    and retract1_ab: "\<And>x y. R (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z"
    and retract1_bc: "\<And>x y. R (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z"
    and generated: "Eb \<le> equivclp R"
    and set_ab: "\<And>x y. Eab x y \<Longrightarrow> set_Fab x = set_Fab y"
    and set_bc: "\<And>x y. Ebc x y \<Longrightarrow> set_Fbc x = set_Fbc y"
    and transp_a: "transp Ea"
    and transp_c: "transp Ec"
    and equivp_ab: "equivp Eab"
    and equivp_bc: "equivp Ebc"
    and in_rel_Fab: "\<And>A x y. rel_Fab A x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fab x \<subseteq> {(x, y). A x y}} \<and> \<pi>_Faba z = x \<and> \<pi>_Fabb z = y)"
    and in_rel_Fbc: "\<And>B x y. rel_Fbc B x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fbc x \<subseteq> {(x, y). B x y}} \<and> \<pi>_Fbcb z = x \<and> \<pi>_Fbcc z = y)"
    and rel_compp: "\<And>A B. rel_Fac (A OO B) = rel_Fab A OO rel_Fbc B"
    and \<pi>_Faba_respect: "rel_fun Eab Ea \<pi>_Faba \<pi>_Faba"
    and \<pi>_Fbcc_respect: "rel_fun Ebc Ec \<pi>_Fbcc \<pi>_Fbcc"
begin

lemma retract_ab: "R\<^sup>*\<^sup>* (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z"
  by(induction rule: rtranclp_induct)(blast dest: retract1_ab intro: equivp_transp[OF equivp_ab] equivp_reflp[OF equivp_ab])+

lemma retract_bc: "R\<^sup>*\<^sup>* (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z"
  by(induction rule: rtranclp_induct)(blast dest: retract1_bc intro: equivp_transp[OF equivp_bc] equivp_reflp[OF equivp_bc])+

lemma subdistributivity: "rel_Fab A OO Eb OO rel_Fbc B \<le> Ea OO rel_Fac (A OO B) OO Ec"
proof(rule predicate2I; elim relcomppE)
  fix x y y' z
  assume "rel_Fab A x y" and "Eb y y'" and "rel_Fbc B y' z"
  then obtain xy y'z
    where xy: "set_Fab xy \<subseteq> {(a, b). A a b}" "x = \<pi>_Faba xy" "y = \<pi>_Fabb xy"
      and y'z: "set_Fbc y'z \<subseteq> {(a, b). B a b}" "y' = \<pi>_Fbcb y'z" "z = \<pi>_Fbcc y'z"
    by(auto simp add: in_rel_Fab in_rel_Fbc)
  from \<open>Eb y y'\<close> have "equivclp R y y'" using generated by blast
  then obtain u where u: "R\<^sup>*\<^sup>* y u" "R\<^sup>*\<^sup>* y' u"
    unfolding semiconfluentp_equivclp[OF confluent[THEN confluentp_imp_semiconfluentp]]
    by(auto simp add: rtranclp_conversep)
  with xy y'z obtain xy' y'z'
    where retract1: "Eab xy xy'" "\<pi>_Fabb xy' = u"
      and retract2: "Ebc y'z y'z'" "\<pi>_Fbcb y'z' = u"
    by(auto dest!: retract_ab retract_bc)
  from retract1(1) xy have "Ea x (\<pi>_Faba xy')" by(auto dest: \<pi>_Faba_respect[THEN rel_funD])
  moreover have "rel_Fab A (\<pi>_Faba xy') u" using xy retract1
    by(auto simp add: in_rel_Fab dest: set_ab)
  moreover have "rel_Fbc B u (\<pi>_Fbcc y'z')" using y'z retract2
    by(auto simp add: in_rel_Fbc dest: set_bc)
  moreover have "Ec (\<pi>_Fbcc y'z') z" using retract2 y'z equivp_symp[OF equivp_bc]
    by(auto dest: \<pi>_Fbcc_respect[THEN rel_funD])
  ultimately show "(Ea OO rel_Fac (A OO B) OO Ec) x z" unfolding rel_compp by blast
qed

end

end