section \<open>The ``sturm'' proof method\<close>

(* Author: Manuel Eberl <manuel@pruvisto.org> *)
theory Sturm_Method
imports Sturm_Theorem
begin

subsection \<open>Preliminary lemmas\<close>

text \<open>
  In this subsection, we prove lemmas that reduce root counting and
  related statements to simple, computable expressions using the
  @{term "count_roots"} function family.
\<close>

lemma poly_card_roots_less_leq:
  "card {x. a < x \<and> x \<le> b \<and> poly p x = 0} = count_roots_between p a b"
  by (simp add: count_roots_between_correct)

lemma poly_card_roots_leq_leq:
  "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
       ( count_roots_between p a b +
      (if (a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0) then 1 else 0))"
proof (cases "(a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0)")
  case False
    note False' = this
    thus ?thesis
    proof (cases "p = 0")
      case False
        with False' have "poly p a \<noteq> 0 \<or> a > b" by auto
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
               {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
        by (auto simp: less_eq_real_def)
        thus ?thesis using poly_card_roots_less_leq False'
            by (auto split: if_split_asm)
    next
      case True
        have "{x. a \<le> x \<and> x \<le> b} = {a..b}"
             "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x \<le> b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioc infinite_Icc)
        with True False show ?thesis
            using count_roots_between_correct by simp
    qed
next
  case True
    note True' = this
    have fin: "finite {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0}"
    proof (cases "p = 0")
      case True
        with True' have "a = b" by simp
        hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} = {b}" using True by auto
        thus ?thesis by simp
    next
      case False
        from poly_roots_finite[OF this] show ?thesis by fast
    qed
    with True have "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
        insert a {x. a < x \<and> x \<le> b \<and> poly p x = 0}" by auto
    hence "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
           Suc (card {x. a < x \<and> x \<le> b \<and> poly p x = 0})" using fin by force
    thus ?thesis using True count_roots_between_correct by simp
qed

lemma poly_card_roots_less_less:
  "card {x. a < x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b -
              (if poly p b = 0 \<and> a < b \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p b = 0 \<and> a < b \<and> p \<noteq> 0")
  case False
    note False' = this
    show ?thesis
    proof (cases "p = 0")
      case True
        have [simp]: "{x. a < x \<and> x < b} = {a<..<b}"
                     "{x. a < x \<and> x \<le> b} = {a<..b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a < x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ioo infinite_Ioc)
        with True False' show ?thesis
            by (auto simp: count_roots_between_correct)
    next
      case False
        with False' have "{x. a < x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq False by auto
  qed
next
  case True
    with poly_roots_finite
        have fin: "finite {x. a < x \<and> x < b \<and> poly p x = 0}" by fast
    from True have "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
        insert b {x. a < x \<and> x < b \<and> poly p x = 0}" by auto
    hence "Suc (card {x. a < x \<and> x < b \<and> poly p x = 0}) =
           card {x. a < x \<and> x \<le> b \<and> poly p x = 0}" using fin by force
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using True by simp
qed

lemma poly_card_roots_leq_less:
  "card {x::real. a \<le> x \<and> x < b \<and> poly p x = 0} =
      ( count_roots_between p a b +
      (if p \<noteq> 0 \<and> a < b \<and> poly p a = 0 then 1 else 0) -
      (if p \<noteq> 0 \<and> a < b \<and> poly p b = 0 then 1 else 0))"
proof (cases "p = 0 \<or> a \<ge> b")
  case True
    note True' = this
    show ?thesis
    proof (cases "a \<ge> b")
      case False
        hence "{x. a < x \<and> x \<le> b} = {a<..b}"
              "{x. a \<le> x \<and> x < b} = {a..<b}" by auto
        with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x < b} = 0"
          by (auto simp add: card_eq_0_iff infinite_Ico infinite_Ioc)
        with False True' show ?thesis
            by (simp add: count_roots_between_correct)
    next
      case True
        with True' have "{x. a \<le> x \<and> x < b \<and> poly p x = 0} =
                          {x. a < x \<and> x \<le> b \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis using poly_card_roots_less_leq True by simp
  qed
next
  case False
    let ?A = "{x. a \<le> x \<and> x < b \<and> poly p x = 0}"
    let ?B = "{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
    let ?C = "{x. x = b \<and> poly p x = 0}"
    let ?D = "{x. x = a \<and> poly p a = 0}"
    have CD_if: "?C = (if poly p b = 0 then {b} else {})"
                "?D = (if poly p a = 0 then {a} else {})" by auto
    from False poly_roots_finite
        have [simp]: "finite ?A" "finite ?B" "finite ?C" "finite ?D"
            by (fast, fast, simp_all)

    from False have "?A = (?B \<union> ?D) - ?C" by (auto simp: less_eq_real_def)
    with False have "card ?A = card ?B + (if poly p a = 0 then 1 else 0) -
                       (if poly p b = 0 then 1 else 0)" by (auto simp: CD_if)
    also note count_roots_between_correct[symmetric]
    finally show ?thesis using False by simp
qed

lemma poly_card_roots:
  "card {x::real. poly p x = 0} = count_roots p"
  using count_roots_correct by simp

lemma poly_no_roots:
  "(\<forall>x. poly p x \<noteq> 0) \<longleftrightarrow> ( p \<noteq> 0 \<and> count_roots p = 0)"
    by (auto simp: count_roots_correct dest: poly_roots_finite)

lemma poly_pos:
  "(\<forall>x. poly p x > 0) \<longleftrightarrow> (
        p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots p = 0)"
  by (simp only: Let_def poly_pos poly_no_roots, blast)

lemma poly_card_roots_greater:
  "card {x::real. x > a \<and> poly p x = 0} = count_roots_above p a"
  using count_roots_above_correct by simp

lemma poly_card_roots_leq:
  "card {x::real. x \<le> a \<and> poly p x = 0} = count_roots_below p a"
  using count_roots_below_correct by simp

lemma poly_card_roots_geq:
  "card {x::real. x \<ge> a \<and> poly p x = 0} = (
      count_roots_above p a + (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x \<ge> a \<and> poly p x = 0} = card {x. x > a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a<..<a+1}"
        by (metis infinite_Ioo less_add_one)
      moreover have "{a<..<a+1} \<subseteq> {x. x \<ge> a \<and> poly p x = 0}"
                    "{a<..<a+1} \<subseteq> {x. x > a \<and> poly p x = 0}"
          using \<open>p = 0\<close> by auto
      ultimately have "\<not>finite {x. x \<ge> a \<and> poly p x = 0}"
                      "\<not>finite {x. x > a \<and> poly p x = 0}"
        by (auto dest!: finite_subset[of "{a<..<a+1}"] simp: infinite_Ioo)
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x \<ge> a \<and> poly p x = 0} = {x. x > a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using False
        by (auto intro: poly_card_roots_greater)
next
  case True
    hence "finite {x. x > a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<ge> a \<and> poly p x = 0} =
                       insert a {x. x > a \<and> poly p x = 0}" using True by auto
    ultimately have "card {x. x \<ge> a \<and> poly p x = 0} =
                         Suc (card {x. x > a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    thus ?thesis using True by (auto intro: poly_card_roots_greater)
qed

lemma poly_card_roots_less:
  "card {x::real. x < a \<and> poly p x = 0} =
       (count_roots_below p a - (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
proof (cases "poly p a = 0 \<and> p \<noteq> 0")
  case False
    hence "card {x. x < a \<and> poly p x = 0} = card {x. x \<le> a \<and> poly p x = 0}"
    proof (cases rule: disjE)
      assume "p = 0"
      have "\<not>finite {a - 1<..<a}"
        by (metis infinite_Ioo diff_add_cancel less_add_one)
      moreover have "{a - 1<..<a} \<subseteq> {x. x \<le> a \<and> poly p x = 0}"
                    "{a - 1<..<a} \<subseteq> {x. x < a \<and> poly p x = 0}"
          using \<open>p = 0\<close> by auto
      ultimately have "\<not>finite {x. x \<le> a \<and> poly p x = 0}"
                     "\<not>finite {x. x < a \<and> poly p x = 0}"
          by (auto dest: finite_subset[of "{a - 1<..<a}"] simp: infinite_Ioo)
      thus ?thesis by simp
    next
      assume "poly p a \<noteq> 0"
      hence "{x. x < a \<and> poly p x = 0} = {x. x \<le> a \<and> poly p x = 0}"
          by (auto simp: less_eq_real_def)
      thus ?thesis by simp
    qed auto
    thus ?thesis using False
        by (auto intro: poly_card_roots_leq)
next
  case True
    hence "finite {x. x < a \<and> poly p x = 0}" using poly_roots_finite by force
    moreover have "{x. x \<le> a \<and> poly p x = 0} =
                       insert a {x. x < a \<and> poly p x = 0}" using True by auto
    ultimately have "Suc (card {x. x < a \<and> poly p x = 0}) =
                     (card {x. x \<le> a \<and> poly p x = 0})"
        using card_insert_disjoint by auto
    also note count_roots_below_correct[symmetric]
    finally show ?thesis using True by simp
qed

lemma poly_no_roots_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> count_roots_between p a b = 0)))"
  by (auto simp: count_roots_between_correct card_eq_0_iff not_le
           dest: poly_roots_finite)

lemma poly_pos_between_less_leq:
  "(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p b > 0 \<and> count_roots_between p a b = 0)))"
  by (simp only: poly_pos_between_less_leq Let_def
                 poly_no_roots_less_leq, blast)

lemma poly_no_roots_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b = 0)))"
apply (intro iffI)
apply (force simp add: count_roots_between_correct card_eq_0_iff)
apply (elim conjE disjE, simp, intro allI)
apply (rename_tac x, case_tac "x = a")
apply (auto simp add: count_roots_between_correct card_eq_0_iff
            dest: poly_roots_finite)
done

lemma poly_pos_between_leq_leq:
  "(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a > b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and>
                count_roots_between p a b = 0)))"
by (simp only: poly_pos_between_leq_leq Let_def poly_no_roots_leq_leq, force)

lemma poly_no_roots_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> count_roots_between p a b =
       (if poly p b = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case A: 1
    show ?case
    proof (cases "a \<ge> b")
      case True
      with A show ?thesis by simp
    next
      case False
      with A have [simp]: "p \<noteq> 0" using dense[of a b] by auto
      have B: "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
                {x. a < x \<and> x < b \<and> poly p x = 0} \<union>
                (if poly p b = 0 then {b} else {})" using A False by auto
      have "count_roots_between p a b =
                 card {x. a < x \<and> x < b \<and> poly p x = 0} +
                (if poly p b = 0 then 1 else 0)"
         by (subst count_roots_between_correct, subst B, subst card_Un_disjoint,
             rule finite_subset[OF _ poly_roots_finite], blast, simp_all)
      also from A have "{x. a < x \<and> x < b \<and> poly p x = 0} = {}" by simp
      finally show ?thesis by auto
    qed
next
  case prems: 2
    hence "card {x. a < x \<and> x < b \<and> poly p x = 0} = 0"
        by (subst poly_card_roots_less_less, auto simp: count_roots_between_def)
    thus ?case using prems
        by (cases "p = 0", simp, subst (asm) card_eq_0_iff,
            auto dest: poly_roots_finite)
qed

lemma poly_pos_between_less_less:
  "(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p ((a+b)/2) > 0 \<and>
       count_roots_between p a b = (if poly p b = 0 then 1 else 0))))"
  by (simp only: poly_pos_between_less_less Let_def
                 poly_no_roots_less_less, blast)

lemma poly_no_roots_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
   ((a \<ge> b \<or> p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b =
       (if a < b \<and> poly p b = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case prems: 1
    hence "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by simp
    thus ?case using prems by (subst (asm) poly_no_roots_less_less, auto)
next
  case prems: 2
    hence "(b \<le> a \<or> p \<noteq> 0 \<and> count_roots_between p a b =
               (if poly p b = 0 then 1 else 0))" by auto
    thus ?case using prems unfolding Let_def
        by (subst (asm) poly_no_roots_less_less[symmetric, unfolded Let_def],
        auto split: if_split_asm simp: less_eq_real_def)
qed

lemma poly_pos_between_leq_less:
  "(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and> count_roots_between p a b =
        (if a < b \<and> poly p b = 0 then 1 else 0))))"
 by (simp only: poly_pos_between_leq_less Let_def
                poly_no_roots_leq_less, force)

lemma poly_no_roots_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_above p a = 0))"
proof-
  have "\<forall>x. \<not> a < x \<Longrightarrow> False" by (metis gt_ex)
  thus ?thesis by (auto simp: count_roots_above_correct card_eq_0_iff
                        intro: poly_roots_finite )
qed

lemma poly_pos_greater:
  "(\<forall>x. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow> (
       p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots_above p a = 0)"
  unfolding Let_def
  by (subst poly_pos_greater, subst poly_no_roots_greater, force)

lemma poly_no_roots_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> count_roots_below p a = 0))"
    by (auto simp: Let_def count_roots_below_correct card_eq_0_iff
             intro: poly_roots_finite)

lemma poly_pos_leq:
  "(\<forall>x. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   ( p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a = 0)"
  by (simp only: poly_pos_leq Let_def poly_no_roots_leq, blast)

lemma poly_no_roots_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ( (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0))"
proof (standard, goal_cases)
  case prems: 1
  hence "\<forall>x>a. poly p x \<noteq> 0" by simp
  thus ?case using prems by (subst (asm) poly_no_roots_greater, auto)
next
  case prems: 2
  hence "(p \<noteq> 0 \<and> count_roots_above p a = 0)" by simp
  thus ?case using prems
      by (subst (asm) poly_no_roots_greater[symmetric, unfolded Let_def],
          auto simp: less_eq_real_def)
qed

lemma poly_pos_geq:
  "(\<forall>x. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_inf p = 1 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0)"
  by (simp only: poly_pos_geq Let_def poly_no_roots_geq, blast)

lemma poly_no_roots_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
       ((p \<noteq> 0 \<and> count_roots_below p a = (if poly p a = 0 then 1 else 0)))"
proof (standard, goal_cases)
  case prems: 1
  hence "{x. x \<le> a \<and> poly p x = 0} = (if poly p a = 0 then {a} else {})"
      by (auto simp: less_eq_real_def)
  moreover have "\<forall>x. \<not> x < a \<Longrightarrow> False" by (metis lt_ex)
  ultimately show ?case using prems by (auto simp: count_roots_below_correct)
next
  case prems: 2
  have A: "{x. x \<le> a \<and> poly p x = 0} = {x. x < a \<and> poly p x = 0} \<union>
            (if poly p a = 0 then {a} else {})" by (auto simp: less_eq_real_def)
  have "count_roots_below p a = card {x. x < a \<and> poly p x = 0} +
            (if poly p a = 0 then 1 else 0)" using prems
      by (subst count_roots_below_correct, subst A, subst card_Un_disjoint,
          auto intro: poly_roots_finite)
  with prems have "card {x. x < a \<and> poly p x = 0} = 0" by simp
  thus ?case using prems
      by (subst (asm) card_eq_0_iff, auto intro: poly_roots_finite)
qed

lemma poly_pos_less:
  "(\<forall>x. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
   (p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a =
       (if poly p a = 0 then 1 else 0))"
  by (simp only: poly_pos_less Let_def poly_no_roots_less, blast)

lemmas sturm_card_substs = poly_card_roots poly_card_roots_less_leq
    poly_card_roots_leq_less poly_card_roots_less_less poly_card_roots_leq_leq
    poly_card_roots_less poly_card_roots_leq poly_card_roots_greater
    poly_card_roots_geq

lemmas sturm_prop_substs = poly_no_roots poly_no_roots_less_leq
    poly_no_roots_leq_leq poly_no_roots_less_less poly_no_roots_leq_less
    poly_no_roots_leq poly_no_roots_less poly_no_roots_geq
    poly_no_roots_greater
    poly_pos poly_pos_greater poly_pos_geq poly_pos_less poly_pos_leq
    poly_pos_between_leq_less poly_pos_between_less_leq
    poly_pos_between_leq_leq poly_pos_between_less_less

subsection \<open>Reification\<close>

text \<open>
  This subsection defines a number of equations to automatically convert
  statements about roots of polynomials into a canonical form so that they
  can be proven using the above substitutions.
\<close>

definition "PR_TAG x \<equiv> x"

lemma sturm_id_PR_prio0:
  "{x::real. P x} = {x::real. (PR_TAG P) x}"
  "(\<forall>x::real. f x < g x) = (\<forall>x::real. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. P x) = (\<forall>x::real. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio1:
  "{x::real. x < a \<and> P x} = {x::real. x < a \<and> (PR_TAG P) x}"
  "{x::real. x \<le> a \<and> P x} = {x::real. x \<le> a \<and> (PR_TAG P) x}"
  "{x::real. x \<ge> b \<and> P x} = {x::real. x \<ge> b \<and> (PR_TAG P) x}"
  "{x::real. x > b \<and> P x} = {x::real. x > b \<and> (PR_TAG P) x}"
  "(\<forall>x::real < a. f x < g x) = (\<forall>x::real < a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<le> a. f x < g x) = (\<forall>x::real \<le> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real > a. f x < g x) = (\<forall>x::real > a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real \<ge> a. f x < g x) = (\<forall>x::real \<ge> a. PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real < a. P x) = (\<forall>x::real < a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real > a. P x) = (\<forall>x::real > a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<le> a. P x) = (\<forall>x::real \<le> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real \<ge> a. P x) = (\<forall>x::real \<ge> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma sturm_id_PR_prio2:
  "{x::real. x > a \<and> x \<le> b \<and> P x} =
       {x::real. x > a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x \<le> b \<and> P x} =
       {x::real. x \<ge> a \<and> x \<le> b \<and> PR_TAG P x}"
  "{x::real. x \<ge> a \<and> x < b \<and> P x} =
       {x::real. x \<ge> a \<and> x < b \<and> PR_TAG P x}"
  "{x::real. x > a \<and> x < b \<and> P x} =
       {x::real. x > a \<and> x < b \<and> PR_TAG P x}"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> f x < g x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
  "(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  "(\<forall>x::real. a < x \<and> x < b \<longrightarrow> P x) =
       (\<forall>x::real. a < x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
  by (simp_all add: PR_TAG_def)

lemma PR_TAG_intro_prio0:
  fixes P :: "real \<Rightarrow> bool" and f :: "real \<Rightarrow> real"
  shows
  "PR_TAG P = P' \<Longrightarrow> PR_TAG (\<lambda>x. \<not>(\<not>P x)) = P'"
  "\<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<and> Q x) = (\<lambda>x. poly (gcd p q) x = 0)" and
 " \<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. P x \<or> Q x) = (\<lambda>x. poly (p*q) x = 0)" and

  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x = g x) = (\<lambda>x. poly (p-q) x = 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> g x) = (\<lambda>x. poly (p-q) x \<noteq> 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x < g x) = (\<lambda>x. poly (q-p) x > 0)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> g x) = (\<lambda>x. poly (q-p) x \<ge> 0)"

  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. -f x) = (\<lambda>x. poly (-p) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x + g x) = (\<lambda>x. poly (p+q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x - g x) = (\<lambda>x. poly (p-q) x)"
  "\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * g x) = (\<lambda>x. poly (p*q) x)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n) = (\<lambda>x. poly (p^n) x)"
  "PR_TAG (\<lambda>x. poly p x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. x::real) = (\<lambda>x. poly [:0,1:] x)"
  "PR_TAG (\<lambda>x. a::real) = (\<lambda>x. poly [:a:] x)"
  by (simp_all add: PR_TAG_def poly_eq_0_iff_dvd field_simps)

lemma PR_TAG_intro_prio1:
  fixes f :: "real \<Rightarrow> real"
  shows
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x = 0) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> 0) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 = f x) = (\<lambda>x. poly p x = 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 \<noteq> f x) = (\<lambda>x. poly p x \<noteq> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<ge> 0) = (\<lambda>x. poly p x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x > 0) = (\<lambda>x. poly p x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> 0) = (\<lambda>x. poly (-p) x \<ge> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x < 0) = (\<lambda>x. poly (-p) x > 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 \<le> f x) = (\<lambda>x. poly (-p) x \<le> 0)"
  "PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
       PR_TAG (\<lambda>x. 0 < f x) = (\<lambda>x. poly (-p) x < 0)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. a * f x) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * a) = (\<lambda>x. poly (smult a p) x)"
  "PR_TAG f = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x / a) = (\<lambda>x. poly (smult (inverse a) p) x)"
  "PR_TAG (\<lambda>x. x^n :: real) = (\<lambda>x. poly (monom 1 n) x)"
by (simp_all add: PR_TAG_def field_simps poly_monom)

lemma PR_TAG_intro_prio2:
  "PR_TAG (\<lambda>x. 1 / b) = (\<lambda>x. inverse b)"
  "PR_TAG (\<lambda>x. a / b) = (\<lambda>x. a / b)"
  "PR_TAG (\<lambda>x. a / b * x^n :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. x^n * a / b :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
  "PR_TAG (\<lambda>x. a * x^n :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n * a :: real) = (\<lambda>x. poly (monom a n) x)"
  "PR_TAG (\<lambda>x. x^n / a :: real) = (\<lambda>x. poly (monom (inverse a) n) x)"
(* TODO: can this be done more efficiently? I should think so. *)
  "PR_TAG (\<lambda>x. f x^(Suc (Suc 0)) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n * f x :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. f x * (f x)^n :: real) = (\<lambda>x. poly p x)"
  "PR_TAG (\<lambda>x. (f x)^(m+n) :: real) = (\<lambda>x. poly p x)
       \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^m * (f x)^n :: real) = (\<lambda>x. poly p x)"
by (simp_all add: PR_TAG_def field_simps poly_monom power_add)

lemma sturm_meta_spec: "(\<And>x::real. P x) \<Longrightarrow> P x" by simp
lemma sturm_imp_conv:
  "(a < x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(a < x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(a \<le> x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
  "(x < b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
  "(x \<le> b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
  by auto

subsection \<open>Setup for the ``sturm'' method\<close>

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

method_setup sturm = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Sturm.sturm_tac ctxt true))
\<close>

end


(*  Title:      ZF/UNITY/Comp.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   1998  University of Cambridge

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January  2001

Added: a strong form of the order relation over component and localize

Theory ported from HOL.

*)

section\<open>Composition\<close>

theory Comp imports Union Increasing begin

definition
  component :: "[i,i]=>o"  (infixl "component" 65)  where
  "F component H == (\<exists>G. F \<squnion> G = H)"

definition
  strict_component :: "[i,i]=>o" (infixl "strict'_component" 65)  where
  "F strict_component H == F component H & F\<noteq>H"

definition
  (* A stronger form of the component relation *)
  component_of :: "[i,i]=>o"   (infixl "component'_of" 65)  where
  "F component_of H  == (\<exists>G. F ok G & F \<squnion> G = H)"

definition
  strict_component_of :: "[i,i]=>o" (infixl "strict'_component'_of" 65)  where
  "F strict_component_of H  == F component_of H  & F\<noteq>H"

definition
  (* Preserves a state function f, in particular a variable *)
  preserves :: "(i=>i)=>i"  where
  "preserves(f) == {F:program. \<forall>z. F: stable({s:state. f(s) = z})}"

definition
  fun_pair :: "[i=>i, i =>i] =>(i=>i)"  where
  "fun_pair(f, g) == %x. <f(x), g(x)>"

definition
  localize  :: "[i=>i, i] => i"  where
  "localize(f,F) == mk_program(Init(F), Acts(F),
                       AllowedActs(F) \<inter> (\<Union>G\<in>preserves(f). Acts(G)))"

(*** component and strict_component relations ***)

lemma componentI:
     "H component F | H component G ==> H component (F \<squnion> G)"
apply (unfold component_def, auto)
apply (rule_tac x = "Ga \<squnion> G" in exI)
apply (rule_tac [2] x = "G \<squnion> F" in exI)
apply (auto simp add: Join_ac)
done

lemma component_eq_subset:
     "G \<in> program ==> (F component G) \<longleftrightarrow>
   (Init(G) \<subseteq> Init(F) & Acts(F) \<subseteq> Acts(G) & AllowedActs(G) \<subseteq> AllowedActs(F))"
apply (unfold component_def, auto)
apply (rule exI)
apply (rule program_equalityI, auto)
done

lemma component_SKIP [simp]: "F \<in> program ==> SKIP component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_left)
done

lemma component_refl [simp]: "F \<in> program ==> F component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_right)
done

lemma SKIP_minimal: "F component SKIP ==> programify(F) = SKIP"
apply (rule program_equalityI)
apply (simp_all add: component_eq_subset, blast)
done

lemma component_Join1: "F component (F \<squnion> G)"
by (unfold component_def, blast)

lemma component_Join2: "G component (F \<squnion> G)"
apply (unfold component_def)
apply (simp (no_asm) add: Join_commute)
apply blast
done

lemma Join_absorb1: "F component G ==> F \<squnion> G = G"
by (auto simp add: component_def Join_left_absorb)

lemma Join_absorb2: "G component F ==> F \<squnion> G = F"
by (auto simp add: Join_ac component_def)

lemma JOIN_component_iff:
     "H \<in> program==>(JOIN(I,F) component H) \<longleftrightarrow> (\<forall>i \<in> I. F(i) component H)"
apply (case_tac "I=0", force)
apply (simp (no_asm_simp) add: component_eq_subset)
apply auto
apply blast
apply (rename_tac "y")
apply (drule_tac c = y and A = "AllowedActs (H)" in subsetD)
apply (blast elim!: not_emptyE)+
done

lemma component_JOIN: "i \<in> I ==> F(i) component (\<Squnion>i \<in> I. (F(i)))"
apply (unfold component_def)
apply (blast intro: JOIN_absorb)
done

lemma component_trans: "[| F component G; G component H |] ==> F component H"
apply (unfold component_def)
apply (blast intro: Join_assoc [symmetric])
done

lemma component_antisym:
     "[| F \<in> program; G \<in> program |] ==>(F component G & G  component F) \<longrightarrow> F = G"
apply (simp (no_asm_simp) add: component_eq_subset)
apply clarify
apply (rule program_equalityI, auto)
done

lemma Join_component_iff:
     "H \<in> program ==>
      ((F \<squnion> G) component H) \<longleftrightarrow> (F component H & G component H)"
apply (simp (no_asm_simp) add: component_eq_subset)
apply blast
done

lemma component_constrains:
     "[| F component G; G \<in> A co B; F \<in> program |] ==> F \<in> A co B"
apply (frule constrainsD2)
apply (auto simp add: constrains_def component_eq_subset)
done

(*** preserves ***)

lemma preserves_is_safety_prop [simp]: "safety_prop(preserves(f))"
apply (unfold preserves_def safety_prop_def)
apply (auto dest: ActsD simp add: stable_def constrains_def)
apply (drule_tac c = act in subsetD, auto)
done

lemma preservesI [rule_format]:
     "\<forall>z. F \<in> stable({s \<in> state. f(s) = z})  ==> F \<in> preserves(f)"
apply (auto simp add: preserves_def)
apply (blast dest: stableD2)
done

lemma preserves_imp_eq:
     "[| F \<in> preserves(f);  act \<in> Acts(F);  <s,t> \<in> act |] ==> f(s) = f(t)"
apply (unfold preserves_def stable_def constrains_def)
apply (subgoal_tac "s \<in> state & t \<in> state")
 prefer 2 apply (blast dest!: Acts_type [THEN subsetD], force)
done

lemma Join_preserves [iff]:
"(F \<squnion> G \<in> preserves(v)) \<longleftrightarrow>
      (programify(F) \<in> preserves(v) & programify(G) \<in> preserves(v))"
by (auto simp add: preserves_def INT_iff)

lemma JOIN_preserves [iff]:
     "(JOIN(I,F): preserves(v)) \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)):preserves(v))"
by (auto simp add: JOIN_stable preserves_def INT_iff)

lemma SKIP_preserves [iff]: "SKIP \<in> preserves(v)"
by (auto simp add: preserves_def INT_iff)

lemma fun_pair_apply [simp]: "fun_pair(f,g,x) = <f(x), g(x)>"
apply (unfold fun_pair_def)
apply (simp (no_asm))
done

lemma preserves_fun_pair:
     "preserves(fun_pair(v,w)) = preserves(v) \<inter> preserves(w)"
apply (rule equalityI)
apply (auto simp add: preserves_def stable_def constrains_def, blast+)
done

lemma preserves_fun_pair_iff [iff]:
     "F \<in> preserves(fun_pair(v, w))  \<longleftrightarrow> F \<in> preserves(v) \<inter> preserves(w)"
by (simp add: preserves_fun_pair)

lemma fun_pair_comp_distrib:
     "(fun_pair(f, g) comp h)(x) = fun_pair(f comp h, g comp h, x)"
by (simp add: fun_pair_def metacomp_def)

lemma comp_apply [simp]: "(f comp g)(x) = f(g(x))"
by (simp add: metacomp_def)

lemma preserves_type: "preserves(v)<=program"
by (unfold preserves_def, auto)

lemma preserves_into_program [TC]: "F \<in> preserves(f) ==> F \<in> program"
by (blast intro: preserves_type [THEN subsetD])

lemma subset_preserves_comp: "preserves(f) \<subseteq> preserves(g comp f)"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (drule_tac x = "f (xb)" in spec)
apply (drule_tac x = act in bspec, auto)
done

lemma imp_preserves_comp: "F \<in> preserves(f) ==> F \<in> preserves(g comp f)"
by (blast intro: subset_preserves_comp [THEN subsetD])

lemma preserves_subset_stable: "preserves(f) \<subseteq> stable({s \<in> state. P(f(s))})"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (rename_tac s' s)
apply (subgoal_tac "f (s) = f (s') ")
apply (force+)
done

lemma preserves_imp_stable:
     "F \<in> preserves(f) ==> F \<in> stable({s \<in> state. P(f(s))})"
by (blast intro: preserves_subset_stable [THEN subsetD])

lemma preserves_imp_increasing:
 "[| F \<in> preserves(f); \<forall>x \<in> state. f(x):A |] ==> F \<in> Increasing.increasing(A, r, f)"
apply (unfold Increasing.increasing_def)
apply (auto intro: preserves_into_program)
apply (rule_tac P = "%x. <k, x>:r" in preserves_imp_stable, auto)
done

lemma preserves_id_subset_stable:
 "st_set(A) ==> preserves(%x. x) \<subseteq> stable(A)"
apply (unfold preserves_def stable_def constrains_def, auto)
apply (drule_tac x = xb in spec)
apply (drule_tac x = act in bspec)
apply (auto dest: ActsD)
done

lemma preserves_id_imp_stable:
     "[| F \<in> preserves(%x. x); st_set(A) |] ==> F \<in> stable(A)"
by (blast intro: preserves_id_subset_stable [THEN subsetD])

(** Added by Sidi **)
(** component_of **)

(*  component_of is stronger than component *)
lemma component_of_imp_component:
"F component_of H ==> F component H"
apply (unfold component_def component_of_def, blast)
done

(* component_of satisfies many of component's properties *)
lemma component_of_refl [simp]: "F \<in> program ==> F component_of F"
apply (unfold component_of_def)
apply (rule_tac x = SKIP in exI, auto)
done

lemma component_of_SKIP [simp]: "F \<in> program ==>SKIP component_of F"
apply (unfold component_of_def, auto)
apply (rule_tac x = F in exI, auto)
done

lemma component_of_trans:
     "[| F component_of G; G component_of H |] ==> F component_of H"
apply (unfold component_of_def)
apply (blast intro: Join_assoc [symmetric])
done

(** localize **)
lemma localize_Init_eq [simp]: "Init(localize(v,F)) = Init(F)"
by (unfold localize_def, simp)

lemma localize_Acts_eq [simp]: "Acts(localize(v,F)) = Acts(F)"
by (unfold localize_def, simp)

lemma localize_AllowedActs_eq [simp]:
 "AllowedActs(localize(v,F)) = AllowedActs(F) \<inter> (\<Union>G \<in> preserves(v). Acts(G))"
apply (unfold localize_def)
apply (rule equalityI)
apply (auto dest: Acts_type [THEN subsetD])
done

(** Theorems used in ClientImpl **)

lemma stable_localTo_stable2:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});  G \<in> preserves(f);  G \<in> preserves(g) |]
      ==> F \<squnion> G \<in> stable({s \<in> state. P(f(s), g(s))})"
apply (auto dest: ActsD preserves_into_program simp add: stable_def constrains_def)
apply (case_tac "act \<in> Acts (F) ")
apply auto
apply (drule preserves_imp_eq)
apply (drule_tac [3] preserves_imp_eq, auto)
done

lemma Increasing_preserves_Stable:
     "[| F \<in> stable({s \<in> state. <f(s), g(s)>:r});  G \<in> preserves(f);
         F \<squnion> G \<in> Increasing(A, r, g);
         \<forall>x \<in> state. f(x):A & g(x):A |]
      ==> F \<squnion> G \<in> Stable({s \<in> state. <f(s), g(s)>:r})"
apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
apply (simp_all add: constrains_type [THEN subsetD] preserves_type [THEN subsetD])
apply (blast intro: constrains_weaken)
(*The G case remains*)
apply (auto dest: ActsD simp add: preserves_def stable_def constrains_def ball_conj_distrib all_conj_distrib)
(*We have a G-action, so delete assumptions about F-actions*)
apply (erule_tac V = "\<forall>act \<in> Acts (F). P (act)" for P in thin_rl)
apply (erule_tac V = "\<forall>k\<in>A. \<forall>act \<in> Acts (F) . P (k,act)" for P in thin_rl)
apply (subgoal_tac "f (x) = f (xa) ")
apply (auto dest!: bspec)
done

(** Lemma used in AllocImpl **)

lemma Constrains_UN_left:
     "[| \<forall>x \<in> I. F \<in> A(x) Co B; F \<in> program |] ==> F:(\<Union>x \<in> I. A(x)) Co B"
by (unfold Constrains_def constrains_def, auto)

lemma stable_Join_Stable:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});
     \<forall>k \<in> A. F \<squnion> G \<in> Stable({s \<in> state. P(k, g(s))});
     G \<in> preserves(f); \<forall>s \<in> state. f(s):A|]
  ==> F \<squnion> G \<in> Stable({s \<in> state. P(f(s), g(s))})"
apply (unfold stable_def Stable_def preserves_def)
apply (rule_tac A = "(\<Union>k \<in> A. {s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))})" in Constrains_weaken_L)
prefer 2 apply blast
apply (rule Constrains_UN_left, auto)
apply (rule_tac A = "{s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))} \<inter> {s \<in> state. P (k, g (s))}" and A' = "({s \<in> state. f(s)=k} \<union> {s \<in> state. P (f (s), g (s))}) \<inter> {s \<in> state. P (k, g (s))}" in Constrains_weaken)
 prefer 2 apply blast
 prefer 2 apply blast
apply (rule Constrains_Int)
apply (rule constrains_imp_Constrains)
apply (auto simp add: constrains_type [THEN subsetD])
apply (blast intro: constrains_weaken)
apply (drule_tac x = k in spec)
apply (blast intro: constrains_weaken)
done

end


(*  Title:      HOL/ex/List_to_Set_Comprehension_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section {* Examples for the list comprehension to set comprehension simproc *}

theory List_to_Set_Comprehension_Examples
imports Main
begin

text {*
Examples that show and test the simproc that rewrites list comprehensions
applied to List.set to set comprehensions.
*}

subsection {* Some own examples for set (case ..) simpproc *}

lemma "set [(x, xs). x # xs <- as] = {(x, xs). x # xs \<in> set as}"
by auto

lemma "set [(x, y, ys). x # y # ys <- as] = {(x, y, ys). x # y # ys \<in> set as}"
by auto

lemma "set [(x, y, z, zs). x # y # z # zs <- as] = {(x, y, z, zs). x # y # z # zs \<in> set as}"
by auto

lemma "set [(zs, x, z, y). x # (y, z) # zs <- as] = {(zs, x, z, y). x # (y, z) # zs \<in> set as}"
by auto

lemma "set [(x, y). x # y <- zs, x = x'] = {(x, y). x # y \<in> set zs & x = x'}"
by auto

subsection {* Existing examples from the List theory *}

lemma "set [(x,y,z). b] = {(x', y', z'). x = x' & y = y' & z = z' & b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs] = {(x, y', z'). x \<in> set xs & y' = y & z = z'}"
by auto

lemma "set [e x y. x\<leftarrow>xs, y\<leftarrow>ys] = {z. \<exists> x y. z = e x y & x \<in> set xs & y \<in> set ys}"
by auto

lemma "set [(x,y,z). x<a, x>b] = {(x', y', z'). x' = x & y' = y & z = z' & x < a & x>b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x < a}"
by auto

lemma "set [(x,y). Cons True x \<leftarrow> xs] = {(x, y'). y = y' & Cons True x \<in> set xs}"
by auto

lemma "set [(x,y,z). Cons x [] \<leftarrow> xs] = {(x, y', z'). y = y' & z = z' & Cons x [] \<in> set xs}"
by auto

lemma "set [(x,y,z). x<a, x>b, x=d] = {(x', y', z'). x = x' & y = y' & z = z' & x < a & x > b & x = d}"
by auto

lemma "set [(x,y,z). x<a, x>b, y\<leftarrow>ys] = {(x', y, z'). x = x' & y \<in> set ys & z = z' & x < a & x > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs,y>b] = {(x',y',z'). x' \<in> set xs & y = y' & z = z' & x < a & y > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys] = {(x', y', z'). z = z' & x < a & x' \<in> set xs & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y<a] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b & y < a}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys] = {(x', y', z'). z = z' & x' \<in> set xs & x' > b & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x] = {(x', y', z'). z = z' & x' \<in> set xs & y' \<in> set ys & y' > x'}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs] = {(x', y', z'). x' \<in> set xs & y' \<in> set ys & z' \<in> set zs}"
by auto

end


theory EventSystems
imports "../Basics/Prefix" "../Basics/Projection"
begin

(* structural representation of event systems *)
record 'e ES_rec =
  E_ES ::  "'e set"
  I_ES ::  "'e set"
  O_ES ::  "'e set"
  Tr_ES :: "('e list) set"

(* syntax abbreviations for ES_rec *)
abbreviation ESrecEES :: "'e ES_rec \<Rightarrow> 'e set"
("E\<^bsub>_\<^esub>" [1000] 1000)
where
"E\<^bsub>ES\<^esub> \<equiv> (E_ES ES)"

abbreviation ESrecIES :: "'e ES_rec \<Rightarrow> 'e set"
("I\<^bsub>_\<^esub>" [1000] 1000)
where
"I\<^bsub>ES\<^esub> \<equiv> (I_ES ES)"

abbreviation ESrecOES :: "'e ES_rec \<Rightarrow> 'e set"
("O\<^bsub>_\<^esub>" [1000] 1000)
where
"O\<^bsub>ES\<^esub> \<equiv> (O_ES ES)"

abbreviation ESrecTrES :: "'e ES_rec \<Rightarrow> ('e list) set"
("Tr\<^bsub>_\<^esub>" [1000] 1000)
where
"Tr\<^bsub>ES\<^esub> \<equiv> (Tr_ES ES)"

(* side conditions for event systems *)
definition es_inputs_are_events :: "'e ES_rec \<Rightarrow> bool"
where
"es_inputs_are_events ES \<equiv> I\<^bsub>ES\<^esub> \<subseteq> E\<^bsub>ES\<^esub>"

definition es_outputs_are_events :: "'e ES_rec \<Rightarrow> bool"
where
"es_outputs_are_events ES \<equiv> O\<^bsub>ES\<^esub> \<subseteq> E\<^bsub>ES\<^esub>"

definition es_inputs_outputs_disjoint :: "'e ES_rec \<Rightarrow> bool"
where
"es_inputs_outputs_disjoint ES \<equiv> I\<^bsub>ES\<^esub> \<inter> O\<^bsub>ES\<^esub> = {}"

definition traces_contain_events :: "'e ES_rec \<Rightarrow> bool"
where
"traces_contain_events ES \<equiv> \<forall>l \<in> Tr\<^bsub>ES\<^esub>. \<forall>e \<in> (set l). e \<in> E\<^bsub>ES\<^esub>"

definition traces_prefixclosed :: "'e ES_rec \<Rightarrow> bool"
where
"traces_prefixclosed ES \<equiv> prefixclosed Tr\<^bsub>ES\<^esub>"

definition ES_valid :: "'e ES_rec \<Rightarrow> bool"
where
"ES_valid ES \<equiv>
  es_inputs_are_events ES \<and> es_outputs_are_events ES
  \<and> es_inputs_outputs_disjoint ES \<and> traces_contain_events ES
  \<and> traces_prefixclosed ES"

(* Event systems are instances of ES_rec that satisfy ES_valid. *)

(* Totality of an event system ES with respect to a set E *)
definition total :: "'e ES_rec \<Rightarrow> 'e set \<Rightarrow> bool"
where
"total ES E \<equiv> E \<subseteq> E\<^bsub>ES\<^esub> \<and> (\<forall>\<tau> \<in> Tr\<^bsub>ES\<^esub>. \<forall>e \<in> E. \<tau> @ [e] \<in> Tr\<^bsub>ES\<^esub>)"

lemma totality: "\<lbrakk> total ES E; t \<in> Tr\<^bsub>ES\<^esub>; set t' \<subseteq> E \<rbrakk> \<Longrightarrow> t @ t' \<in> Tr\<^bsub>ES\<^esub>"
  by (induct t' rule: rev_induct, force, simp only: total_def, auto)

(* structural representation of composed event systems (composition operator) *)
definition composeES :: "'e ES_rec \<Rightarrow> 'e ES_rec \<Rightarrow> 'e ES_rec"
where
"composeES ES1 ES2 \<equiv>
  \<lparr>
    E_ES  = E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>,
    I_ES  = (I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub>) \<union> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>),
    O_ES  = (O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub>) \<union> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>),
    Tr_ES = {\<tau> . (\<tau> \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<in> Tr\<^bsub>ES1\<^esub> \<and> (\<tau> \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<in> Tr\<^bsub>ES2\<^esub>
                  \<and> (set \<tau> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>)}
  \<rparr>"

abbreviation composeESAbbrv :: "'e ES_rec \<Rightarrow> 'e ES_rec \<Rightarrow> 'e ES_rec"
("_ \<parallel> _"[1000] 1000)
where
"ES1 \<parallel> ES2 \<equiv> (composeES ES1 ES2)"

definition composable :: "'e ES_rec \<Rightarrow> 'e ES_rec \<Rightarrow> bool"
where
"composable ES1 ES2 \<equiv> (E\<^bsub>ES1\<^esub> \<inter> E\<^bsub>ES2\<^esub>) \<subseteq> ((O\<^bsub>ES1\<^esub> \<inter> I\<^bsub>ES2\<^esub>) \<union> (O\<^bsub>ES2\<^esub> \<inter> I\<^bsub>ES1\<^esub>))"

(* composing two event systems yields an event system *)
lemma composeES_yields_ES:
  "\<lbrakk> ES_valid ES1; ES_valid ES2 \<rbrakk> \<Longrightarrow> ES_valid (ES1 \<parallel> ES2)"
  unfolding ES_valid_def
proof (auto)
  assume ES1_inputs_are_events: "es_inputs_are_events ES1"
  assume ES2_inputs_are_events: "es_inputs_are_events ES2"
  show "es_inputs_are_events (ES1 \<parallel> ES2)" unfolding composeES_def es_inputs_are_events_def
    proof (simp)
      have subgoal11: "I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
      proof (auto)
        fix x
        assume "x \<in> I\<^bsub>ES1\<^esub>"
        with ES1_inputs_are_events  show "x \<in> E\<^bsub>ES1\<^esub>"
          by (auto simp add: es_inputs_are_events_def)
      qed
      have subgoal12: "I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
      proof (rule subsetI, rule UnI2, auto)
        fix x
        assume "x \<in> I\<^bsub>ES2\<^esub>"
        with ES2_inputs_are_events show "x \<in> E\<^bsub>ES2\<^esub>"
          by (auto simp add: es_inputs_are_events_def)
      qed
      from subgoal11 subgoal12
      show "I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub> \<and> I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>" ..
  qed
next
  assume ES1_outputs_are_events: "es_outputs_are_events ES1"
  assume ES2_outputs_are_events: "es_outputs_are_events ES2"
  show "es_outputs_are_events (ES1 \<parallel> ES2)"
    unfolding composeES_def es_outputs_are_events_def
    proof (simp)
      have subgoal21: "O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
      proof (auto)
        fix x
        assume "x \<in> O\<^bsub>ES1\<^esub>"
        with ES1_outputs_are_events  show "x \<in> E\<^bsub>ES1\<^esub>"
          by (auto simp add: es_outputs_are_events_def)
      qed
      have subgoal22: "O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
      proof (rule subsetI, rule UnI2, auto)
        fix x
        assume "x \<in> O\<^bsub>ES2\<^esub>"
        with ES2_outputs_are_events show "x \<in> E\<^bsub>ES2\<^esub>"
          by (auto simp add: es_outputs_are_events_def)
      qed
      from subgoal21 subgoal22
      show "O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub> \<and> O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub> \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>" ..
  qed
next
  assume ES1_inputs_outputs_disjoint: "es_inputs_outputs_disjoint ES1"
  assume ES2_inputs_outputs_disjoint: "es_inputs_outputs_disjoint ES2"
  show "es_inputs_outputs_disjoint (ES1 \<parallel> ES2)"
    unfolding composeES_def es_inputs_outputs_disjoint_def
    proof (simp)
      have subgoal31:
        "{} \<subseteq> (I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<union> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>)) \<inter> (O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<union> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>))"
        by auto
      have subgoal32:
        "(I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<union> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>)) \<inter> (O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<union> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)) \<subseteq> {}"
      proof (rule subsetI, erule IntE)
      fix x
      assume ass1: "x \<in> I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<union> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>)"
      then have ass1': "x \<in> I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<or> x \<in> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>)"
        by auto
      assume ass2: "x \<in> O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<union> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)"
      then have ass2':"x \<in> O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<or> x \<in> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)"
        by auto
      note ass1'
      moreover {
        assume left1: "x \<in> I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub>"
        note ass2'
        moreover {
          assume left2: "x \<in> O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub>"
          with left1 have "x\<in> (I\<^bsub>ES1\<^esub>) \<inter> (O\<^bsub>ES1\<^esub>)"
            by (auto)
          with ES1_inputs_outputs_disjoint have "x\<in>{}"
            by (auto simp add: es_inputs_outputs_disjoint_def)
        }
        moreover {
          assume right2: "x \<in> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)"
          with left1 have "x\<in> (I\<^bsub>ES1\<^esub> - I\<^bsub>ES1\<^esub>)"
            by auto
          hence "x\<in>{}"
            by auto
        }
        ultimately have "x\<in>{}" ..
      }
      moreover {
        assume right1: "x \<in> I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>"
        note ass2'
        moreover {
          assume left2: "x \<in> O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub>"
          with right1 have "x\<in> (I\<^bsub>ES2\<^esub> - I\<^bsub>ES2\<^esub>)"
            by auto
          hence "x\<in>{}"
            by auto
        }
        moreover {
          assume right2: "x \<in> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)"
          with right1 have "x \<in> (I\<^bsub>ES2\<^esub> \<inter> O\<^bsub>ES2\<^esub>)"
            by auto
          with ES2_inputs_outputs_disjoint have "x\<in>{}"
            by (auto simp add: es_inputs_outputs_disjoint_def)
        }
        ultimately have "x\<in>{}" ..
      }
      ultimately show "x\<in>{}" ..
    qed

    from subgoal31 subgoal32
    show "(I\<^bsub>ES1\<^esub> - O\<^bsub>ES2\<^esub> \<union> (I\<^bsub>ES2\<^esub> - O\<^bsub>ES1\<^esub>)) \<inter> (O\<^bsub>ES1\<^esub> - I\<^bsub>ES2\<^esub> \<union> (O\<^bsub>ES2\<^esub> - I\<^bsub>ES1\<^esub>)) = {}"
      by auto
  qed
next
  show "traces_contain_events (ES1 \<parallel> ES2)" unfolding composeES_def traces_contain_events_def
    proof (clarsimp)
      fix l e
      assume "e \<in> set l"
        and "set l \<subseteq> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
      then have e_in_union: "e \<in> E\<^bsub>ES1\<^esub> \<union> E\<^bsub>ES2\<^esub>"
        by auto
      assume "e \<notin> E\<^bsub>ES2\<^esub>"
      with e_in_union show "e \<in> E\<^bsub>ES1\<^esub>"
        by auto
    qed
next
  assume ES1_traces_prefixclosed: "traces_prefixclosed ES1"
  assume ES2_traces_prefixclosed: "traces_prefixclosed ES2"
  show "traces_prefixclosed (ES1 \<parallel> ES2)"
    unfolding composeES_def traces_prefixclosed_def prefixclosed_def prefix_def
  proof (clarsimp)
    fix l2 l3
    have l2l3split: "(l2 @ l3) \<upharpoonleft> E\<^bsub>ES1\<^esub> = (l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>)"
      by (rule projection_concatenation_commute)
    assume "(l2 @ l3) \<upharpoonleft> E\<^bsub>ES1\<^esub> \<in> Tr\<^bsub>ES1\<^esub>"
    with l2l3split have l2l3cattrace: "(l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<in> Tr\<^bsub>ES1\<^esub>"
      by auto
    have theprefix: "(l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>))"
      by (simp add: prefix_def)
    have prefixclosure: "\<forall> es1 \<in> (Tr\<^bsub>ES1\<^esub>). \<forall> es2. es2 \<preceq> es1 \<longrightarrow> es2 \<in> (Tr\<^bsub>ES1\<^esub>)"
      by (clarsimp, insert ES1_traces_prefixclosed, unfold traces_prefixclosed_def prefixclosed_def,
        erule_tac x="es1" in ballE, erule_tac x="es2" in allE, erule impE, auto)
    hence
      " ((l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>)) \<in> Tr\<^bsub>ES1\<^esub> \<Longrightarrow> \<forall> es2. es2 \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>))
         \<longrightarrow> es2 \<in> Tr\<^bsub>ES1\<^esub>" ..
    with l2l3cattrace have "\<forall> es2. es2 \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>)) \<longrightarrow> es2 \<in> Tr\<^bsub>ES1\<^esub>"
      by auto
    hence "(l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES1\<^esub>)) \<longrightarrow> (l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<in> Tr\<^bsub>ES1\<^esub>" ..
    with theprefix have goal51: "(l2 \<upharpoonleft> E\<^bsub>ES1\<^esub>) \<in> Tr\<^bsub>ES1\<^esub>"
      by simp
    have l2l3split: "(l2 @ l3) \<upharpoonleft> E\<^bsub>ES2\<^esub> = (l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>)"
      by (rule projection_concatenation_commute)
    assume "(l2 @ l3) \<upharpoonleft> E\<^bsub>ES2\<^esub> \<in> Tr\<^bsub>ES2\<^esub>"
    with l2l3split have l2l3cattrace: "(l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<in> Tr\<^bsub>ES2\<^esub>"
      by auto
    have theprefix: "(l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>))"
      by (simp add: prefix_def)
    have prefixclosure: "\<forall> es1 \<in> Tr\<^bsub>ES2\<^esub>. \<forall>es2. es2 \<preceq> es1 \<longrightarrow> es2 \<in> Tr\<^bsub>ES2\<^esub>"
      by (clarsimp, insert ES2_traces_prefixclosed,
        unfold traces_prefixclosed_def prefixclosed_def,
        erule_tac x="es1" in ballE, erule_tac x="es2" in allE, erule impE, auto)
    hence " ((l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>)) \<in> Tr\<^bsub>ES2\<^esub>
      \<Longrightarrow> \<forall> es2. es2 \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>)) \<longrightarrow> es2 \<in> Tr\<^bsub>ES2\<^esub>" ..
    with l2l3cattrace have "\<forall> es2. es2 \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>)) \<longrightarrow> es2 \<in> Tr\<^bsub>ES2\<^esub>"
      by auto
    hence "(l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<preceq> ((l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) @ (l3 \<upharpoonleft> E\<^bsub>ES2\<^esub>)) \<longrightarrow> (l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<in> Tr\<^bsub>ES2\<^esub>" ..
    with theprefix have goal52: "(l2 \<upharpoonleft> E\<^bsub>ES2\<^esub>) \<in> Tr\<^bsub>ES2\<^esub>"
      by simp
    from goal51 goal52 show goal5: "l2 \<upharpoonleft> E\<^bsub>ES1\<^esub> \<in> Tr\<^bsub>ES1\<^esub> \<and> l2 \<upharpoonleft> E\<^bsub>ES2\<^esub> \<in> Tr\<^bsub>ES2\<^esub>" ..
  qed
qed

end


theory Soundness
  imports Transition_Rules
begin

chapter \<open>Soundness\<close>

context rules
begin

section \<open>Soundness Definition\<close>

text \<open>All traces that start with a program c\<close>
fun cp :: "('a,'b) com \<Rightarrow> ('a,'b) config list \<Rightarrow> bool"
  where "cp c t = (t \<in> transitions \<and> fst (t ! 0) = c)"

text \<open>All traces that satisfy a precondition in their first state\<close>
fun pre :: "'b pred \<Rightarrow> ('a,'b) config list \<Rightarrow> bool"
  where
    "pre P (s#t) = (snd s \<in> P)" |
    "pre P [] = True"

text \<open>All traces that satisfy a postcondition in their final state given termination\<close>
fun post :: "'b pred \<Rightarrow> ('a,'b) config list \<Rightarrow> bool"
  where
    "post Q [s] = (fst s = Nil \<longrightarrow> snd s \<in> Q)" |
    "post Q (s#t) = post Q t" |
    "post Q [] = True"

text \<open>All traces where program steps satisfy a guarantee\<close>
fun gurn :: "'b rpred \<Rightarrow> ('a,'b) config list \<Rightarrow> bool"
  where
    "gurn G (s#s'#t) = (gurn G (s'#t) \<and> (s -c\<rightarrow> s' \<longrightarrow> (snd s,snd s') \<in> G\<^sup>=))" |
    "gurn G _ = True"

text \<open>All traces where environment steps satisfy a rely\<close>
fun rely :: "'b rpred \<Rightarrow> ('a,'b) config list \<Rightarrow> bool"
  where
    "rely R (s#s'#t) = (rely R (s'#t) \<and> (s -e\<rightarrow> s' \<longrightarrow> (snd s, snd s') \<in> R))" |
    "rely R _ = True"

text \<open>Validity of the rely/guarantee judgements\<close>
definition validity :: "('a,'b) com \<Rightarrow> 'b set \<Rightarrow> ('b) rpred \<Rightarrow> 'b rpred \<Rightarrow> 'b set \<Rightarrow> bool"
  ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
  where "\<Turnstile> c SAT [P, R, G, Q] \<equiv> \<forall>t. cp c t \<and> pre P t \<and> rely R t \<longrightarrow> post Q t \<and> gurn G t"

section \<open>Soundness Proof\<close>

text \<open>All transitions that start with a program with a logic judgement and satisfy
      the precondition and environment rely should conform to the guarantee and
      establish the postcondition if they terminate\<close>
lemma sound_transitions:
  assumes "t \<in> transitions" "fst (t ! 0) = c" "R,G \<turnstile> P {c} Q" "pre P t" "rely R t"
  shows "post Q t \<and> gurn G t"
  using assms
proof (induct arbitrary: c P rule: transitions.induct)
  case (env s s' t)
  then obtain P' where "P \<subseteq> P'" "stable R P'" "R,G \<turnstile> P' {c} Q" by (metis stable_preE)
  thus ?case using env by (auto simp: stable_def)
next
  case (prg s s' t)
  then obtain g where \<alpha>: "c \<mapsto>[g] (fst s')" "(snd s,snd s') \<in> g" by auto
  then obtain M v where p: "P \<subseteq> wp v g M" "guar v g G" "R,G \<turnstile> M {fst s'} Q"
    using gexecute_ruleI[OF prg(5) \<alpha>(1)] by metis
  hence "rely R (s' # t)" "pre M (s' # t)" "(snd s, snd s') \<in> G\<^sup>="
    using prg \<alpha>(2) by (auto simp: wp_def guar_def)
  thus ?case using prg p(3) by auto
qed force+

theorem sound:
  assumes "R,G \<turnstile> P { c } Q"
  shows "\<Turnstile> c SAT [P, R, G, Q]"
  using sound_transitions[OF _ _ assms]
  by (auto simp: validity_def)

end

end


theory GPV_Applicative imports
  Generative_Probabilistic_Value
  SPMF_Applicative
begin

subsection \<open>Applicative instance for @{typ "(_, 'out, 'in) gpv"}\<close>

definition ap_gpv :: "('a \<Rightarrow> 'b, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> ('b, 'out, 'in) gpv"
where "ap_gpv f x = bind_gpv f (\<lambda>f'. bind_gpv x (\<lambda>x'. Done (f' x')))"

adhoc_overloading Applicative.ap ap_gpv

abbreviation (input) pure_gpv :: "'a \<Rightarrow> ('a, 'out, 'in) gpv"
where "pure_gpv \<equiv> Done"

context includes applicative_syntax begin

lemma ap_gpv_id: "pure_gpv (\<lambda>x. x) \<diamondop> x = x"
by(simp add: ap_gpv_def)

lemma ap_gpv_comp: "pure_gpv (\<circ>) \<diamondop> u \<diamondop> v \<diamondop> w = u \<diamondop> (v \<diamondop> w)"
by(simp add: ap_gpv_def bind_gpv_assoc)

lemma ap_gpv_homo: "pure_gpv f \<diamondop> pure_gpv x = pure_gpv (f x)"
by(simp add: ap_gpv_def)

lemma ap_gpv_interchange: "u \<diamondop> pure_gpv x = pure_gpv (\<lambda>f. f x) \<diamondop> u"
by(simp add: ap_gpv_def)

applicative gpv
for
  pure: pure_gpv
  ap: ap_gpv
by(rule ap_gpv_id ap_gpv_comp[unfolded o_def[abs_def]] ap_gpv_homo ap_gpv_interchange)+

lemma map_conv_ap_gpv: "map_gpv f (\<lambda>x. x) gpv = pure_gpv f \<diamondop> gpv"
by(simp add: ap_gpv_def map_gpv_conv_bind)

lemma exec_gpv_ap_pure [simp]:
  "exec_gpv callee (pure_gpv f \<diamondop> x) \<sigma> = pure_spmf (apfst f) \<diamondop> exec_gpv callee x \<sigma>"
by(simp add: exec_gpv_ap apfst_def map_prod_def)

end

end


(*  Title:      HOL/MicroJava/BV/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Lists of a fixed length.
*)

section \<open>Fixed Length Lists\<close>

theory Listn
imports Err "HOL-Library.NList"
begin

definition le :: "'a ord \<Rightarrow> ('a list)ord"
where
  "le r = list_all2 (\<lambda>x y. x \<sqsubseteq>\<^sub>r y)"

abbreviation
  lesublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubseteq>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubseteq>\<^bsub>r\<^esub>] y == x <=_(Listn.le r) y"

abbreviation
  lesssublist :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubset>\<^bsub>_\<^esub>] _)" [50, 0, 51] 50) where
  "x [\<sqsubset>\<^bsub>r\<^esub>] y == x <_(Listn.le r) y"

(*<*)
notation (ASCII)
  lesublist  ("(_ /[<=_] _)" [50, 0, 51] 50) and
  lesssublist  ("(_ /[<_] _)" [50, 0, 51] 50)

abbreviation (input)
  lesublist2 :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubseteq>\<^sub>_] _)" [50, 0, 51] 50) where
  "x [\<sqsubseteq>\<^sub>r] y == x [\<sqsubseteq>\<^bsub>r\<^esub>] y"

abbreviation (input)
  lesssublist2 :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"  ("(_ /[\<sqsubset>\<^sub>_] _)" [50, 0, 51] 50) where
  "x [\<sqsubset>\<^sub>r] y == x [\<sqsubset>\<^bsub>r\<^esub>] y"
(*>*)

abbreviation
  plussublist :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
    ("(_ /[\<squnion>\<^bsub>_\<^esub>] _)" [65, 0, 66] 65) where
  "x [\<squnion>\<^bsub>f\<^esub>] y == x \<squnion>\<^bsub>map2 f\<^esub> y"

(*<*)
notation (ASCII)
  plussublist  ("(_ /[+_] _)" [65, 0, 66] 65)

abbreviation (input)
  plussublist2 :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
    ("(_ /[\<squnion>\<^sub>_] _)" [65, 0, 66] 65) where
  "x [\<squnion>\<^sub>f] y == x [\<squnion>\<^bsub>f\<^esub>] y"
(*>*)

primrec coalesce :: "'a err list \<Rightarrow> 'a list err"
where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"

definition sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl"
where
  "sl n = (\<lambda>(A,r,f). (nlists n A, le r, map2 f))"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err"
where
  "sup f = (\<lambda>xs ys. if size xs = size ys then coalesce(xs [\<squnion>\<^bsub>f\<^esub>] ys) else Err)"

definition upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl"
where
  "upto_esl m = (\<lambda>(A,r,f). (Union{nlists n A |n. n \<le> m}, le r, sup f))"

lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys = Listn.le r xs ys"
(*<*) by (simp add: lesub_def) (*>*)

lemma Nil_le_conv [iff]: "([] [\<sqsubseteq>\<^bsub>r\<^esub>] ys) = (ys = [])"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_notle_Nil [iff]: "\<not> x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] []"
(*<*)
apply (unfold lesub_def Listn.le_def)
apply simp
done
(*>*)

lemma Cons_le_Cons [iff]: "x#xs [\<sqsubseteq>\<^bsub>r\<^esub>] y#ys = (x \<sqsubseteq>\<^sub>r y \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys)"
(*<*)
by (simp add: lesub_def Listn.le_def)
(*>*)

lemma list_update_le_cong:
  "\<lbrakk> i<size xs; xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; x \<sqsubseteq>\<^sub>r y \<rbrakk> \<Longrightarrow> xs[i:=x] [\<sqsubseteq>\<^bsub>r\<^esub>] ys[i:=y]"
(*<*)
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
(*>*)

lemma le_listD: "\<lbrakk> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p \<sqsubseteq>\<^sub>r ys!p"
(*<*)
by (simp add: Listn.le_def lesub_def list_all2_nthD)
(*>*)

lemma le_list_refl: "\<forall>x. x \<sqsubseteq>\<^sub>r x \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs"
(*<*)
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
(*>*)

lemma le_list_trans:
  assumes ord: "order r A"
      and xs:  "xs \<in> nlists n A" and ys: "ys \<in> nlists n A" and zs: "zs \<in> nlists n A"
      and      "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys" and "ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
    shows      "xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
  using assms
proof (unfold le_def lesssub_def lesub_def)
  assume "list_all2 r xs ys" and "list_all2 r ys zs"
  hence xs_ys_zs:  "\<forall>i < length xs. r (xs!i) (ys!i) \<and> r (ys!i) (zs!i)"
        and len_xs_zs: "length xs = length zs" by (auto simp add: list_all2_conv_all_nth)
  from xs ys zs have inA: "\<forall>i<length xs. xs!i \<in> A \<and> ys!i \<in> A \<and> zs!i \<in> A" by (unfold nlists_def) auto

  from ord have "\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z" by (unfold order_def) blast
  hence "\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. r x y \<and> r y z \<longrightarrow> r x z" by (unfold lesssub_def lesub_def)
  with xs_ys_zs inA have "\<forall>i<length xs. r (xs!i) (zs!i)" by blast
  with len_xs_zs show "list_all2 r xs zs" by (simp add:list_all2_conv_all_nth)
qed
(*
  apply (unfold lesssub_def lesub_def)
  apply (unfold Listn.le_def)
  apply (frule list_all2_trans)
    apply simp
  apply blast
  apply (simp add:list_all2_conv_all_nth)
  apply (intro strip)
  apply (erule order_trans)
  apply (unfold list_def)
  apply (auto)
*)

lemma le_list_antisym:
  assumes ord: "order r A"
      and xs:  "xs \<in> nlists n A" and ys: "ys \<in> nlists n A"
      and      "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys" and "ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs"
    shows      "xs = ys"
(*<*)
  using assms
proof (simp add: le_def lesssub_def lesub_def)
  assume "list_all2 r xs ys" and "list_all2 r ys xs"
  hence xs_ys:  "\<forall>i < length xs. r (xs!i) (ys!i) \<and> r (ys!i) (xs!i)"
        and len_xs_ys: "length xs = length ys" by (auto simp add: list_all2_conv_all_nth)
  from xs ys have inA: "\<forall>i<length xs. xs!i \<in> A \<and> ys!i \<in> A" by (unfold nlists_def) auto

  from ord have "\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x = y" by (unfold order_def) blast
  hence "\<forall>x\<in>A. \<forall>y\<in>A. r x y \<and> r y x \<longrightarrow> x = y" by (unfold lesssub_def lesub_def)
  with xs_ys inA have "\<forall>i<length xs. xs!i = ys!i" by blast
  with len_xs_ys show "xs = ys" by (simp add:list_eq_iff_nth_eq)
qed
(*
apply (unfold unfold_lesub_list)
  apply (unfold Listn.le_def)
  apply (auto simp add: list_eq_iff_nth_eq list_def list_all2_conv_all_nth)
  apply (rule order_antisym)
 apply (auto simp add: list_def)
done
*)
(*>*)

lemma nth_in [rule_format, simp]:
  "\<forall>i n. size xs = n \<longrightarrow> set xs \<subseteq> A \<longrightarrow> i < n \<longrightarrow> (xs!i) \<in> A"
(*<*)
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma le_list_refl': "order r A \<Longrightarrow> xs \<in> nlists n A \<Longrightarrow> xs \<sqsubseteq>\<^bsub>Listn.le r\<^esub> xs"
  apply (unfold le_def lesssub_def lesub_def list_all2_conv_all_nth)
  apply auto
  apply (subgoal_tac "xs ! i \<in> A")
   apply (subgoal_tac "(xs ! i) \<sqsubseteq>\<^sub>r (xs ! i)")
    apply (simp only: lesssub_def lesub_def)
   apply (fastforce dest: nlistsE_nth_in)
   apply (fastforce dest: order_refl)
  done

lemma order_listI [simp, intro!]: "order r A \<Longrightarrow> order(Listn.le r) (nlists n A)"
(*<*)
proof-
  assume ord: "order r A"
  let ?r = "Listn.le r"
  let ?A = "nlists n A"
  have "\<forall>x\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x" using ord le_list_refl' by auto
  moreover have "\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> y \<and> y \<sqsubseteq>\<^bsub>?r\<^esub>  x \<longrightarrow> x=y" using ord le_list_antisym by auto
  moreover have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub>y \<and> y \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<sqsubseteq>\<^bsub>?r\<^esub> z" using ord le_list_trans by auto
  ultimately show ?thesis by (auto simp only: order_def)
qed
(*>*)

lemma le_list_refl2': "order r A \<Longrightarrow> xs \<in> (\<Union>{nlists n A |n. n \<le> mxs})\<Longrightarrow> xs \<sqsubseteq>\<^bsub>Listn.le r\<^esub> xs"
  by (auto simp add:le_list_refl')
lemma le_list_trans2:
  assumes "order r A"
      and "xs \<in> (\<Union>{nlists n A |n. n \<le> mxs})" and "ys \<in>(\<Union>{nlists n A |n. n \<le> mxs})" and "zs \<in>(\<Union>{nlists n A |n. n \<le> mxs})"
      and "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys" and "ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
    shows "xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)using assms
proof(auto simp only:nlists_def le_def lesssub_def lesub_def)
  assume xA: "set xs \<subseteq> A" and "length xs \<le> mxs " and " length ys \<le> mxs "
     and yA: "set ys \<subseteq> A" and len_zs: "length zs \<le> mxs"
     and zA: "set zs \<subseteq> A" and xy: "list_all2 r xs ys" and yz: "list_all2 r ys zs"
     and ord: "order r A"
  from xy yz have xs_ys: "length xs = length ys" and ys_zs: "length ys = length zs" by (auto simp add:list_all2_conv_all_nth)
  from ord have "\<forall>x\<in>A.  \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z" by (unfold order_def) blast
  hence trans: "\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. r x y \<and> r y z \<longrightarrow> r x z" by (simp only:lesssub_def lesub_def)

  from xA yA zA have x_inA: "\<forall>i<length xs. xs!i \<in> A"
                 and y_inA: "\<forall>i<length xs. ys!i \<in> A"
                 and z_inA: "\<forall>i<length xs. zs!i \<in> A"  using xs_ys ys_zs  by auto

  from xy yz have "\<forall>i < length xs. r (xs!i) (ys!i)"
              and "\<forall>i < length ys. r (ys!i) (zs!i)" by (auto simp add:list_all2_conv_all_nth)
  hence "\<forall>i < length xs. r (xs!i) (ys!i) \<and> r (ys!i) (zs!i)" using xs_ys ys_zs by auto

  with x_inA y_inA z_inA
  have "\<forall>i<length xs. r (xs!i)  (zs!i)" using trans  xs_ys ys_zs by blast
  thus "list_all2 r xs zs" using xs_ys ys_zs by (simp add:list_all2_conv_all_nth)
qed

lemma le_list_antisym2:
  assumes "order r A"
      and "xs \<in>(\<Union>{nlists n A |n. n \<le> mxs})" and "ys \<in>(\<Union>{nlists n A |n. n \<le> mxs})"
      and "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys" and "ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs"
    shows " xs = ys"
(*<*)
  using assms
proof(auto simp only:nlists_def le_def lesssub_def lesub_def)
  assume xA: "set xs \<subseteq> A" and len_ys: "length ys \<le> mxs" and len_xs: "length xs \<le> mxs"
     and yA: "set ys \<subseteq> A" and xy: "list_all2 r xs ys" and yx: "list_all2 r ys xs"
     and ord: "order r A"
  from xy have len_eq_xs_ys: "length xs = length ys" by (simp add:list_all2_conv_all_nth)

  from ord have antisymm:"\<forall>x\<in>A. \<forall>y\<in>A. r x y \<and> r y x\<longrightarrow> x=y " by (auto simp only:lesssub_def lesub_def order_def)
  from xA yA have x_inA: "\<forall>i<length xs. xs!i \<in> A" and y_inA: "\<forall>i<length ys. ys!i \<in> A" by auto
  from xy yx have "\<forall>i < length xs. r (xs!i) (ys!i)" and "\<forall>i < length ys. r (ys!i) (xs!i)" by (auto simp add:list_all2_conv_all_nth)
  with x_inA y_inA
  have "\<forall>i<length xs. xs!i = ys!i" using antisymm len_eq_xs_ys by auto
  then show "xs = ys" using len_eq_xs_ys by (simp add:list_eq_iff_nth_eq)
qed
(*<*)

lemma order_listI2[intro!] : "order r A \<Longrightarrow> order(Listn.le r) (\<Union>{nlists n A |n. n \<le> mxs})"
(*<*)
proof-
  assume ord: "order r A"
  let ?r = "Listn.le r"
  let ?A = "(\<Union>{nlists n A |n. n \<le> mxs})"
  have "\<forall>x\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x" using ord le_list_refl2' by auto  \<comment>\<open> use order_listI \<close>
  moreover have "\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> y \<and> y \<sqsubseteq>\<^bsub>?r\<^esub>  x \<longrightarrow> x=y" using ord le_list_antisym2 by blast
  moreover have "\<forall>x\<in>?A.  \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub>y \<and> y \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<sqsubseteq>\<^bsub>?r\<^esub> z" using ord le_list_trans2 by blast
  ultimately show ?thesis by (auto simp only: order_def)
qed

lemma lesub_list_impl_same_size [simp]: "xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
(*>*)

lemma lesssub_lengthD: "xs [\<sqsubset>\<^sub>r] ys \<Longrightarrow> size ys = size xs"
(*<*)
apply (unfold lesssub_def)
apply auto
done
(*>*)

lemma le_list_appendI: "a [\<sqsubseteq>\<^bsub>r\<^esub>] b \<Longrightarrow> c [\<sqsubseteq>\<^bsub>r\<^esub>] d \<Longrightarrow> a@c [\<sqsubseteq>\<^bsub>r\<^esub>] b@d"
(*<*)
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
(*>*)

lemma le_listI:
  assumes "length a = length b"
  assumes "\<And>n. n < length a \<Longrightarrow> a!n \<sqsubseteq>\<^sub>r b!n"
  shows "a [\<sqsubseteq>\<^bsub>r\<^esub>] b"
(*<*)
proof -
  from assms have "list_all2 r a b"
    by (simp add: list_all2_all_nthI lesub_def)
  then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
(*>*)

lemma plus_list_Nil [simp]: "[] [\<squnion>\<^bsub>f\<^esub>] xs = []"
(*<*)
apply (unfold plussub_def)
apply simp
done
(*>*)

lemma plus_list_Cons [simp]:
  "(x#xs) [\<squnion>\<^bsub>f\<^esub>] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x \<squnion>\<^sub>f y)#(xs [\<squnion>\<^bsub>f\<^esub>] ys))"
(*<*) by (simp add: plussub_def split: list.split) (*>*)

lemma length_plus_list [rule_format, simp]:
  "\<forall>ys. size(xs [\<squnion>\<^bsub>f\<^esub>] ys) = min(size xs) (size ys)"
(*<*)
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
(*>*)

lemma nth_plus_list [rule_format, simp]:
  "\<forall>xs ys i. size xs = n \<longrightarrow> size ys = n \<longrightarrow> i<n \<longrightarrow> (xs [\<squnion>\<^bsub>f\<^esub>] ys)!i = (xs!i) \<squnion>\<^sub>f (ys!i)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
(*>*)

lemma (in Semilat) plus_list_ub1 [rule_format]:
 "\<lbrakk> set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_ub2:
 "\<lbrakk>set xs \<subseteq> A; set ys \<subseteq> A; size xs = size ys \<rbrakk> \<Longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] xs [\<squnion>\<^bsub>f\<^esub>] ys"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) plus_list_lub [rule_format]:
shows "\<forall>xs ys zs. set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> set zs \<subseteq> A
  \<longrightarrow> size xs = n \<and> size ys = n \<longrightarrow>
  xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<longrightarrow> xs [\<squnion>\<^bsub>f\<^esub>] ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
(*>*)

lemma (in Semilat) list_update_incr [rule_format]:
 "x\<in>A \<Longrightarrow> set xs \<subseteq> A \<longrightarrow>
  (\<forall>i. i<size xs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] xs[i := x \<squnion>\<^sub>f xs!i])"
(*<*)
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
(*>*)

lemma closed_nlistsI:
  "closed S f \<Longrightarrow> closed (nlists n S) (map2 f)"
(*<*)
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply simp
done
(*>*)

lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
(*<*)
proof -
  interpret Semilat A r f by fact
  show ?thesis
  apply (unfold Listn.sl_def)
  apply (simp (no_asm) only: semilat_Def split_conv)
  apply (rule conjI)
   apply simp
  apply (rule conjI)
   apply (simp only: closedI closed_nlistsI)
  apply (simp (no_asm) only: nlists_def)
  apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
  done
qed
(*>*)

lemma Listn_sl: "semilat L \<Longrightarrow> semilat (Listn.sl n L)"
(*<*) apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all) (*>*)

lemma coalesce_in_err_list [rule_format]:
  "\<forall>xes. xes \<in> nlists n (err A) \<longrightarrow> coalesce xes \<in> err(nlists n A)"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
(*>*)

lemma lem: "\<And>x xs. x \<squnion>\<^bsub>(#)\<^esub> xs = x#xs"
(*<*) by (simp add: plussub_def) (*>*)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> nlists n A \<longrightarrow> (\<forall>ys. ys \<in> nlists n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
(*>*)

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> nlists n A \<longrightarrow> (\<forall>ys. ys \<in> nlists n A \<longrightarrow>
  (\<forall>zs. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<longrightarrow> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
(*>*)

lemma lift2_le_ub:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A; x \<squnion>\<^sub>f y = OK z;
      u\<in>A; x \<sqsubseteq>\<^sub>r u; y \<sqsubseteq>\<^sub>r u \<rbrakk> \<Longrightarrow> z \<sqsubseteq>\<^sub>r u"
(*<*)
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
(*>*)

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> nlists n A \<longrightarrow> (\<forall>ys. ys \<in> nlists n A \<longrightarrow>
  (\<forall>zs us. coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = OK zs \<and> xs [\<sqsubseteq>\<^bsub>r\<^esub>] us \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] us
           \<and> us \<in> nlists n A \<longrightarrow> zs [\<sqsubseteq>\<^bsub>r\<^esub>] us))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done
(*>*)

lemma lift2_eq_ErrD:
  "\<lbrakk> x \<squnion>\<^sub>f y = Err; semilat(err A, Err.le r, lift2 f); x\<in>A; y\<in>A \<rbrakk>
  \<Longrightarrow> \<not>(\<exists>u\<in>A. x \<sqsubseteq>\<^sub>r u \<and> y \<sqsubseteq>\<^sub>r u)"
(*<*) by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1]) (*>*)

lemma coalesce_eq_Err_D [rule_format]:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
  \<Longrightarrow> \<forall>xs. xs \<in> nlists n A \<longrightarrow> (\<forall>ys. ys \<in> nlists n A \<longrightarrow>
      coalesce (xs [\<squnion>\<^bsub>f\<^esub>] ys) = Err \<longrightarrow>
      \<not>(\<exists>zs \<in> nlists n A. xs [\<sqsubseteq>\<^bsub>r\<^esub>] zs \<and> ys [\<sqsubseteq>\<^bsub>r\<^esub>] zs))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done
(*>*)

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> err A)"
(*<*)
apply (unfold closed_def)
apply (simp add: err_def')
done
(*>*)

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) \<Longrightarrow>
  \<forall>xs. xs \<in> nlists n A \<longrightarrow> (\<forall>ys. ys \<in> nlists n A \<longrightarrow>
  map2 f xs ys \<in> nlists n (err A))"
(*<*)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_nlists_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
(*>*)

lemma err_semilat_sup:
  "err_semilat (A,r,f) \<Longrightarrow>
  err_semilat (nlists n A, Listn.le r, sup f)"
(*<*)
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
(*>*)

lemma err_semilat_upto_esl:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
(*<*)
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done
(*>*)

end