(* Title: Sub_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open>Sub-designs\<close>
text \<open>Sub designs are a relationship between two designs using the subset and submultiset relations
This theory defines the concept at the incidence system level, before extending to defining on
well defined designs \<close>

theory Sub_Designs imports Design_Operations
begin

subsection \<open>Sub-system and Sub-design Locales \<close>
locale sub_set_system = incidence_system \<V> \
  for "\" and "\" and "\<V>" and "\" +
  assumes points_subset: "\ \<subseteq> \<V>"
  assumes blocks_subset: "\ \<subseteq># \"
begin

lemma sub_points: "x \<in> \ \<Longrightarrow> x \<in> \<V>"
  using points_subset by auto

lemma sub_blocks: "bl \<in># \ \<Longrightarrow> bl \<in># \"
  using blocks_subset by auto

lemma sub_blocks_count: "count \ b \<le> count \ b"
  by (simp add: mset_subset_eq_count blocks_subset)

end

locale sub_incidence_system = sub_set_system + ins: incidence_system \ \

locale sub_design = sub_incidence_system + des: design \<V> \
begin

lemma sub_non_empty_blocks: "A \<in># \ \<Longrightarrow> A \<noteq> {}"
  using des.blocks_nempty sub_blocks by simp

sublocale sub_des: design \ \
  using des.finite_sets finite_subset points_subset sub_non_empty_blocks
  by (unfold_locales) (auto)

end

locale proper_sub_set_system = incidence_system \<V> \
  for "\" and "\" and "\<V>" and "\" +
  assumes points_psubset: "\ \<subset> \<V>"
  assumes blocks_subset: "\ \<subseteq># \"
begin

lemma point_sets_ne: "\ \<noteq> \<V>"
  using points_psubset by auto

end

sublocale proper_sub_set_system \<subseteq> sub_set_system
  using points_psubset blocks_subset by (unfold_locales) simp_all

context sub_set_system
begin

lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_set_system \ \ \<V> \"
  using blocks_subset incidence_system_axioms
  by (simp add: points_subset proper_sub_set_system.intro proper_sub_set_system_axioms_def psubsetI)

end

locale proper_sub_incidence_system = proper_sub_set_system + ins: incidence_system \ \

sublocale proper_sub_incidence_system \<subseteq> sub_incidence_system
  by (unfold_locales)

context sub_incidence_system
begin
lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_incidence_system \ \ \<V> \"
  by (simp add: ins.incidence_system_axioms proper_sub_incidence_system_def sub_is_proper)

end

locale proper_sub_design = proper_sub_incidence_system + des: design \<V> \

sublocale proper_sub_design \<subseteq> sub_design
  by (unfold_locales)

context sub_design
begin
lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_design \ \ \<V> \"
  by (simp add: des.wf_design proper_sub_design.intro sub_is_proper)

end

lemma ss_proper_implies_sub [intro]: "proper_sub_set_system \ \ \<V> \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  using proper_sub_set_system.axioms(1) proper_sub_set_system.blocks_subset psubsetE
  by (metis proper_sub_set_system.points_psubset sub_set_system.intro sub_set_system_axioms_def)

lemma sub_ssI [intro!]: "incidence_system \<V> \ \<Longrightarrow> \ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  using incidence_system_def subset_iff
  by (unfold_locales) (simp_all add: incidence_system.wellformed)

lemma sub_ss_equality:
  assumes "sub_set_system \ \ \<V> \"
    and "sub_set_system \<V> \ \ \"
  shows "\ = \<V>" and "\ = \"
  using assms(1) assms(2) sub_set_system.points_subset apply blast
  by (meson assms(1) assms(2) sub_set_system.blocks_subset subset_mset.eq_iff)

subsection \<open>Reasoning on Sub-designs\<close>

subsubsection \<open>Reasoning on Incidence Sys property relationships \<close>

context sub_incidence_system
begin

lemma sub_sys_block_sizes: "ins.sys_block_sizes \<subseteq> sys_block_sizes"
  by (auto simp add: sys_block_sizes_def ins.sys_block_sizes_def blocks_subset sub_blocks)

lemma sub_point_rep_number_le: "x \<in> \ \<Longrightarrow> \ rep x \<le> \ rep x"
  by (simp add: point_replication_number_def blocks_subset multiset_filter_mono size_mset_mono)

lemma sub_point_index_le: "ps \<subseteq> \ \<Longrightarrow> \ index ps \<le> \ index ps"
  by (simp add: points_index_def blocks_subset multiset_filter_mono size_mset_mono)

lemma sub_sys_intersection_numbers: "ins.intersection_numbers \<subseteq> intersection_numbers"
  apply (auto simp add: intersection_numbers_def ins.intersection_numbers_def)
  by (metis blocks_subset insert_DiffM insert_subset_eq_iff)

end

subsubsection \<open>Reasoning on Incidence Sys/Design operations \<close>
context incidence_system
begin

lemma sub_set_sysI[intro]: "\ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  by (simp add: sub_ssI incidence_system_axioms)

lemma sub_inc_sysI[intro]: "incidence_system \ \ \<Longrightarrow> \ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow>
    sub_incidence_system \ \ \<V> \"
  by (simp add: sub_incidence_system.intro sub_set_sysI)

lemma multiple_orig_sub_system:
  assumes "n > 0"
  shows "sub_incidence_system \<V> \ \<V> (multiple_blocks n)"
  using multiple_block_in_original wellformed multiple_blocks_sub assms
  by (unfold_locales) simp_all

lemma add_point_sub_sys: "sub_incidence_system \<V> \ (add_point p) \"
  using add_point_wf add_point_def
  by (simp add: sub_ssI subset_insertI incidence_system_axioms sub_incidence_system.intro)

lemma strong_del_point_sub_sys: "sub_incidence_system (del_point p) (str_del_point_blocks p) \<V> \ "
  using strong_del_point_incidence_wf wf_invalid_point del_point_def str_del_point_blocks_def
  by (unfold_locales) (auto)

lemma add_block_sub_sys: "sub_incidence_system \<V> \ (\<V> \<union> b) (add_block b)"
  using add_block_wf wf_invalid_point add_block_def by (unfold_locales) (auto)

lemma delete_block_sub_sys: "sub_incidence_system \<V> (del_block b)  \<V> \ "
  using delete_block_wf delete_block_subset incidence_system_def by (unfold_locales, auto)

end

lemma (in two_set_systems) combine_sub_sys: "sub_incidence_system \<V> \ \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

lemma (in two_set_systems) combine_sub_sys_alt: "sub_incidence_system \<V>' \' \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

context design
begin

lemma sub_designI [intro]: "design \ \ \<Longrightarrow> sub_incidence_system \ \ \<V> \ \<Longrightarrow> sub_design \ \ \<V> \"
  by (simp add: sub_design.intro wf_design)

lemma sub_designII [intro]: "design \ \ \<Longrightarrow> sub_incidence_system \<V> \ \ \ \<Longrightarrow> sub_design \<V> \ \ \"
  by (simp add: sub_design_def)

lemma multiple_orig_sub_des:
  assumes "n > 0"
  shows "sub_design \<V> \ \<V> (multiple_blocks n)"
  using multiple_is_design assms multiple_orig_sub_system by (simp add: sub_design.intro)

lemma add_point_sub_des: "sub_design \<V> \ (add_point p) \"
  using add_point_design add_point_sub_sys sub_design.intro by fastforce

lemma strong_del_point_sub_des: "sub_design (del_point p) (str_del_point_blocks p) \<V> \ "
  using strong_del_point_sub_sys sub_design.intro wf_design by blast

lemma add_block_sub_des: "finite b \<Longrightarrow> b \<noteq> {} \<Longrightarrow> sub_design \<V> \ (\<V> \<union> b) (add_block b)"
  using add_block_sub_sys add_block_design sub_designII by fastforce

lemma delete_block_sub_des: "sub_design \<V> (del_block b) \<V> \ "
  using delete_block_design delete_block_sub_sys sub_designI by auto

end

lemma (in two_designs) combine_sub_des: "sub_design \<V> \ \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

lemma (in two_designs) combine_sub_des_alt: "sub_design \<V>' \' \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

end


(*<*) theory induct_rules imports Main begin (*>*)

theorem merge_induct:  "(\<And>ys. P [] ys) \<Longrightarrow> (\<And>v va. P (v # va) []) \<Longrightarrow>
    (\<And>x xs y ys. (x \<le> y \<Longrightarrow> P xs (y # ys)) \<Longrightarrow> (\<not> x \<le> y \<Longrightarrow> P (x # xs) ys) \<Longrightarrow> P (x # xs) (y # ys)) \<Longrightarrow>
    P a0 a1"
proof -
  assume 1: "\<And>ys. P [] ys "
  assume 2:" (\<And>v va. P (v # va) [])"
  assume 3:"(\<And>x xs y ys. (x \<le> y \<Longrightarrow> P xs (y # ys)) \<Longrightarrow> (\<not> x \<le> y \<Longrightarrow> P (x # xs) ys) \<Longrightarrow> P (x # xs) (y # ys))"
  show "P a0 a1"
  proof (induction a0)
    case Nil
    then show ?case using 1 by auto
  next
    show "\<And>a a0. P a0 a1 \<Longrightarrow> P (a # a0) a1"
    proof (induct a1)
      case Nil
      then show ?case using 2 by auto
    next
      from 3 have new3: "(\<And>aa a0 a a1. (aa \<le> a \<Longrightarrow> P a0 (a # a1)) \<Longrightarrow> (\<not> aa \<le> a \<Longrightarrow> P (aa # a0) a1) \<Longrightarrow> P (aa # a0) (a # a1))" by simp
      show "\<And>a a1 aa a0. (\<And>a a0. P a0 a1 \<Longrightarrow> P (a # a0) a1) \<Longrightarrow> P a0 (a # a1) \<Longrightarrow> P (aa # a0) (a # a1)"
      proof -
        fix a a1 aa a0
        assume 4:"(\<And>m n. P n a1 \<Longrightarrow> P (m # n) a1)"
        assume 5:" P a0 (a # a1)"
        show "P (aa # a0) (a # a1)"
        proof (cases)
          assume 6:"aa \<le>a"
          then show ?thesis
          proof -
            from new3 6 have "P a0 (a # a1) \<Longrightarrow>P (aa # a0) (a # a1) " by auto
            from this 5 show "P (aa # a0) (a # a1)" by auto
          qed
        next
          assume 7:"\<not> (aa \<le>a )"
          then show "P (aa # a0) (a # a1)"
          proof -
            from new3 7 have 8:" P (aa # a0) a1 \<Longrightarrow>P (aa # a0) (a # a1) "  by auto
            from 4 have "P a0 a1 \<Longrightarrow>P (aa#a0 ) a1" by auto
            from this 8 have 9: "P a0 a1 \<Longrightarrow> P (aa#a0) (a#a1)" by auto
            from 4 have "P [] a1 \<Longrightarrow> P (aa#[]) a1" by auto
            from 4 have "\<And> ll. P ll a1"
            proof -
              fix ll
              show "P ll a1"
              proof (induct ll)
                case Nil
                then show ?case using 1 by auto
              next
                case (Cons a ll)
                then show ?case using 4 by auto
              qed
            qed
            then have "P a0 a1" by auto
            from this 9 show "P (aa#a0) (a#a1)" by auto
          qed
        qed
      qed
    qed
  qed
qed

(* theorem list_induct :" P [] \<Longrightarrow>  ( \<And> x a . P (x)  \<Longrightarrow>  P (a#x) )  \<Longrightarrow> P ll" sorry *)

theorem list_induct2: "P[] \<Longrightarrow>( \<And> x . P (x#[]) ) \<Longrightarrow>(\<And> x y a. (P (x#y)  \<Longrightarrow>P (a#x#y)) )  \<Longrightarrow> P ll"
proof -
  assume 1:" P[]"
  assume 2:"( \<And> x . P (x#[]) )"
  assume 3:"(\<And> x y a. (P (x#y)  \<Longrightarrow>P (a#x#y)) ) "
  show "P ll"
  proof (induct ll)
    case Nil
    then show ?case using 1 by auto
  next
    case (Cons a ll)
    then show ?case
    proof (induct ll)
      case Nil
      then show ?case using 2 by auto
    next
      case (Cons a ll)
      then show ?case using 3 by auto
    qed
  qed
qed

lemma take_drop: " P  ( (take x ll) @ ( drop x ll) )  \<Longrightarrow>P ll " by auto

(*
lemma num_induct: "P (0::nat) \<Longrightarrow> P 1\<Longrightarrow> ( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) ) \<Longrightarrow>P num"
  sorry
*)

(*  generated by sledgehammer
by (metis diff_less div_2_gt_zero div_by_1 div_eq_0_iff div_eq_dividend_iff div_less_dividend div_self infinite_descent less_one linorder_neqE_nat nat_less_induct nat_neq_iff not_gr0 one_div_two_eq_zero one_neq_zero zero_not_eq_two)
*)

(* generated by sledgehammer,simplified
 by (metis diff_less div_2_gt_zero div_eq_0_iff div_less_dividend infinite_descent less_one  nat_less_induct nat_neq_iff not_gr0 one_div_two_eq_zero zero_not_eq_two)
*)

(*  generated by sledgehammer
proof -
  assume a1: "P 0"
  assume a2: "P 1"
  assume "\<And>x. \<lbrakk>P (x div 2); P (x - x div 2)\<rbrakk> \<Longrightarrow> P x"
  then have f3: "\<forall>n na. \<not> P (na - na div 2) \<or> P na \<or> \<not> na div 2 < sK0 P \<or> P n"
    by (metis nat_less_induct) (* > 1.0 s, timed out *)
  have f4: "spl2_4 = (\<forall>X7. \<not> P (X7 - X7 div 2) \<or> \<not> X7 div 2 < sK0 P \<or> P X7)"
    by auto (* failed *)
  have f5: "spl2_0 = (\<forall>E_x. P E_x)"
    by auto (* failed *)
  have f6: "spl2_0 \<or> spl2_4"
    using f4 f3 by blast
  have f7: "\<forall>n na. \<not> 1 < n \<or> P na \<or> na div n < na"
    using a1 by (metis (no_types) div_less_dividend not_gr0)
  have "spl2_93 = (\<not> (1::nat) < 2)"
    by auto (* failed *)
  then have "\<not> spl2_93"
    by simp
  then have "spl2_4 \<and> spl2_92 \<or> spl2_0"
    using f6 by metis (* failed *)
  moreover
  { assume "spl2_4 \<and> spl2_92"
    moreover
    { assume "\<not> P (sK0 P) \<and> spl2_4 \<and> spl2_92"
moreover
{ assume "sK0 P div 2 < sK0 P \<and> \<not> P (sK0 P) \<and> spl2_4"
        moreover
        { assume "0 < sK0 P div 2 \<and> sK0 P div 2 < sK0 P \<and> \<not> P (sK0 P) \<and> spl2_4"
          moreover
          { assume "\<exists>n. 0 < sK0 P \<and> \<not> P (sK0 P - n) \<and> 0 < n"
            moreover
            { assume "\<exists>n. \<not> P (sK0 P - n) \<and> 0 < n \<and> (0::nat) < sK1 P"
              moreover
              { assume "\<exists>n. \<not> P (sK1 P - n) \<and> 0 < n \<and> 0 < sK1 P"
                then have "\<exists>n<sK1 P. \<not> P n"
                  by (meson diff_less)
                then have ?thesis
                  by (metis infinite_descent) (* > 1.0 s, timed out *) }
              ultimately have "sK0 P = sK1 P \<longrightarrow> P num"
                by (metis (no_types)) }
            ultimately have "sK0 P = sK1 P \<longrightarrow> P num"
              by (metis (no_types)) }
          ultimately have "sK0 P = sK1 P \<longrightarrow> P num \<or> P (sK1 P)"
            using f4 a1 by (metis (no_types) not_gr0) }
        moreover
        { assume "sK0 P \<noteq> sK1 P"
          moreover
          { assume "sK0 P < sK1 P"
            then have "P (sK0 P) \<or> P num"
              by (metis infinite_descent) (* > 1.0 s, timed out *) }
          moreover
          { assume "\<not> sK0 P < sK1 P \<and> sK0 P \<noteq> sK1 P"
            then have "sK1 P < sK0 P"
              by (meson nat_neq_iff)
            then have "P (sK1 P) \<or> P num"
              by (metis nat_less_induct) (* > 1.0 s, timed out *) }
          ultimately have "P (sK0 P) \<or> P (sK1 P) \<or> P num"
            by satx }
        moreover
        { assume "P (sK1 P)"
          then have ?thesis
            by (metis infinite_descent) (* > 1.0 s, timed out *) }
        ultimately have "P (sK0 P) \<or> P num"
          using a2 a1 by (metis (no_types) div_2_gt_zero less_one linorder_neqE_nat) }
      ultimately have "P (sK0 P) \<or> P num"
        using f7 by force }
    moreover
    { assume "P (sK0 P)"
      then have ?thesis
        by (metis nat_less_induct) (* > 1.0 s, timed out *) }
    ultimately have ?thesis
      by blast }
  ultimately show ?thesis
    using f5 by blast
qed
*)

lemma num_induct2_pre: "   ((\<And> n. (n::nat) < m \<Longrightarrow> P n) \<Longrightarrow>P m )\<Longrightarrow> (\<And> n::nat . n < m \<Longrightarrow> P n)  \<Longrightarrow> (\<And> n::nat . n < (Suc m) \<Longrightarrow> P n)  "
proof -
  fix m
  assume 1:"(\<And> n::nat . n < m \<Longrightarrow> P n)"
  assume 2:" (\<And> n. (n::nat) < m \<Longrightarrow> P n) \<Longrightarrow>P m"
  show 3:"(\<And> n::nat . n < (Suc m) \<Longrightarrow> P n)"
  proof -
    from 1 2 have " P m" by auto
    from this 1 less_le have "(\<And> n::nat . n \<le> m \<Longrightarrow> P n)" by metis
    from this less_le show "(\<And> n::nat . n < (Suc m) \<Longrightarrow> P n)" by auto
  qed
qed

lemma num_induct2_pre2: " (\<And> m .(\<And> n::nat . n < m \<Longrightarrow> P n) ) \<Longrightarrow> P all "
proof -
  assume 1:"(\<And> m .(\<And> n::nat . n < m \<Longrightarrow> P n) )"
  show "P all"
  proof (induct all)
    case 0
    from 1 show ?case by auto
  next
    case (Suc all)
    from 1 show ?case by auto
  qed
qed

lemma num_induct2: " (\<And> m. (\<And> n. (n::nat) < m \<Longrightarrow> P n) \<Longrightarrow>P m )  \<Longrightarrow> P all"
proof -
  assume 1:"(\<And> m. (\<And> n. (n::nat) < m \<Longrightarrow> P n) \<Longrightarrow>P m )"
  then have 2:"P 0" by auto
  from 1 num_induct2_pre have 3:"\<And> m. (\<And> n::nat . n < m \<Longrightarrow> P n)  \<Longrightarrow> (\<And> n::nat . n < (Suc m) \<Longrightarrow> P n)" by metis
  have 4: "\<And> m. (\<And> n::nat . n < m \<Longrightarrow> P n) "
  proof -
    fix m
    show "(\<And> n::nat . n < m \<Longrightarrow> P n) "
    proof (induct m)
      case 0
      then show ?case by auto
    next
      case (Suc m)
      then show ?case
        using "1" 3 by metis
    qed
  qed
  from 4 num_induct2_pre2 show "P all" by auto
qed

lemma "(\<forall> n. ( A (n) \<longrightarrow>B ) ) = ((\<forall> n . A(n)) \<longrightarrow>B) "  (*this is not true*)
  oops

lemma "( \<forall> n.  B\<longrightarrow> A n ) = (B \<longrightarrow>(\<forall> n . A n) ) "  by auto

lemma num_induct3_pre: " P (0::nat) \<Longrightarrow> ( (\<And> n. (n::nat) < 0 \<Longrightarrow> P n) \<Longrightarrow>P 0 ) " by auto

lemma num_induct3_pre2: " P (0::nat) \<Longrightarrow>P(1) \<Longrightarrow> ( (\<And> n. (n::nat) < 1 \<Longrightarrow> P n) \<Longrightarrow>P 1 ) " by auto

lemma num_induct_pre: "(m::nat) \<ge>2 \<Longrightarrow>( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) ) \<Longrightarrow>  (\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m "
proof -
  assume 1:"m \<ge>2"
  assume 2:"( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) )"
  assume 3:" (\<And> n. n  < m \<Longrightarrow> P n)"
  show "P m"
  proof -
    have 4:"(m div 2) < m" using 1 by auto
    have 5:"m - (m div 2) < m " using 1 by auto
    have 6:"(P (m div 2) ) \<Longrightarrow> (P (m - (m div 2) ) \<Longrightarrow>P m)" using 2 by metis
    from 3 4 have 7:" P (m div 2)" by auto
    from 3 5 have 8:"P (m - (m div 2) )" by auto
    from 6 7 8 show " P m" by auto
  qed
qed

lemma num_induct: "P (0::nat) \<Longrightarrow> P 1\<Longrightarrow> ( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) ) \<Longrightarrow>P num"
proof -
  assume 1:"P 0"
  assume 2:"P 1"
  assume 22:"( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) )"
  have "\<And> m. (\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m"
  proof -
    fix m
    show "(\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m"
    proof (cases)
      assume 3:"m<2"
      show "(\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m"
      proof (cases)
        assume "m = 0"
        from 1 this show "(\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m" by auto
      next
        assume "~ m= 0"
        from 3 this have "m =1" by auto
        from 2 this show "(\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m" by auto
      qed
    next
      assume "\<not> (m < 2)"
      from this have "m \<ge>2" by auto
      from this num_induct_pre have "( \<And> x . (P (x div 2) ) \<Longrightarrow> (P (x - (x div 2) ) \<Longrightarrow>P x) ) \<Longrightarrow>  (\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m" by metis
      from this 22 show "(\<And> n. n  < m \<Longrightarrow> P n) \<Longrightarrow>P m" by metis
    qed
  qed
  from this num_induct2 show " P num" by metis

qed

value " (1::nat) div 2"

lemma
  fixes ll :: "nat list"
  fixes n :: "nat"
shows "(\<And> n ll . (length(ll) = n  \<Longrightarrow>P(ll)) ) \<Longrightarrow> P all " by metis

(* " (\<And> m. (\<And> n. (n::nat) < m \<Longrightarrow> P n) \<Longrightarrow>P m )  \<Longrightarrow> P all" *)
lemma list_induct_pre:
  shows "  ( \<And> mm. (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm))  \<Longrightarrow> P []   "
proof -
  assume 1:"( \<And> mm. (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm))"
  have 2:"  (\<And> ll .length(ll) < (length [])   \<Longrightarrow>P(ll) )" by auto
  from 1 2 show "P []" by metis
qed

lemma list_induct_pre2:
  assumes 1:"( \<And> mm. (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm))"
  shows " \<And> mm. (  (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )    \<Longrightarrow> P(mm)  ) \<Longrightarrow> (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )   "
proof -
  fix mm
  (*show "(  (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )    \<Longrightarrow> P(mm)  ) \<Longrightarrow> (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )"
    this one doesnt work,  bc isbella auto move goal \<And> to the begin*)
  have "(  (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )    \<Longrightarrow> P(mm)  ) \<Longrightarrow> ! ll. ( (length(ll) < (length mm) ) \<longrightarrow>P(ll) ) "
  proof (induct mm)
    show "((\<And>ll. length ll < length [] \<Longrightarrow> P ll) \<Longrightarrow> P []) \<Longrightarrow> (! ll. length ll < length [] \<longrightarrow> P ll)" by auto
  next
    show "\<And>a mmm. (((\<And>ll. length ll < length mmm \<Longrightarrow> P ll) \<Longrightarrow> P mmm) \<Longrightarrow>( ! ll .length ll < length mmm \<longrightarrow> P ll) ) \<Longrightarrow>
            ((\<And>ll. length ll < length (a # mmm) \<Longrightarrow> P ll) \<Longrightarrow> P (a # mmm)) \<Longrightarrow> (! ll. length ll < length (a # mmm) \<longrightarrow> P ll )"
    proof -
      fix a mmm
      assume 2:"(((\<And>ll. length ll < length mmm \<Longrightarrow> P ll) \<Longrightarrow> P mmm) \<Longrightarrow>( \<forall> ll. length ll < length mmm \<longrightarrow> P ll) )"
      assume 3:"((\<And>ll. length ll < length (a # mmm) \<Longrightarrow> P ll) \<Longrightarrow> P (a # mmm))"
      have 4: "\<And> ll. length ll < length (mmm) \<Longrightarrow> P ll" using 1 2 by metis
      have 5:"\<forall> ll. length ll = length (mmm) \<longrightarrow> P ll" using 1 4 by metis
      show "\<forall> ll. length ll < length (a # mmm) \<longrightarrow> P ll"
      proof
        fix ll
        show "length ll < length (a # mmm) \<longrightarrow> P ll"
        proof (cases)
          assume "length ll < length mmm"
          from this show "length ll < length (a # mmm) \<longrightarrow> P ll" using 4 by metis
        next
          assume assume1:"\<not> length ll < length mmm"
          show "length ll < length (a # mmm) \<longrightarrow> P ll"
          proof
            assume "length ll < length (a # mmm)"
            from this assume1 have "length ll =length mmm" by auto
            from this 5 show "P ll" by auto
          qed
        qed
      qed
    qed
  qed
  from this show "(  (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )    \<Longrightarrow> P(mm)  ) \<Longrightarrow> (\<And> ll. ( (length(ll) < (length mm) ) \<Longrightarrow>P(ll) ) )"
    by metis
qed

lemma list_induct:
  fixes n :: "nat"
  shows "  ( \<And> mm. (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm) )  \<Longrightarrow> P all   "
proof (induct all)
  case Nil
  then show ?case using list_induct_pre by metis
next
  show "\<And>la llt. ((\<And>mm. (\<And>ll. length ll < length mm \<Longrightarrow> P ll) \<Longrightarrow> P mm) \<Longrightarrow> P llt) \<Longrightarrow>
              (\<And>mm. (\<And>ll. length ll < length mm \<Longrightarrow> P ll) \<Longrightarrow> P mm) \<Longrightarrow> P (la # llt)"
  proof -
    fix la llt
    assume 1:"(\<And>mm. (\<And>ll. length ll < length mm \<Longrightarrow> P ll) \<Longrightarrow> P mm) \<Longrightarrow> P llt"
    assume 2:"(\<And>mm. (\<And>ll. length ll < length mm \<Longrightarrow> P ll) \<Longrightarrow> P mm)"
    from this list_induct_pre2 have 6:"\<And> mm. (  (\<And> ll .(length(ll) < (length mm) \<Longrightarrow>P(ll)) )    \<Longrightarrow> P(mm)  ) \<Longrightarrow> (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )"
      by metis
    from 1 2 have 3: "P llt" by metis
    from 2 have 4:"(\<And>ll. length ll < length (llt) \<Longrightarrow> P ll) \<Longrightarrow> P (llt)" by metis
    from 2 have 5:"(\<And>ll. length ll < length (la # llt) \<Longrightarrow> P ll) \<Longrightarrow> P (la # llt)" by metis
    from this 6 have "\<And> ll . ( length(ll) < (length (la# llt)) )  \<Longrightarrow>P(ll)" by metis
    from this 2 show "P (la # llt)" by metis
  qed
qed

thm length_induct

theorem msort_induct: "P [] \<Longrightarrow>
    (\<And>x. P [x]) \<Longrightarrow>
    (\<And>v vb vc.
        (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> P (take x (v # vb # vc))) \<Longrightarrow>
        (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> P (drop x (v # vb # vc))) \<Longrightarrow> P (v # vb # vc)) \<Longrightarrow>
    P all"
proof -
  assume r1:"P []"
  assume r2:"\<And>x. P [x]"
  assume r3:"\<And>v vb vc.
        (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> P (take x (v # vb # vc))) \<Longrightarrow>
        (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> P (drop x (v # vb # vc))) \<Longrightarrow> P (v # vb # vc)"
  have " ( \<And> mm. (\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm))"
  proof -
    fix mm
    show "(\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm)"
    proof (cases)
      assume "mm =[]"
      then show "(\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm)" using r1 by auto
    next
      assume ineq1:"~ (mm = []) "
      from this obtain ma mt where eq1:"ma= hd mm" "mt=(tl mm)" by auto
      from ineq1 this have eq2: "mm=(ma#mt)" by auto
      then have "(\<And> ll .(length(ll) < (length ( ma#mt) )  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(ma#mt)"
      proof (cases)
        assume "mt =[]"
        from this show "(\<And> ll .(length(ll) < (length ( ma#mt) )  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(ma#mt)" using r2 by metis
      next
        assume ineq2:"~ (mt= [])"
        from this obtain mb mtt where eq3:"mb= hd mt" "mtt=(tl mt)" by auto
        from this ineq2 have eq4: "mt=mb#mtt" by auto
        have "(\<And> ll .(length(ll) < (length ( ma#mb#mtt) )  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(ma#mb#mtt) "
        proof -
          assume a1:"(\<And> ll .(length(ll) < (length ( ma#mb#mtt) )  \<Longrightarrow>P(ll)) )"
          have t1:" length ( take  ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt) )  < length (ma # mb # mtt)" by auto
          have t2:" length ( drop  ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt) )  < length (ma # mb # mtt)" by auto
          from r3 have " P ( take  ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt))  \<Longrightarrow>
            P ( drop  ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt))   \<Longrightarrow>  P(ma#mb#mtt)   " by metis
          from t1 a1 have t3: " P ( take  ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt)) " by auto
          from t2 a1 have t4: " P ( drop ( length (ma # mb # mtt) div 2 )  (ma#mb#mtt)) " by auto
          from t3 t4 r3 show "P(ma#mb#mtt)" by metis
        qed
        from this eq4 show "(\<And> ll .(length(ll) < (length ( ma#mt) )  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(ma#mt)" by auto
      qed
      then show "(\<And> ll .(length(ll) < (length mm)  \<Longrightarrow>P(ll)) )  \<Longrightarrow> P(mm)" using eq2 by auto
    qed
  qed
  then show "P all" using list_induct by metis
qed


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin_opt
imports QElin
begin

subsubsection{*An optimization*}

text{* Atoms are simplified asap. *}

definition
"asimp a = (case a of
 Less r cs \<Rightarrow> (if \<forall>c\<in> set cs. c = 0
               then if r<0 then TrueF else FalseF
               else Atom a) |
 Eq r cs \<Rightarrow> (if \<forall>c\<in> set cs. c = 0
             then if r=0 then TrueF else FalseF else Atom a))"

lemma asimp_pretty:
"asimp (Less r cs) =
 (if \<forall>c\<in> set cs. c = 0
  then if r<0 then TrueF else FalseF
  else Atom(Less r cs))"
"asimp (Eq r cs) =
 (if \<forall>c\<in> set cs. c = 0
  then if r=0 then TrueF else FalseF
  else Atom(Eq r cs))"
by(auto simp:asimp_def)

definition qe_FMo\<^sub>1 :: "atom list \<Rightarrow> atom fm" where
"qe_FMo\<^sub>1 as = list_conj [asimp(combine p q). p\<leftarrow>lbounds as, q\<leftarrow>ubounds as]"

lemma I_asimp: "R.I (asimp a) xs = I\<^sub>R a xs"
by(simp add:asimp_def iprod0_if_coeffs0 split:atom.split)

lemma I_qe_FMo\<^sub>1: "R.I (qe_FMo\<^sub>1 as) xs = R.I (qe_FM\<^sub>1 as) xs"
by(simp add:qe_FM\<^sub>1_def qe_FMo\<^sub>1_def I_asimp)

definition "qe_FMo = R\<^sub>e.lift_dnfeq_qe qe_FMo\<^sub>1"

lemma qfree_qe_FMo\<^sub>1: "qfree (qe_FMo\<^sub>1 as)"
by(auto simp:qe_FM\<^sub>1_def qe_FMo\<^sub>1_def asimp_def intro!:qfree_list_conj
        split:atom.split)

corollary I_qe_FMo: "R.I (qe_FMo \<phi>) xs = R.I \<phi> xs"
unfolding qe_FMo_def
apply(rule R\<^sub>e.I_lift_dnfeq_qe)
 apply(rule qfree_qe_FMo\<^sub>1)
apply(rule allI)
apply(subst I_qe_FMo\<^sub>1)
apply(rule I_qe_FM\<^sub>1)
 prefer 2 apply blast
apply(clarify)
apply(drule_tac x=a in bspec) apply simp
apply(simp add: depends\<^sub>R_def split:atom.splits list.splits)
done

theorem qfree_qe_FMo: "qfree (qe_FMo f)"
by(simp add:qe_FMo_def R\<^sub>e.qfree_lift_dnfeq_qe qfree_qe_FMo\<^sub>1)

end


(* Title:      Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Binary Iterings\<close>

theory Binary_Iterings

imports Base

begin

class binary_itering = idempotent_left_zero_semiring + while +
  assumes while_productstar: "(x * y) \<star> z = z \<squnion> x * ((y * x) \<star> (y * z))"
  assumes while_sumstar: "(x \<squnion> y) \<star> z = (x \<star> y) \<star> (x \<star> z)"
  assumes while_left_dist_sup: "x \<star> (y \<squnion> z) = (x \<star> y) \<squnion> (x \<star> z)"
  assumes while_sub_associative: "(x \<star> y) * z \<le> x \<star> (y * z)"
  assumes while_simulate_left_plus: "x * z \<le> z * (y \<star> 1) \<squnion> w \<longrightarrow> x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
  assumes while_simulate_right_plus: "z * x \<le> y * (y \<star> z) \<squnion> w \<longrightarrow> z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
begin

text \<open>Theorem 9.1\<close>

lemma while_zero:
  "bot \<star> x = x"
  by (metis sup_bot_right mult_left_zero while_productstar)

text \<open>Theorem 9.4\<close>

lemma while_mult_increasing:
  "x * y \<le> x \<star> y"
  by (metis le_supI2 mult.left_neutral mult_left_sub_dist_sup_left while_productstar)

text \<open>Theorem 9.2\<close>

lemma while_one_increasing:
  "x \<le> x \<star> 1"
  by (metis mult.right_neutral while_mult_increasing)

text \<open>Theorem 9.3\<close>

lemma while_increasing:
  "y \<le> x \<star> y"
  by (metis sup_left_divisibility mult_left_one while_productstar)

text \<open>Theorem 9.42\<close>

lemma while_right_isotone:
  "y \<le> z \<Longrightarrow> x \<star> y \<le> x \<star> z"
  by (metis le_iff_sup while_left_dist_sup)

text \<open>Theorem 9.41\<close>

lemma while_left_isotone:
  "x \<le> y \<Longrightarrow> x \<star> z \<le> y \<star> z"
  using sup_left_divisibility while_sumstar while_increasing by auto

lemma while_isotone:
  "w \<le> x \<Longrightarrow> y \<le> z \<Longrightarrow> w \<star> y \<le> x \<star> z"
  by (meson order_lesseq_imp while_left_isotone while_right_isotone)

text \<open>Theorem 9.17\<close>

lemma while_left_unfold:
  "x \<star> y = y \<squnion> x * (x \<star> y)"
  by (metis mult_1_left mult_1_right while_productstar)

lemma while_simulate_left_plus_1:
  "x * z \<le> z * (y \<star> 1) \<Longrightarrow> x \<star> (z * w) \<le> z * (y \<star> w) \<squnion> (x \<star> bot)"
  by (metis sup_bot_right mult_left_zero while_simulate_left_plus)

text \<open>Theorem 11.1\<close>

lemma while_simulate_absorb:
  "y * x \<le> x \<Longrightarrow> y \<star> x \<le> x \<squnion> (y \<star> bot)"
  by (metis while_simulate_left_plus_1 while_zero mult_1_right)

text \<open>Theorem 9.10\<close>

lemma while_transitive:
  "x \<star> (x \<star> y) = x \<star> y"
  by (metis order.eq_iff sup_bot_right sup_ge2 while_left_dist_sup while_increasing while_left_unfold while_simulate_absorb)

text \<open>Theorem 9.25\<close>

lemma while_slide:
  "(x * y) \<star> (x * z) = x * ((y * x) \<star> z)"
  by (metis mult_left_dist_sup while_productstar mult_assoc while_left_unfold)

text \<open>Theorem 9.21\<close>

lemma while_zero_2:
  "(x * bot) \<star> y = x * bot \<squnion> y"
  by (metis mult_left_zero sup_commute mult_assoc while_left_unfold)

text \<open>Theorem 9.5\<close>

lemma while_mult_star_exchange:
  "x * (x \<star> y) = x \<star> (x * y)"
  by (metis mult_left_one while_slide)

text \<open>Theorem 9.18\<close>

lemma while_right_unfold:
  "x \<star> y = y \<squnion> (x \<star> (x * y))"
  by (metis while_left_unfold while_mult_star_exchange)

text \<open>Theorem 9.7\<close>

lemma while_one_mult_below:
  "(x \<star> 1) * y \<le> x \<star> y"
  by (metis mult_left_one while_sub_associative)

lemma while_plus_one:
  "x \<star> y = y \<squnion> (x \<star> y)"
  by (simp add: sup.absorb2 while_increasing)

text \<open>Theorem 9.19\<close>

lemma while_rtc_2:
  "y \<squnion> x * y \<squnion> (x \<star> (x \<star> y)) = x \<star> y"
  by (simp add: sup_absorb2 while_increasing while_mult_increasing while_transitive)

text \<open>Theorem 9.6\<close>

lemma while_left_plus_below:
  "x * (x \<star> y) \<le> x \<star> y"
  by (metis sup_right_divisibility while_left_unfold)

lemma while_right_plus_below:
  "x \<star> (x * y) \<le> x \<star> y"
  using while_left_plus_below while_mult_star_exchange by auto

lemma while_right_plus_below_2:
  "(x \<star> x) * y \<le> x \<star> y"
  by (smt order_trans while_right_plus_below while_sub_associative)

text \<open>Theorem 9.47\<close>

lemma while_mult_transitive:
  "x \<le> z \<star> y \<Longrightarrow> y \<le> z \<star> w \<Longrightarrow> x \<le> z \<star> w"
  by (smt order_trans while_right_isotone while_transitive)

text \<open>Theorem 9.48\<close>

lemma while_mult_upper_bound:
  "x \<le> z \<star> 1 \<Longrightarrow> y \<le> z \<star> w \<Longrightarrow> x * y \<le> z \<star> w"
  by (metis order.trans mult_isotone while_one_mult_below while_transitive)

lemma while_one_mult_while_below:
  "(y \<star> 1) * (y \<star> v) \<le> y \<star> v"
  by (simp add: while_mult_upper_bound)

text \<open>Theorem 9.34\<close>

lemma while_sub_dist:
  "x \<star> z \<le> (x \<squnion> y) \<star> z"
  by (simp add: while_left_isotone)

lemma while_sub_dist_1:
  "x * z \<le> (x \<squnion> y) \<star> z"
  using order.trans while_mult_increasing while_sub_dist by blast

lemma while_sub_dist_2:
  "x * y * z \<le> (x \<squnion> y) \<star> z"
  by (metis sup_commute mult_assoc while_mult_transitive while_sub_dist_1)

text \<open>Theorem 9.36\<close>

lemma while_sub_dist_3:
  "x \<star> (y \<star> z) \<le> (x \<squnion> y) \<star> z"
  by (metis sup_commute while_mult_transitive while_sub_dist)

text \<open>Theorem 9.44\<close>

lemma while_absorb_2:
  "x \<le> y \<Longrightarrow> y \<star> (x \<star> z) = y \<star> z"
  using sup_left_divisibility while_sumstar while_transitive by auto

lemma while_simulate_right_plus_1:
  "z * x \<le> y * (y \<star> z) \<Longrightarrow> z * (x \<star> w) \<le> y \<star> (z * w)"
  by (metis sup_bot_right mult_left_zero while_simulate_right_plus)

text \<open>Theorem 9.39\<close>

lemma while_sumstar_1_below:
  "x \<star> ((y * (x \<star> 1)) \<star> z) \<le> ((x \<star> 1) * y) \<star> (x \<star> z)"
proof -
  have 1: "x * (((x \<star> 1) * y) \<star> (x \<star> z)) \<le> ((x \<star> 1) * y) \<star> (x \<star> z)"
    by (smt sup_mono sup_ge2 mult_assoc mult_left_dist_sup mult_right_sub_dist_sup_right while_left_unfold)
  have "x \<star> ((y * (x \<star> 1)) \<star> z) \<le> (x \<star> z) \<squnion> (x \<star> (y * (((x \<star> 1) * y) \<star> ((x \<star> 1) * z))))"
    by (metis eq_refl while_left_dist_sup while_productstar)
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> ((x \<star> 1) * y * (((x \<star> 1) * y) \<star> ((x \<star> 1) * z))))"
    by (metis sup_right_isotone mult_assoc mult_left_one mult_right_sub_dist_sup_left while_left_unfold while_right_isotone)
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> (((x \<star> 1) * y) \<star> ((x \<star> 1) * z)))"
    using semiring.add_left_mono while_left_plus_below while_right_isotone by blast
  also have "... \<le> x \<star> (((x \<star> 1) * y) \<star> (x \<star> z))"
    by (meson order.trans le_supI while_increasing while_one_mult_below while_right_isotone)
  also have "... \<le> (((x \<star> 1) * y) \<star> (x \<star> z)) \<squnion> (x \<star> bot)"
    using 1 while_simulate_absorb by auto
  also have "... = ((x \<star> 1) * y) \<star> (x \<star> z)"
    by (smt sup_assoc sup_commute sup_bot_left while_left_dist_sup while_left_unfold)
  finally show ?thesis
    .
qed

lemma while_sumstar_2_below:
  "((x \<star> 1) * y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> (x \<star> z)"
  by (simp add: while_left_isotone while_one_mult_below)

text \<open>Theorem 9.38\<close>

lemma while_sup_1_below:
  "x \<star> ((y * (x \<star> 1)) \<star> z) \<le> (x \<squnion> y) \<star> z"
proof -
  have "((x \<star> 1) * y) \<star> ((x \<star> 1) * z) \<le> (x \<squnion> y) \<star> z"
    using while_sumstar while_isotone while_one_mult_below by auto
  hence "(y * (x \<star> 1)) \<star> z \<le> z \<squnion> y * ((x \<squnion> y) \<star> z)"
    by (metis sup_right_isotone mult_right_isotone while_productstar)
  also have "... \<le> (x \<squnion> y) \<star> z"
    by (metis sup_right_isotone sup_ge2 mult_left_isotone while_left_unfold)
  finally show ?thesis
    using while_mult_transitive while_sub_dist by blast
qed

text \<open>Theorem 9.16\<close>

lemma while_while_while:
  "((x \<star> 1) \<star> 1) \<star> y = (x \<star> 1) \<star> y"
  by (smt (z3) sup.absorb1 while_sumstar while_absorb_2 while_increasing while_one_increasing)

lemma while_one:
  "(1 \<star> 1) \<star> y = 1 \<star> y"
  by (metis while_while_while while_zero)

text \<open>Theorem 9.22\<close>

lemma while_sup_below:
  "x \<squnion> y \<le> x \<star> (y \<star> 1)"
  by (metis le_supI le_supI1 while_left_dist_sup while_left_unfold while_one_increasing)

text \<open>Theorem 9.32\<close>

lemma while_sup_2:
  "(x \<squnion> y) \<star> z \<le> (x \<star> (y \<star> 1)) \<star> z"
  using while_left_isotone while_sup_below by auto

text \<open>Theorem 9.45\<close>

lemma while_sup_one_left_unfold:
  "1 \<le> x \<Longrightarrow> x * (x \<star> y) = x \<star> y"
  by (metis order.antisym mult_1_left mult_left_isotone while_left_plus_below)

lemma while_sup_one_right_unfold:
  "1 \<le> x \<Longrightarrow> x \<star> (x * y) = x \<star> y"
  using while_mult_star_exchange while_sup_one_left_unfold by auto

text \<open>Theorem 9.30\<close>

lemma while_decompose_7:
  "(x \<squnion> y) \<star> z = x \<star> (y \<star> ((x \<squnion> y) \<star> z))"
  by (metis order.eq_iff order_trans while_increasing while_sub_dist_3 while_transitive)

text \<open>Theorem 9.31\<close>

lemma while_decompose_8:
  "(x \<squnion> y) \<star> z = (x \<squnion> y) \<star> (x \<star> (y \<star> z))"
  using while_absorb_2 by auto

text \<open>Theorem 9.27\<close>

lemma while_decompose_9:
  "(x \<star> (y \<star> 1)) \<star> z = x \<star> (y \<star> ((x \<star> (y \<star> 1)) \<star> z))"
  by (smt sup_commute le_iff_sup order_trans while_sup_below while_increasing while_sub_dist_3)

lemma while_decompose_10:
  "(x \<star> (y \<star> 1)) \<star> z = (x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z))"
proof -
  have 1: "(x \<star> (y \<star> 1)) \<star> z \<le> (x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z))"
    by (meson order.trans while_increasing while_right_isotone)
  have "x \<squnion> (y \<star> 1) \<le> x \<star> (y \<star> 1)"
    using while_increasing while_sup_below by auto
  hence "(x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z)) \<le> (x \<star> (y \<star> 1)) \<star> z"
    using while_absorb_2 while_sup_below by force
  thus ?thesis
    using 1 order.antisym by blast
qed

lemma while_back_loop_fixpoint:
  "z * (y \<star> (y * x)) \<squnion> z * x = z * (y \<star> x)"
  by (metis sup_commute mult_left_dist_sup while_right_unfold)

lemma while_back_loop_prefixpoint:
  "z * (y \<star> 1) * y \<squnion> z \<le> z * (y \<star> 1)"
  by (metis le_supI le_supI2 mult_1_right mult_right_isotone mult_assoc while_increasing while_one_mult_below while_right_unfold)

text \<open>Theorem 9\<close>

lemma while_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)"
  using is_fixpoint_def sup_commute while_left_unfold by auto

text \<open>Theorem 9\<close>

lemma while_back_loop_is_prefixpoint:
  "is_prefixpoint (\<lambda>x . x * y \<squnion> z) (z * (y \<star> 1))"
  using is_prefixpoint_def while_back_loop_prefixpoint by auto

text \<open>Theorem 9.20\<close>

lemma while_while_sup:
  "(1 \<squnion> x) \<star> y = (x \<star> 1) \<star> y"
  by (metis sup_commute while_decompose_10 while_sumstar while_zero)

lemma while_while_mult_sub:
  "x \<star> (1 \<star> y) \<le> (x \<star> 1) \<star> y"
  by (metis sup_commute while_sub_dist_3 while_while_sup)

text \<open>Theorem 9.11\<close>

lemma while_right_plus:
  "(x \<star> x) \<star> y = x \<star> y"
  by (metis sup_idem while_plus_one while_sumstar while_transitive)

text \<open>Theorem 9.12\<close>

lemma while_left_plus:
  "(x * (x \<star> 1)) \<star> y = x \<star> y"
  by (simp add: while_mult_star_exchange while_right_plus)

text \<open>Theorem 9.9\<close>

lemma while_below_while_one:
  "x \<star> x \<le> x \<star> 1"
  by (meson eq_refl while_mult_transitive while_one_increasing)

lemma while_below_while_one_mult:
  "x * (x \<star> x) \<le> x * (x \<star> 1)"
  by (simp add: mult_right_isotone while_below_while_one)

text \<open>Theorem 9.23\<close>

lemma while_sup_sub_sup_one:
  "x \<star> (x \<squnion> y) \<le> x \<star> (1 \<squnion> y)"
  using semiring.add_right_mono while_left_dist_sup while_below_while_one by auto

lemma while_sup_sub_sup_one_mult:
  "x * (x \<star> (x \<squnion> y)) \<le> x * (x \<star> (1 \<squnion> y))"
  by (simp add: mult_right_isotone while_sup_sub_sup_one)

lemma while_elimination:
  "x * y = bot \<Longrightarrow> x * (y \<star> z) = x * z"
  by (metis sup_bot_right mult_assoc mult_left_dist_sup mult_left_zero while_left_unfold)

text \<open>Theorem 9.8\<close>

lemma while_square:
  "(x * x) \<star> y \<le> x \<star> y"
  by (metis while_left_isotone while_mult_increasing while_right_plus)

text \<open>Theorem 9.35\<close>

lemma while_mult_sub_sup:
  "(x * y) \<star> z \<le> (x \<squnion> y) \<star> z"
  by (metis while_increasing while_isotone while_mult_increasing while_sumstar)

text \<open>Theorem 9.43\<close>

lemma while_absorb_1:
  "x \<le> y \<Longrightarrow> x \<star> (y \<star> z) = y \<star> z"
  by (metis order.antisym le_iff_sup while_increasing while_sub_dist_3)

lemma while_absorb_3:
  "x \<le> y \<Longrightarrow> x \<star> (y \<star> z) = y \<star> (x \<star> z)"
  by (simp add: while_absorb_1 while_absorb_2)

text \<open>Theorem 9.24\<close>

lemma while_square_2:
  "(x * x) \<star> ((x \<squnion> 1) * y) \<le> x \<star> y"
  by (metis le_supI while_increasing while_mult_transitive while_mult_upper_bound while_one_increasing while_square)

lemma while_separate_unfold_below:
  "(y * (x \<star> 1)) \<star> z \<le> (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z))))"
proof -
  have "(y * (x \<star> 1)) \<star> z = (y \<star> (y * x * (x \<star> 1))) \<star> (y \<star> z)"
    by (metis mult_assoc mult_left_dist_sup mult_1_right while_left_unfold while_sumstar)
  hence "(y * (x \<star> 1)) \<star> z = (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> 1))) * ((y * (x \<star> 1)) \<star> z)"
    using while_left_unfold by auto
  also have "... \<le> (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> 1)) * ((y * (x \<star> 1)) \<star> z))"
    using sup_right_isotone while_sub_associative by auto
  also have "... \<le> (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z))))"
    by (smt sup_right_isotone mult_assoc mult_right_isotone while_one_mult_below while_right_isotone)
  finally show ?thesis
    .
qed

text \<open>Theorem 9.33\<close>

lemma while_mult_zero_sup:
  "(x \<squnion> y * bot) \<star> z = x \<star> ((y * bot) \<star> z)"
proof -
  have "(x \<squnion> y * bot) \<star> z = (x \<star> (y * bot)) \<star> (x \<star> z)"
    by (simp add: while_sumstar)
  also have "... = (x \<star> z) \<squnion> (x \<star> (y * bot)) * ((x \<star> (y * bot)) \<star> (x \<star> z))"
    using while_left_unfold by auto
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> (y * bot))"
    by (metis sup_right_isotone mult_assoc mult_left_zero while_sub_associative)
  also have "... = x \<star> ((y * bot) \<star> z)"
    by (simp add: sup_commute while_left_dist_sup while_zero_2)
  finally show ?thesis
    by (simp add: order.antisym while_sub_dist_3)
qed

lemma while_sup_mult_zero:
  "(x \<squnion> y * bot) \<star> y = x \<star> y"
  by (simp add: sup_absorb2 zero_right_mult_decreasing while_mult_zero_sup while_zero_2)

lemma while_mult_zero_sup_2:
  "(x \<squnion> y * bot) \<star> z = (x \<star> z) \<squnion> (x \<star> (y * bot))"
  by (simp add: sup_commute while_left_dist_sup while_mult_zero_sup while_zero_2)

lemma while_sup_zero_star:
  "(x \<squnion> y * bot) \<star> z = x \<star> (y * bot \<squnion> z)"
  by (simp add: while_mult_zero_sup while_zero_2)

lemma while_unfold_sum:
  "(x \<squnion> y) \<star> z = (x \<star> z) \<squnion> (x \<star> (y * ((x \<squnion> y) \<star> z)))"
  apply (rule order.antisym)
  apply (metis semiring.add_left_mono while_sub_associative while_sumstar while_left_unfold)
  by (metis le_supI while_decompose_7 while_mult_increasing while_right_isotone while_sub_dist)

lemma while_simulate_left:
  "x * z \<le> z * y \<squnion> w \<Longrightarrow> x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
  by (metis sup_left_isotone mult_right_isotone order_trans while_one_increasing while_simulate_left_plus)

lemma while_simulate_right:
  assumes "z * x \<le> y * z \<squnion> w"
    shows "z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
proof -
  have "y * z \<squnion> w \<le> y * (y \<star> z) \<squnion> w"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  thus ?thesis
    by (meson assms order.trans while_simulate_right_plus)
qed

lemma while_simulate:
  "z * x \<le> y * z \<Longrightarrow> z * (x \<star> v) \<le> y \<star> (z * v)"
  by (metis sup_bot_right mult_left_zero while_simulate_right)

text \<open>Theorem 9.14\<close>

lemma while_while_mult:
  "1 \<star> (x \<star> y) = (x \<star> 1) \<star> y"
proof -
  have "(x \<star> 1) \<star> y \<le> (x \<star> 1) * ((x \<star> 1) \<star> y)"
    by (simp add: while_increasing while_sup_one_left_unfold)
  also have "... \<le> 1 \<star> ((x \<star> 1) * y)"
    by (simp add: while_one_mult_while_below while_simulate)
  also have "... \<le> 1 \<star> (x \<star> y)"
    by (simp add: while_isotone while_one_mult_below)
  finally show ?thesis
    by (metis order.antisym while_sub_dist_3 while_while_sup)
qed

lemma while_simulate_left_1:
  "x * z \<le> z * y \<Longrightarrow> x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> bot)"
  by (meson order.trans mult_right_isotone while_one_increasing while_simulate_left_plus_1)

text \<open>Theorem 9.46\<close>

lemma while_associative_1:
  assumes "1 \<le> z"
  shows "x \<star> (y * z) = (x \<star> y) * z"
proof -
  have "x \<star> (y * z) \<le> x \<star> ((x \<star> y) * z)"
    by (simp add: mult_isotone while_increasing while_right_isotone)
  also have "... \<le> (x \<star> y) * (bot \<star> z) \<squnion> (x \<star> bot)"
    by (metis mult_assoc mult_right_sub_dist_sup_right while_left_unfold while_simulate_absorb while_zero)
  also have "... \<le> (x \<star> y) * z \<squnion> (x \<star> bot) * z"
    by (metis assms le_supI sup_ge1 sup_ge2 case_split_right while_plus_one while_zero)
  also have "... = (x \<star> y) * z"
    by (metis sup_bot_right mult_right_dist_sup while_left_dist_sup)
  finally show ?thesis
    by (simp add: order.antisym while_sub_associative)
qed

text \<open>Theorem 9.29\<close>

lemma while_associative_while_1:
  "x \<star> (y * (z \<star> 1)) = (x \<star> y) * (z \<star> 1)"
  by (simp add: while_associative_1 while_increasing)

text \<open>Theorem 9.13\<close>

lemma while_one_while:
  "(x \<star> 1) * (y \<star> 1) = x \<star> (y \<star> 1)"
  by (metis mult_left_one while_associative_while_1)

lemma while_decompose_5_below:
  "(x \<star> (y \<star> 1)) \<star> z \<le> (y \<star> (x \<star> 1)) \<star> z"
  by (smt (z3) while_left_dist_sup while_sumstar while_absorb_2 while_one_increasing while_plus_one while_sub_dist)

text \<open>Theorem 9.26\<close>

lemma while_decompose_5:
  "(x \<star> (y \<star> 1)) \<star> z = (y \<star> (x \<star> 1)) \<star> z"
  by (simp add: order.antisym while_decompose_5_below)

lemma while_decompose_4:
  "(x \<star> (y \<star> 1)) \<star> z = x \<star> ((y \<star> (x \<star> 1)) \<star> z)"
  using while_absorb_1 while_decompose_5 while_sup_below by auto

text \<open>Theorem 11.7\<close>

lemma while_simulate_2:
  "y * (x \<star> 1) \<le> x \<star> (y \<star> 1) \<longleftrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
proof
  assume "y * (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  hence "y * (x \<star> 1) \<le> (x \<star> 1) * (y \<star> 1)"
    by (simp add: while_one_while)
  hence "y \<star> ((x \<star> 1) * 1) \<le> (x \<star> 1) * (y \<star> 1) \<squnion> (y \<star> bot)"
    using while_simulate_left_plus_1 by blast
  hence "y \<star> (x \<star> 1) \<le> (x \<star> (y \<star> 1)) \<squnion> (y \<star> bot)"
    by (simp add: while_one_while)
  also have "... = x \<star> (y \<star> 1)"
    by (metis sup_commute le_iff_sup order_trans while_increasing while_right_isotone bot_least)
  finally show "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
    .
next
  assume "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  thus "y * (x \<star> 1) \<le> x \<star> (y \<star> 1)"
    using order_trans while_mult_increasing by blast
qed

lemma while_simulate_1:
  "y * x \<le> x * y \<Longrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  by (metis order_trans while_mult_increasing while_right_isotone while_simulate while_simulate_2)

lemma while_simulate_3:
  "y * (x \<star> 1) \<le> x \<star> 1 \<Longrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  by (meson order.trans while_increasing while_right_isotone while_simulate_2)

text \<open>Theorem 9.28\<close>

lemma while_extra_while:
  "(y * (x \<star> 1)) \<star> z = (y * (y \<star> (x \<star> 1))) \<star> z"
proof -
  have "y * (y \<star> (x \<star> 1)) \<le> y * (x \<star> 1) * (y * (x \<star> 1) \<star> 1)"
    using while_back_loop_prefixpoint while_left_isotone while_mult_star_exchange by auto
  hence 1: "(y * (y \<star> (x \<star> 1))) \<star> z \<le> (y * (x \<star> 1)) \<star> z"
    by (metis while_simulate_right_plus_1 mult_left_one)
  have "(y * (x \<star> 1)) \<star> z \<le> (y * (y \<star> (x \<star> 1))) \<star> z"
    by (simp add: while_increasing while_left_isotone while_mult_star_exchange)
  thus ?thesis
    using 1 order.antisym by auto
qed

text \<open>Theorem 11.6\<close>

lemma while_separate_4:
  assumes "y * x \<le> x * (x \<star> (1 \<squnion> y))"
    shows "(x \<squnion> y) \<star> z = x \<star> (y \<star> z)"
proof -
  have "(1 \<squnion> y) * x \<le> x * (x \<star> (1 \<squnion> y))"
    by (smt assms sup_assoc le_supI mult_left_one mult_left_sub_dist_sup_left mult_right_dist_sup mult_1_right while_left_unfold)
  hence 1: "(1 \<squnion> y) * (x \<star> 1) \<le> x \<star> (1 \<squnion> y)"
    by (metis mult_1_right while_simulate_right_plus_1)
  have "y * x * (x \<star> 1) \<le> x * (x \<star> ((1 \<squnion> y) * (x \<star> 1)))"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup while_associative_1 while_increasing)
  also have "... \<le> x * (x \<star> (1 \<squnion> y))"
    using 1 mult_right_isotone while_mult_transitive by blast
  also have "... \<le> x * (x \<star> 1) * (y \<star> 1)"
    by (simp add: mult_right_isotone mult_assoc while_increasing while_one_increasing while_one_while while_right_isotone)
  finally have "y \<star> (x * (x \<star> 1)) \<le> x * (x \<star> 1) * (y \<star> 1) \<squnion> (y \<star> bot)"
    by (metis mult_assoc mult_1_right while_simulate_left_plus_1)
  hence "(y \<star> 1) * (y \<star> x) \<le> x * (x \<star> y \<star> 1) \<squnion> (y \<star> bot)"
    by (smt le_iff_sup mult_assoc mult_1_right order_refl order_trans while_absorb_2 while_left_dist_sup while_mult_star_exchange while_one_mult_below while_one_while while_plus_one)
  hence "(y \<star> 1) * ((y \<star> x) \<star> (y \<star> z)) \<le> x \<star> ((y \<star> 1) * (y \<star> z) \<squnion> (y \<star> bot) * ((y \<star> x) \<star> (y \<star> z)))"
    by (simp add: while_simulate_right_plus)
  also have "... \<le> x \<star> ((y \<star> z) \<squnion> (y \<star> bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x \<star> y \<star> z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

lemma while_separate_5:
  "y * x \<le> x * (x \<star> (x \<squnion> y)) \<Longrightarrow> (x \<squnion> y) \<star> z = x \<star> (y \<star> z)"
  using order_lesseq_imp while_separate_4 while_sup_sub_sup_one_mult by blast

lemma while_separate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y) \<star> z = x \<star> (y \<star> z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_separate_5)

text \<open>Theorem 11.4\<close>

lemma while_separate_1:
  "y * x \<le> x * y \<Longrightarrow> (x \<squnion> y) \<star> z = x \<star> (y \<star> z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_separate_6 by blast

text \<open>Theorem 11.2\<close>

lemma while_separate_mult_1:
  "y * x \<le> x * y \<Longrightarrow> (x * y) \<star> z \<le> x \<star> (y \<star> z)"
  by (metis while_mult_sub_sup while_separate_1)

text \<open>Theorem 11.5\<close>

lemma separation:
  assumes "y * x \<le> x * (y \<star> 1)"
    shows "(x \<squnion> y) \<star> z = x \<star> (y \<star> z)"
proof -
  have "y \<star> x \<le> x * (y \<star> 1) \<squnion> (y \<star> bot)"
    by (metis assms mult_1_right while_simulate_left_plus_1)
  also have "... \<le> x * (x \<star> y \<star> 1) \<squnion> (y \<star> bot)"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  finally have "(y \<star> 1) * (y \<star> x) \<le> x * (x \<star> y \<star> 1) \<squnion> (y \<star> bot)"
    using order.trans while_one_mult_while_below by blast
  hence "(y \<star> 1) * ((y \<star> x) \<star> (y \<star> z)) \<le> x \<star> ((y \<star> 1) * (y \<star> z) \<squnion> (y \<star> bot) * ((y \<star> x) \<star> (y \<star> z)))"
    by (simp add: while_simulate_right_plus)
  also have "... \<le> x \<star> ((y \<star> z) \<squnion> (y \<star> bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x \<star> y \<star> z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

text \<open>Theorem 11.5\<close>

lemma while_separate_left:
  "y * x \<le> x * (y \<star> 1) \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (metis sup_commute separation while_sub_dist_3)

text \<open>Theorem 11.6\<close>

lemma while_simulate_4:
  "y * x \<le> x * (x \<star> (1 \<squnion> y)) \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (metis sup_commute while_separate_4 while_sub_dist_3)

lemma while_simulate_5:
  "y * x \<le> x * (x \<star> (x \<squnion> y)) \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (smt order_trans while_sup_sub_sup_one_mult while_simulate_4)

lemma while_simulate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_simulate_5)

text \<open>Theorem 11.3\<close>

lemma while_simulate_7:
  "y * x \<le> x * y \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_simulate_6 by blast

lemma while_while_mult_1:
  "x \<star> (1 \<star> y) = 1 \<star> (x \<star> y)"
  by (metis sup_commute mult_left_one mult_1_right order_refl while_separate_1)

text \<open>Theorem 9.15\<close>

lemma while_while_mult_2:
  "x \<star> (1 \<star> y) = (x \<star> 1) \<star> y"
  by (simp add: while_while_mult while_while_mult_1)

text \<open>Theorem 11.8\<close>

lemma while_import:
  assumes "p \<le> p * p \<and> p \<le> 1 \<and> p * x \<le> x * p"
    shows "p * (x \<star> y) = p * ((p * x) \<star> y)"
proof -
  have "p * (x \<star> y) \<le> (p * x) \<star> (p * y)"
    using assms test_preserves_equation while_simulate by auto
  also have "... \<le> (p * x) \<star> y"
    by (metis assms le_iff_sup mult_left_one mult_right_dist_sup while_right_isotone)
  finally have 2: "p * (x \<star> y) \<le> p * ((p * x) \<star> y)"
    by (smt assms sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_1_right)
  have "p * ((p * x) \<star> y) \<le> p * (x \<star> y)"
    by (metis assms mult_left_isotone mult_left_one mult_right_isotone while_left_isotone)
  thus ?thesis
    using 2 order.antisym by auto
qed

text \<open>Theorem 11.8\<close>

lemma while_preserve:
  assumes "p \<le> p * p"
      and "p \<le> 1"
      and "p * x \<le> x * p"
    shows "p * (x \<star> y) = p * (x \<star> (p * y))"
proof (rule order.antisym)
  show "p * (x \<star> y) \<le> p * (x \<star> (p * y))"
    by (metis assms order.antisym coreflexive_transitive mult_right_isotone mult_assoc while_simulate)
  show "p * (x \<star> (p * y)) \<le> p * (x \<star> y)"
    by (metis assms(2) mult_left_isotone mult_left_one mult_right_isotone while_right_isotone)
qed

lemma while_plus_below_while:
  "(x \<star> 1) * x \<le> x \<star> 1"
  by (simp add: while_mult_upper_bound while_one_increasing)

text \<open>Theorem 9.40\<close>

lemma while_01:
  "(w * (x \<star> 1)) \<star> (y * z) \<le> (x \<star> w) \<star> ((x \<star> y) * z)"
proof -
  have "(w * (x \<star> 1)) \<star> (y * z) = y * z \<squnion> w * (((x \<star> 1) * w) \<star> ((x \<star> 1) * y * z))"
    by (metis mult_assoc while_productstar)
  also have "... \<le> y * z \<squnion> w * ((x \<star> w) \<star> ((x \<star> y) * z))"
    by (metis sup_right_isotone mult_left_isotone mult_right_isotone while_isotone while_one_mult_below)
  also have "... \<le> (x \<star> y) * z \<squnion> (x \<star> w) * ((x \<star> w) \<star> ((x \<star> y) * z))"
    by (meson mult_left_isotone semiring.add_mono while_increasing)
  finally show ?thesis
    using while_left_unfold by auto
qed

text \<open>Theorem 9.37\<close>

lemma while_while_sub_associative:
  "x \<star> (y \<star> z) \<le> ((x \<star> y) \<star> z) \<squnion> (x \<star> z)"
proof -
  have 1: "x * (x \<star> 1) \<le> (x \<star> 1) * ((x \<star> y) \<star> 1)"
    by (metis le_supE while_back_loop_prefixpoint while_mult_increasing while_mult_transitive while_one_while)
  have "x \<star> (y \<star> z) \<le> x \<star> ((x \<star> 1) * (y \<star> z))"
    by (metis mult_left_isotone mult_left_one while_increasing while_right_isotone)
  also have "... \<le> (x \<star> 1) * ((x \<star> y) \<star> (y \<star> z)) \<squnion> (x \<star> bot)"
    using 1 while_simulate_left_plus_1 by auto
  also have "... \<le> (x \<star> 1) * ((x \<star> y) \<star> z) \<squnion> (x \<star> z)"
    by (simp add: le_supI1 sup_commute while_absorb_2 while_increasing while_right_isotone)
  also have "... = (x \<star> 1) * z \<squnion> (x \<star> 1) * (x \<star> y) * ((x \<star> y) \<star> z) \<squnion> (x \<star> z)"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "... = (x \<star> y) * ((x \<star> y) \<star> z) \<squnion> (x \<star> z)"
    by (smt sup_assoc sup_commute le_iff_sup mult_left_one mult_right_dist_sup order_refl while_absorb_1 while_plus_one while_sub_associative)
  also have "... \<le> ((x \<star> y) \<star> z) \<squnion> (x \<star> z)"
    using sup_left_isotone while_left_plus_below by auto
  finally show ?thesis
    .
qed

lemma while_induct:
  "x * z \<le> z \<and> y \<le> z \<and> x \<star> 1 \<le> z \<Longrightarrow> x \<star> y \<le> z"
  by (metis le_supI1 sup_commute sup_bot_left le_iff_sup while_right_isotone while_simulate_absorb)

proposition while_sumstar_4_below: "(x \<star> y) \<star> ((x \<star> 1) * z) \<le> x \<star> ((y * (x \<star> 1)) \<star> z)" oops
proposition while_sumstar_2: "(x \<squnion> y) \<star> z = x \<star> ((y * (x \<star> 1)) \<star> z)" oops
proposition while_sumstar_3: "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> (x \<star> z)" oops
proposition while_decompose_6: "x \<star> ((y * (x \<star> 1)) \<star> z) = y \<star> ((x * (y \<star> 1)) \<star> z)" oops
proposition while_finite_associative: "x \<star> bot = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)" oops
proposition atomicity_refinement: "s = s * q \<Longrightarrow> x = q * x \<Longrightarrow> q * b = bot \<Longrightarrow> r * b \<le> b * r \<Longrightarrow> r * l \<le> l * r \<Longrightarrow> x * l \<le> l * x \<Longrightarrow> b * l \<le> l * b \<Longrightarrow> q * l \<le> l * q \<Longrightarrow> r \<star> q \<le> q * (r \<star> 1) \<Longrightarrow> q \<le> 1 \<Longrightarrow> s * ((x \<squnion> b \<squnion> r \<squnion> l) \<star> (q * z)) \<le> s * ((x * (b \<star> q) \<squnion> r \<squnion> l) \<star> z)" oops

proposition while_separate_right_plus: "y * x \<le> x * (x \<star> (1 \<squnion> y)) \<squnion> 1 \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)" oops
proposition while_square_1: "x \<star> 1 = (x * x) \<star> (x \<squnion> 1)" oops
proposition while_absorb_below_one: "y * x \<le> x \<Longrightarrow> y \<star> x \<le> 1 \<star> x" oops
proposition "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops
proposition "y * x \<le> (1 \<squnion> x) * (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops

end

class bounded_binary_itering = bounded_idempotent_left_zero_semiring + binary_itering
begin

text \<open>Theorem 9\<close>

lemma while_right_top:
  "x \<star> top = top"
  by (metis sup_left_top while_left_unfold)

text \<open>Theorem 9\<close>

lemma while_left_top:
  "top * (x \<star> 1) = top"
  by (meson order.antisym le_supE top_greatest while_back_loop_prefixpoint)

end

class extended_binary_itering = binary_itering +
  assumes while_denest_0: "w * (x \<star> (y * z)) \<le> (w * (x \<star> y)) \<star> (w * (x \<star> y) * z)"
begin

text \<open>Theorem 10.2\<close>

lemma while_denest_1:
  "w * (x \<star> (y * z)) \<le> (w * (x \<star> y)) \<star> z"
  using while_denest_0 while_mult_increasing while_mult_transitive by blast

lemma while_mult_sub_while_while:
  "x \<star> (y * z) \<le> (x \<star> y) \<star> z"
  by (metis mult_left_one while_denest_1)

lemma while_zero_zero:
  "(x \<star> bot) \<star> bot = x \<star> bot"
  by (metis order.antisym mult_left_zero sup_bot_left while_left_unfold while_sub_associative while_mult_sub_while_while)

text \<open>Theorem 10.11\<close>

lemma while_mult_zero_zero:
  "(x * (y \<star> bot)) \<star> bot = x * (y \<star> bot)"
  apply (rule order.antisym)
  apply (metis sup_bot_left while_left_unfold mult_assoc le_supI1 mult_left_zero mult_right_isotone while_left_dist_sup while_sub_associative)
  by (metis mult_left_zero while_denest_1)

text \<open>Theorem 10.3\<close>

lemma while_denest_2:
  "w * ((x \<star> (y * w)) \<star> z) = w * (((x \<star> y) * w) \<star> z)"
  apply (rule order.antisym)
  apply (metis mult_assoc while_denest_0 while_simulate_right_plus_1 while_slide)
  by (simp add: mult_isotone while_left_isotone while_sub_associative)

text \<open>Theorem 10.12\<close>

lemma while_denest_3:
  "(x \<star> w) \<star> (x \<star> bot) = (x \<star> w) \<star> bot"
  by (metis while_absorb_2 while_right_isotone while_zero_zero bot_least)

text \<open>Theorem 10.15\<close>

lemma while_02:
  "x \<star> ((x \<star> w) \<star> ((x \<star> y) * z)) = (x \<star> w) \<star> ((x \<star> y) * z)"
proof -
  have "x * ((x \<star> w) \<star> ((x \<star> y) * z)) = x * (x \<star> y) * z \<squnion> x * (x \<star> w) * ((x \<star> w) \<star> ((x \<star> y) * z))"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "... \<le> (x \<star> w) \<star> ((x \<star> y) * z)"
    by (metis sup_mono mult_right_sub_dist_sup_right while_left_unfold)
  finally have "x \<star> ((x \<star> w) \<star> ((x \<star> y) * z)) \<le> ((x \<star> w) \<star> ((x \<star> y) * z)) \<squnion> (x \<star> bot)"
    using while_simulate_absorb by auto
  also have "... = (x \<star> w) \<star> ((x \<star> y) * z)"
    by (metis sup_commute le_iff_sup order_trans while_mult_sub_while_while while_right_isotone bot_least)
  finally show ?thesis
    by (simp add: order.antisym while_increasing)
qed

lemma while_sumstar_3_below:
  "(x \<star> y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> ((x \<star> 1) * z)"
proof -
  have "(x \<star> y) \<star> (x \<star> z) = (x \<star> z) \<squnion> ((x \<star> y) \<star> ((x \<star> y) * (x \<star> z)))"
    using while_right_unfold by blast
  also have "... \<le> (x \<star> z) \<squnion> ((x \<star> y) \<star> (x \<star> (y * (x \<star> z))))"
    by (meson sup_right_isotone while_right_isotone while_sub_associative)
  also have "... \<le> (x \<star> z) \<squnion> ((x \<star> y) \<star> (x \<star> ((x \<star> y) \<star> (x \<star> z))))"
    by (smt sup_right_isotone order_trans while_increasing while_mult_upper_bound while_one_increasing while_right_isotone)
  also have "... \<le> (x \<star> z) \<squnion> ((x \<star> y) \<star> (x \<star> ((x \<star> y) \<star> ((x \<star> 1) * z))))"
    by (metis sup_right_isotone mult_left_isotone mult_left_one order_trans while_increasing while_right_isotone while_sumstar while_transitive)
  also have "... = (x \<star> z) \<squnion> ((x \<star> y) \<star> ((x \<star> 1) * z))"
    by (simp add: while_transitive while_02)
  also have "... = (x \<star> y) \<star> ((x \<star> 1) * z)"
    by (smt sup_assoc mult_left_one mult_right_dist_sup while_02 while_left_dist_sup while_plus_one)
  finally show ?thesis
    .
qed

lemma while_sumstar_4_below:
  "(x \<star> y) \<star> ((x \<star> 1) * z) \<le> x \<star> ((y * (x \<star> 1)) \<star> z)"
proof -
  have "(x \<star> y) \<star> ((x \<star> 1) * z) = (x \<star> 1) * z \<squnion> (x \<star> y) * ((x \<star> y) \<star> ((x \<star> 1) * z))"
    using while_left_unfold by auto
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> (y * ((x \<star> y) \<star> ((x \<star> 1) * z))))"
    by (meson sup_mono while_one_mult_below while_sub_associative)
  also have "... = (x \<star> z) \<squnion> (x \<star> (y * (((x \<star> 1) * y) \<star> ((x \<star> 1) * z))))"
    by (metis mult_left_one while_denest_2)
  also have "... = x \<star> ((y * (x \<star> 1)) \<star> z)"
    by (metis while_left_dist_sup while_productstar)
  finally show ?thesis
    .
qed

text \<open>Theorem 10.10\<close>

lemma while_sumstar_1:
  "(x \<squnion> y) \<star> z = (x \<star> y) \<star> ((x \<star> 1) * z)"
  by (smt order.eq_iff order_trans while_sup_1_below while_sumstar while_sumstar_3_below while_sumstar_4_below)

text \<open>Theorem 10.8\<close>

lemma while_sumstar_2:
  "(x \<squnion> y) \<star> z = x \<star> ((y * (x \<star> 1)) \<star> z)"
  using order.antisym while_sup_1_below while_sumstar_1 while_sumstar_4_below by auto

text \<open>Theorem 10.9\<close>

lemma while_sumstar_3:
  "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> (x \<star> z)"
  using order.antisym while_sumstar while_sumstar_1_below while_sumstar_2_below while_sumstar_2 by force

text \<open>Theorem 10.6\<close>

lemma while_decompose_6:
  "x \<star> ((y * (x \<star> 1)) \<star> z) = y \<star> ((x * (y \<star> 1)) \<star> z)"
  by (metis sup_commute while_sumstar_2)

text \<open>Theorem 10.4\<close>

lemma while_denest_4:
  "(x \<star> w) \<star> (x \<star> (y * z)) = (x \<star> w) \<star> ((x \<star> y) * z)"
proof -
  have "(x \<star> w) \<star> (x \<star> (y * z)) = x \<star> ((w * (x \<star> 1)) \<star> (y * z))"
    using while_sumstar while_sumstar_2 by force
  also have "... \<le> (x \<star> w) \<star> ((x \<star> y) * z)"
    by (metis while_01 while_right_isotone while_02)
  finally show ?thesis
    using order.antisym while_right_isotone while_sub_associative by auto
qed

text \<open>Theorem 10.13\<close>

lemma while_denest_5:
  "w * ((x \<star> (y * w)) \<star> (x \<star> (y * z))) = w * (((x \<star> y) * w) \<star> ((x \<star> y) * z))"
  by (simp add: while_denest_2 while_denest_4)

text \<open>Theorem 10.5\<close>

lemma while_denest_6:
  "(w * (x \<star> y)) \<star> z = z \<squnion> w * ((x \<squnion> y * w) \<star> (y * z))"
  by (metis while_denest_5 while_productstar while_sumstar)

text \<open>Theorem 10.1\<close>

lemma while_sum_below_one:
  "y * ((x \<squnion> y) \<star> z) \<le> (y * (x \<star> 1)) \<star> z"
  by (simp add: while_denest_6)

text \<open>Theorem 10.14\<close>

lemma while_separate_unfold:
  "(y * (x \<star> 1)) \<star> z = (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z))))"
proof -
  have "y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z))) \<le> y \<star> (y * ((x \<squnion> y) \<star> z))"
    using mult_right_isotone while_left_plus_below while_right_isotone mult_assoc while_sumstar_2 by auto
  also have "... \<le> (y * (x \<star> 1)) \<star> z"
    by (metis sup_commute sup_ge1 while_absorb_1 while_mult_star_exchange while_sum_below_one)
  finally have "(y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z)))) \<le> (y * (x \<star> 1)) \<star> z"
    using sup.bounded_iff while_back_loop_prefixpoint while_left_isotone by auto
  thus ?thesis
    by (simp add: order.antisym while_separate_unfold_below)
qed

text \<open>Theorem 10.7\<close>

lemma while_finite_associative:
  "x \<star> bot = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)"
  by (metis while_denest_4 while_zero)

text \<open>Theorem 12\<close>

lemma atomicity_refinement:
  assumes "s = s * q"
      and "x = q * x"
      and "q * b = bot"
      and "r * b \<le> b * r"
      and "r * l \<le> l * r"
      and "x * l \<le> l * x"
      and "b * l \<le> l * b"
      and "q * l \<le> l * q"
      and "r \<star> q \<le> q * (r \<star> 1) \<and> q \<le> 1"
    shows "s * ((x \<squnion> b \<squnion> r \<squnion> l) \<star> (q * z)) \<le> s * ((x * (b \<star> q) \<squnion> r \<squnion> l) \<star> z)"
proof -
  have 1: "(x \<squnion> b \<squnion> r) * l \<le> l * (x \<squnion> b \<squnion> r)"
    by (smt assms(5-7) mult_left_dist_sup semiring.add_mono semiring.distrib_right)
  have "q * ((x * (b \<star> r \<star> 1) * q) \<star> z) \<le> (x * (b \<star> r \<star> 1) * q) \<star> z"
    using assms(9) order_lesseq_imp while_increasing while_mult_upper_bound by blast
  also have "... \<le> (x * (b \<star> ((r \<star> 1) * q))) \<star> z"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative mult_assoc)
  also have "... \<le> (x * (b \<star> r \<star> q)) \<star> z"
    by (simp add: mult_right_isotone while_left_isotone while_one_mult_below while_right_isotone)
  also have "... \<le> (x * (b \<star> (q * (r \<star> 1)))) \<star> z"
    by (simp add: assms(9) mult_right_isotone while_left_isotone while_right_isotone)
  finally have 2: "q * ((x * (b \<star> r \<star> 1) * q) \<star> z) \<le> (x * (b \<star> q) * (r \<star> 1)) \<star> z"
    using while_associative_while_1 mult_assoc by auto
  have "s * ((x \<squnion> b \<squnion> r \<squnion> l) \<star> (q * z)) = s * (l \<star> (x \<squnion> b \<squnion> r) \<star> (q * z))"
    using 1 sup_commute while_separate_1 by fastforce
  also have "... = s * q * (l \<star> b \<star> r \<star> (q * x * (b \<star> r \<star> 1)) \<star> (q * z))"
    by (smt assms(1,2,4) sup_assoc sup_commute while_sumstar_2 while_separate_1)
  also have "... = s * q * (l \<star> b \<star> r \<star> (q * ((x * (b \<star> r \<star> 1) * q) \<star> z)))"
    by (simp add: while_slide mult_assoc)
  also have "... \<le> s * q * (l \<star> b \<star> r \<star> (x * (b \<star> q) * (r \<star> 1)) \<star> z)"
    using 2 by (meson mult_right_isotone while_right_isotone)
  also have "... \<le> s * (l \<star> q * (b \<star> r \<star> (x * (b \<star> q) * (r \<star> 1)) \<star> z))"
    by (simp add: assms(8) mult_right_isotone while_simulate mult_assoc)
  also have "... = s * (l \<star> q * (r \<star> (x * (b \<star> q) * (r \<star> 1)) \<star> z))"
    using assms(3) while_elimination by auto
  also have "... \<le> s * (l \<star> r \<star> (x * (b \<star> q) * (r \<star> 1)) \<star> z)"
    by (meson assms(9) order.trans mult_right_isotone order.refl while_increasing while_mult_upper_bound while_right_isotone)
  also have "... = s * (l \<star> (r \<squnion> x * (b \<star> q)) \<star> z)"
    by (simp add: while_sumstar_2)
  also have "... \<le> s * ((x * (b \<star> q) \<squnion> r \<squnion> l) \<star> z)"
    using mult_right_isotone sup_commute while_sub_dist_3 by auto
  finally show ?thesis
    .
qed

end

class bounded_extended_binary_itering = bounded_binary_itering + extended_binary_itering

end


theory ConcreteSemantics9_2_Sec_Typing
  imports Main "~~/src/HOL/IMP/Sec_Type_Expr"
begin

subsubsection "Syntax Directed Typing"

inductive sec_type :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile> _)" [0,0] 50) where
Skip:
  "l \<turnstile> SKIP" |
Assign:
  "\<lbrakk> sec x \<ge> sec a;  sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile> x ::= a" |
Seq:
  "\<lbrakk> l \<turnstile> c\<^sub>1;  l \<turnstile> c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile> c\<^sub>1;;c\<^sub>2" |
If:
  "\<lbrakk> max (sec b) l \<turnstile> c\<^sub>1;  max (sec b) l \<turnstile> c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2" |
While:
  "max (sec b) l \<turnstile> c \<Longrightarrow> l \<turnstile> WHILE b DO c"

code_pred (expected_modes: i => i => bool) sec_type .

value "0 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"
value "0 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x''  ::= N 0 ELSE SKIP"
value "1 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x''  ::= N 0 ELSE SKIP"
value "1 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"
value "2 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"
value "3 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"

inductive_cases [elim!]:
  "l \<turnstile> x ::= a"  "l \<turnstile> c\<^sub>1;;c\<^sub>2"  "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"  "l \<turnstile> WHILE b DO c"

text\<open>An important property: anti-monotonicity.\<close>

(* Lemma 9.12 (Anti-monotonicity). *)
lemma anti_mono: "\<lbrakk> l \<turnstile> c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile> c"
  apply(induction arbitrary: l' rule:sec_type.induct)
      apply (simp add: sec_type.Skip)
  using sec_type.Assign apply auto[1]
    apply (simp add: sec_type.Seq)
  using If apply auto[1]
  by (simp add: While)

(* Lemma 9.13 (Confinement). *)
lemma confinement: "\<lbrakk> (c,s) \<Rightarrow> t;  l \<turnstile> c \<rbrakk> \<Longrightarrow> s = t (< l)"
proof(induction rule: big_step_induct)
case (Skip s)
  then show ?case
    by simp
next
  case (Assign x a s)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by auto
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  hence "max (sec b) l \<turnstile> c\<^sub>1"
    by blast
  hence "l \<turnstile> c\<^sub>1"
    using anti_mono max.cobounded2 by blast
  thus ?case
    by (simp add: IfTrue.IH)
(*
  then show ?case
    by (smt anti_mono com.distinct(11) com.distinct(15) com.distinct(19) com.distinct(5) com.inject(3) max.cobounded2 sec_type.cases) *)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  hence "max (sec b) l \<turnstile> c\<^sub>2"
    by blast
  hence "l \<turnstile> c\<^sub>2"
    using anti_mono max.cobounded2 by blast
  thus ?case
    by (simp add: IfFalse.IH)
next
  case (WhileFalse b s c)
  then show ?case
    by blast
next
  case (WhileTrue b s\<^sub>1 c)
  hence "max (sec b) l \<turnstile> c"
    by blast
  hence "l \<turnstile> c"
    by (simp add: anti_mono)
  then show ?case
    by (simp add: WhileTrue.IH(1) WhileTrue.IH(2) WhileTrue.prems)
qed

(* Theorem 9.14 (Noninterference). *)
theorem noninterference:
  "\<lbrakk> (c,s) \<Rightarrow> s'; (c,t) \<Rightarrow> t';  0 \<turnstile> c;  s = t (\<le> l) \<rbrakk>
   \<Longrightarrow> s' = t' (\<le> l)"
proof(induction arbitrary: t t' rule: big_step_induct)
case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  have [simp]:"t' = t(x := aval a t)" using Assign by auto
  have "sec a \<le> sec x"  using \<open>0 \<turnstile> x ::= a\<close> by auto
  show ?case
  proof auto
(* 1. sec x \<le> l \<Longrightarrow> aval a s = aval a t
 2. \<And>xa. xa \<noteq> x \<Longrightarrow> sec xa \<le> l \<Longrightarrow> s xa = t xa*)
    assume " sec x \<le> l"
    have "sec a \<le> l"
      using \<open>sec a \<le> sec x\<close> \<open>sec x \<le> l\<close> le_trans by blast
    thus " aval a s = aval a t"
      using Assign.prems(3) aval_eq_if_eq_le by blast
  next
    fix xa assume "xa \<noteq> x" "sec xa \<le> l"
    thus "s xa = t xa"
      by (simp add: Assign.prems(3))
  qed
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by blast
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  show ?case
    proof cases
      assume "sec b \<le> l"
      then have "s = t (\<le> sec b)"
        using IfTrue.prems(3) \<open>sec b \<le> l\<close> by auto
      hence "bval b t"
        using IfTrue.hyps(1) bval_eq_if_eq_le by blast
      with IfTrue.IH IfTrue.prems(1,3) \<open>sec b \<turnstile> c\<^sub>1\<close> anti_mono
      show ?thesis by (auto)
    next
      assume "\<not> sec b \<le> l"
      have "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
        by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
      then have "t = t' (\<le> l)"
        using IfTrue.prems(1) \<open>\<not> sec b \<le> l\<close> confinement by auto
      then show ?thesis
        using IfTrue.hyps(2) IfTrue.prems(3) \<open>\<not> sec b \<le> l\<close> \<open>sec b \<turnstile> c\<^sub>1\<close> confinement by fastforce
    qed
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  have "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  show ?case
    proof cases
      assume "sec b \<le> l"
      then have "s = t (\<le> sec b)"
        using IfFalse.prems(3) le_trans by blast
      hence "\<not>bval b t"
        using IfFalse.hyps(1) bval_eq_if_eq_le by auto
      with IfFalse.IH IfFalse.prems(1,3) \<open>sec b \<turnstile> c\<^sub>2\<close> anti_mono
      show ?thesis by blast
    next
      assume "\<not> sec b \<le> l"
      have "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
        by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
      then have "t = t' (\<le> l)"
        using IfFalse.prems(1) \<open>\<not> sec b \<le> l\<close> confinement by auto
      then show ?thesis
        using IfFalse.hyps(2) IfFalse.prems(3) \<open>\<not> sec b \<le> l\<close> \<open>sec b \<turnstile> c\<^sub>2\<close> confinement by fastforce
    qed
next
  case (WhileFalse b s c)
  have "sec b \<turnstile> c"
    using WhileFalse.prems(2) com.distinct(17) com.distinct(19) com.distinct(7) by force
  show ?case
  proof cases
    assume "sec b \<le> l"
      then have "s = t (\<le> sec b)"
        using WhileFalse.prems(3) dual_order.trans by blast
      hence "\<not>bval b t"
        using WhileFalse.hyps bval_eq_if_eq_le by blast
    then show ?thesis
      using WhileFalse.prems(1) WhileFalse.prems(3) by blast
  next
    assume "\<not> sec b \<le> l"
      have "sec b \<turnstile> WHILE b DO c"
        by (simp add: While \<open>sec b \<turnstile> c\<close>)
      then have "t = t' (\<le> l)"
        using WhileFalse.prems(1) \<open>\<not> sec b \<le> l\<close> confinement by auto
    then show ?thesis
      by (simp add: WhileFalse.prems(3))
  qed
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3 t1 t3)
  have "sec b \<turnstile> c"
    using WhileTrue.prems(2) by force
  show ?case
    proof cases
      assume "sec b \<le> l"
      then have "s\<^sub>1 = t1 (\<le> sec b)"
        using WhileTrue.prems(3) \<open>sec b \<le> l\<close> by auto
      hence "bval b t1"
        using WhileTrue.hyps(1) bval_eq_if_eq_le by blast
      then obtain t2 where "(c, t1) \<Rightarrow> t2" "(WHILE b DO c , t2 ) \<Rightarrow> t3"
        using WhileTrue.prems(1) by auto
      with WhileTrue.IH(1,2) WhileTrue.prems(2, 3) anti_mono
      show ?thesis by auto
    next
      assume "\<not> sec b \<le> l"
      have "sec b \<turnstile> WHILE b DO c"
        by (simp add: While \<open>sec b \<turnstile> c\<close>)
      then have "t1 = t3 (\<le> l)"
        using WhileTrue.prems(1) \<open>\<not> sec b \<le> l\<close> confinement max_absorb1 by auto
      with WhileTrue.hyps(2,3) WhileTrue.prems(3) \<open>\<not> sec b \<le> l\<close> \<open>sec b \<turnstile> WHILE b DO c\<close> \<open>sec b \<turnstile> c\<close>
      show ?thesis
        by (smt confinement dual_order.strict_trans not_le_imp_less order.not_eq_order_implies_strict)
    qed
  qed

subsubsection "The Standard Typing System"

text\<open>The predicate \<^prop>\<open>l \<turnstile> c\<close> is nicely intuitive and executable. The
standard formulation, however, is slightly different, replacing the maximum
computation by an antimonotonicity rule. We introduce the standard system now
and show the equivalence with our formulation.\<close>

inductive sec_type' :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile>'' _)" [0,0] 50) where
Skip':
  "l \<turnstile>' SKIP" |
Assign':
  "\<lbrakk> sec x \<ge> sec a; sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile>' x ::= a" |
Seq':
  "\<lbrakk> l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' c\<^sub>1;;c\<^sub>2" |
If':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2" |
While':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c \<rbrakk> \<Longrightarrow> l \<turnstile>' WHILE b DO c" |
anti_mono':
  "\<lbrakk> l \<turnstile>' c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile>' c"

(* Lemma 9.15 *)
lemma sec_type_sec_type': "l \<turnstile> c \<Longrightarrow> l \<turnstile>' c"
  apply(induction rule: sec_type.induct)
      apply (simp add: Skip')
     apply(simp add: Assign')
    apply(simp add: Seq')
(*   apply (smt max.cobounded1 max.cobounded2 sec_type'.simps)*)
   apply (metis max.commute max.absorb_iff2 nat_le_linear If' anti_mono')
  by (metis While' anti_mono' le_cases max.absorb_iff2 max.order_iff)

(* Lemma 9.16 *)
lemma sec_type'_sec_type: "l \<turnstile>' c \<Longrightarrow> l \<turnstile> c"
  apply(induction rule: sec_type'.induct)
       apply(simp add: Skip)
  apply(simp add: Assign)
     apply(simp add: Seq)
    apply (simp add: If max.absorb2)
   apply (simp add: While max_def)
  using anti_mono by blast

subsubsection "A Bottom-Up Typing System"

inductive sec_type2 :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile> _ : _)" [0,0] 50) where
Skip2:
  "\<turnstile> SKIP : l" |
Assign2:
  "sec x \<ge> sec a \<Longrightarrow> \<turnstile> x ::= a : sec x" |
Seq2:
  "\<lbrakk> \<turnstile> c\<^sub>1 : l\<^sub>1;  \<turnstile> c\<^sub>2 : l\<^sub>2 \<rbrakk> \<Longrightarrow> \<turnstile> c\<^sub>1;;c\<^sub>2 : min l\<^sub>1 l\<^sub>2 " |
If2:
  "\<lbrakk> sec b \<le> min l\<^sub>1 l\<^sub>2;  \<turnstile> c\<^sub>1 : l\<^sub>1;  \<turnstile> c\<^sub>2 : l\<^sub>2 \<rbrakk>
  \<Longrightarrow> \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2 : min l\<^sub>1 l\<^sub>2" |
While2:
  "\<lbrakk> sec b \<le> l;  \<turnstile> c : l \<rbrakk> \<Longrightarrow> \<turnstile> WHILE b DO c : l"

(* Lemma 9.17 *)
lemma sec_type2_sec_type': "\<turnstile> c : l \<Longrightarrow> l \<turnstile>' c"
  apply(induction rule: sec_type2.induct)
      apply(simp add: Skip')
     apply(simp add: Assign')
    apply (meson Seq' anti_mono' min.cobounded1 min.cobounded2)
  apply (metis If' anti_mono' le_cases min_def)
  by (simp add: While')

(* Lemma 9.18 *)
lemma sec_type'_sec_type2: "l \<turnstile>' c \<Longrightarrow> \<exists> l' \<ge> l. \<turnstile> c : l'"
  apply(induction rule: sec_type'.induct)
       apply(simp add: Skip2)
       apply(auto)
  using Assign2 apply blast
  using Seq2 min.bounded_iff apply blast
    apply (metis (no_types, hide_lams) If2 le_trans min.bounded_iff)
  using While2 le_trans apply blast
  using le_trans by blast

(* Exercise 9.5 *)
fun ok :: "level \<Rightarrow> com \<Rightarrow> bool"  where
"ok l SKIP = True" |
"ok l (x ::= a) = ((sec x \<ge> sec a) \<and> (sec x \<ge> l))" |
"ok l (c1;;c2) = ((ok l c1) \<and> (ok l c2))" |
"ok l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = ((ok (max (sec b) l) c\<^sub>1) \<and> (ok ( max (sec b) l) c\<^sub>2))" |
"ok l (WHILE b DO c) = ok (max (sec b) l) c"

lemma ok_sec_type: "ok l c \<Longrightarrow> l \<turnstile> c"
  apply(induction rule: ok.induct)
  using sec_type.Skip apply blast
  using sec_type.Assign apply auto
    apply (simp add: sec_type.Seq)
   apply (simp add: If)
  using While by blast

lemma sec_type_ok: "l \<turnstile> c \<Longrightarrow> ok l c"
  apply(induction rule: sec_type.induct)
      apply(simp add: Skip)
     apply(simp add: Assign)
    apply simp
   apply simp
  apply(simp)
  done

theorem "(l \<turnstile> c) = ok l c"
  using ok_sec_type sec_type_ok by blast

(*
Skip':
  "l \<turnstile>' SKIP" |
Assign':
  "\<lbrakk> sec x \<ge> sec a; sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile>' x ::= a" |
Seq':
  "\<lbrakk> l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' c\<^sub>1;;c\<^sub>2" |
If':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2" |
While':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c \<rbrakk> \<Longrightarrow> l \<turnstile>' WHILE b DO c" |
anti_mono':
  "\<lbrakk> l \<turnstile>' c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile>' c"

fun ok' :: "level \<Rightarrow> com \<Rightarrow> bool"  where
"ok' l SKIP = True" |
"ok' l (x ::= a) = ((sec x \<ge> sec a) \<and> (sec x \<ge> l))" |
"ok' l (c1;;c2) = ((ok' l c1) \<and> (ok' l c2))" |
"ok' l (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = ((sec b \<le> l)\<and> (ok l c\<^sub>1) \<and> (ok l c\<^sub>2))" |
"ok' l (WHILE b DO c) = (sec b \<le> l \<and> ok l c)" |
"ok' l' c = (\<exists>l. (ok' l c \<and> l' \<le> l))" <- It is difficult to reformulate this case.
*)

(* Exercise 9.6*)

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>'' _ : _)" [0,0] 50) where
Skip2':
  "\<turnstile>' SKIP : l" |
Assign2':
  "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
Seq2':
  "\<lbrakk> \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1;;c\<^sub>2 : l " |
If2':
  "\<lbrakk> sec b \<le> l;  \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk>
  \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : l" |
While2':
  "\<lbrakk> sec b \<le> l;  \<turnstile>' c : l \<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l"|
Subsumption2':
  "\<lbrakk>\<turnstile>' c:l ; l' \<le> l\<rbrakk> \<Longrightarrow> \<turnstile>' c : l'"

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists> l' \<ge> l. \<turnstile> c : l'"
    apply(induction rule: sec_type2'.induct)
  apply (metis Skip2 less_or_eq_imp_le)
      apply (metis Assign2 less_or_eq_imp_le)

  apply (metis (full_types) Seq' anti_mono' sec_type'_sec_type2 sec_type2_sec_type')

  apply (metis If' anti_mono' sec_type'_sec_type2 sec_type2_sec_type')
  apply (metis While2 le_trans)
  apply (metis le_trans)
  done
(*    apply (meson Seq2' Subsumption min.cobounded1 min.cobounded2)*)

lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
proof (induct rule: sec_type2.induct)
  case Seq2
  thus ?case
    by (meson Seq2' Subsumption2' min.cobounded1 min.cobounded2)

next
  case If2
  thus ?case
    by (metis If2' Subsumption2' min.bounded_iff nat_le_linear)
qed (auto intro: sec_type2'.intros)

(* Exercise 9.7. *)
fun erase :: "level \<Rightarrow> com \<Rightarrow> com" where
  "erase l (SKIP) = SKIP"
  |"erase l (x ::= a) = (if (sec x \<ge> l) then SKIP else x ::= a)"
  | "erase l (Seq com1 com2) = Seq (erase l com1) (erase l com2)"
  | "erase l (If bexp com1 com2) = (if (sec bexp \<ge> l) then SKIP else (If bexp (erase l com1) (erase l com2)))"
  |"erase l (While  bexp com) = (if sec bexp \<ge> l then SKIP else (While bexp (erase l com)))"

lemma aval_eq_if_eq_less: "\<lbrakk> s1 = s2 (< l);  sec a < l \<rbrakk> \<Longrightarrow> aval a s1 = aval a s2"
  by (induct a) auto

lemma bval_eq_if_eq_less: "\<lbrakk> s1 = s2 (< l);  sec b < l \<rbrakk> \<Longrightarrow> bval b s1 = bval b s2"
  by (induct b) (auto simp add: aval_eq_if_eq_less)

theorem erase_correct:"\<lbrakk>(c, s) \<Rightarrow> s'; (erase l c, t) \<Rightarrow> t'; 0 \<turnstile> c; s = t (< l)\<rbrakk>
       \<Longrightarrow> s' = t' (< l)"
proof(induction arbitrary: t t' rule: big_step_induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  then show ?case by (cases "sec x < l") (auto intro!: aval_eq_if_eq_less)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by fastforce
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  have Hsecc:"sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  show ?case
  proof cases
(*
      assume "sec b \<le> l"
      then have "s = t (\<le> sec b)"
        using IfTrue.prems(3) \<open>sec b \<le> l\<close> by auto
      hence "bval b t"
        using IfTrue.hyps(1) bval_eq_if_eq_le by blast
      with IfTrue.IH IfTrue.prems(1,3) \<open>sec b \<turnstile> c\<^sub>1\<close> anti_mono
      show ?thesis by (auto)
*)
      assume "sec b < l"
      then have "s = t (< sec b)"
        using IfTrue.prems(3) by auto
      hence H1: "bval b t"
        using IfTrue.hyps(1) IfTrue.prems(3) \<open>sec b < l\<close> bval_eq_if_eq_less by blast
      from IfTrue(3, 5) Hsecc(1) obtain t' where H2: "(erase l c\<^sub>1, t) \<Rightarrow> t'" "s' = t' (< l)"
        by (smt IfE IfTrue.prems(1) IfTrue.prems(3) \<open>bval b t\<close> \<open>sec b < l\<close> anti_mono erase.simps(4) le0 leD)
      from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
      with H2(2) show ?thesis
        using IfTrue.prems(1) \<open>sec b < l\<close> big_step_determ by fastforce
    next
      assume "\<not> sec b < l"
      have "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
        by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
      then have "t = t' (< l)"
        using IfTrue.prems(1) \<open>\<not> sec b < l\<close> confinement by auto
      then show ?thesis
        using IfTrue.hyps(2) IfTrue.prems(3) \<open>\<not> sec b < l\<close> \<open>sec b \<turnstile> c\<^sub>1\<close> confinement by fastforce
    qed
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  have Hsecc: "sec b \<turnstile> c\<^sub>1" "sec b \<turnstile> c\<^sub>2" using \<open>0 \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2\<close> by auto
  show ?case
  proof cases
      assume "sec b < l"
      then have "s = t (< sec b)"
        using IfFalse.prems(3) dual_order.strict_trans by blast
      hence H1: "\<not>bval b t"
        using IfFalse.hyps(1) IfFalse.prems(3) \<open>sec b < l\<close> bval_eq_if_eq_less by blast
      from IfFalse(3, 5) Hsecc(1) obtain t' where H2: "(erase l c\<^sub>2, t) \<Rightarrow> t'" "s' = t' (< l)"
        by (smt H1 Hsecc(2) IfE IfFalse.prems(1) IfFalse.prems(3) \<open>sec b < l\<close> anti_mono erase.simps(4) le0 leD)
      from H1 H2(1) have "((IF b THEN erase l c\<^sub>1 ELSE erase l c\<^sub>2), t) \<Rightarrow> t'" by auto
      with H2(2) show ?thesis
        using IfFalse.prems(1) \<open>sec b < l\<close> big_step_determ by fastforce
    next
      assume "\<not> sec b < l"
      have "sec b \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"
        by (simp add: If \<open>sec b \<turnstile> c\<^sub>1\<close> \<open>sec b \<turnstile> c\<^sub>2\<close>)
      then have "t = t' (< l)"
        using IfFalse.prems(1) \<open>\<not> sec b < l\<close> confinement by auto
      then show ?thesis
        using IfFalse.hyps(2) IfFalse.prems(3) \<open>\<not> sec b < l\<close> \<open>sec b \<turnstile> c\<^sub>2\<close> confinement by fastforce
    qed
next
  case (WhileFalse b s c)
  then show ?case by (cases "sec b < l") (auto simp add: bval_eq_if_eq_less)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  have Hsecc: "sec b \<turnstile> c"
    using WhileTrue.prems(2) by force
  show ?case
  proof (cases "sec b < l")
    case True
    with WhileTrue(1, 8) have "bval b t" by (auto simp add: bval_eq_if_eq_less)
    with True WhileTrue(6) obtain ti where H: "(erase l c, t) \<Rightarrow> ti" "(WHILE b DO erase l c, ti) \<Rightarrow>t'" by auto
    from this(1) Hsecc WhileTrue(8) have "s\<^sub>2 = ti (< l)"
      using WhileTrue.IH(1) anti_mono by blast
    with True H(2) WhileTrue(7) show ?thesis by (intro WhileTrue(5)) auto
  next
    case False
    with WhileTrue(2) Hsecc have H1: "s\<^sub>1 = s\<^sub>2 (< l)" by (auto dest: confinement)
    from False Hsecc have "l \<turnstile> WHILE b DO c" by (intro anti_mono [of "sec b" _ l]) (auto intro: sec_type.intros)
    with WhileTrue(4) have H2: "s\<^sub>2 = s\<^sub>3 (< l)"
      using WhileTrue.hyps(3) confinement by auto
    with WhileTrue(8) H1 H2 show ?thesis
      using False WhileTrue.prems(1) by auto
  qed
  qed

text \<open>
In the theorem above we assumed that both @{term"(c,s)"}
and @{term "(erase l c,t)"} terminate. How about the following two properties:
\<close>
lemma "\<lbrakk> (c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
  \<Longrightarrow> \<exists>t'. (erase l c,t) \<Rightarrow> t' \<and> s' = t' (< l)"
  oops
lemma "\<lbrakk> (erase l c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk> \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t'"
  oops
text \<open>Give an informal justification or a counterexample for each property!\<close>

end