(*  File:       Maximum_Parallel_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Maximum Parallel Composition\<close>

theory Maximum_Parallel_Composition
  imports "Basic_Modules/Component_Types/Maximum_Aggregator"
          Parallel_Composition
begin

text
\<open>This is a family of parallel compositions. It composes a new electoral module
from two electoral modules combined with the maximum aggregator. Therein, the
two modules each make a decision and then a partition is returned where every
alternative receives the maximum result of the two input partitions. This means
that, if any alternative is elected by at least one of the modules, then it
gets elected, if any non-elected alternative is deferred by at least one of the
modules, then it gets deferred, only alternatives rejected by both modules get
rejected.\<close>

subsection \<open>Definition\<close>

fun maximum_parallel_composition :: "'a Electoral_Module \<Rightarrow>
        'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "maximum_parallel_composition m n =
    (let a = max_aggregator in (m \<parallel>\<^sub>a n))"

abbreviation max_parallel :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
        'a Electoral_Module" (infix "\<parallel>\<^sub>\<up>" 50) where
  "m \<parallel>\<^sub>\<up> n == maximum_parallel_composition m n"

subsection \<open>Soundness\<close>

theorem max_par_comp_sound:
  assumes
    mod_m: "electoral_module m" and
    mod_n: "electoral_module n"
  shows "electoral_module (m \<parallel>\<^sub>\<up> n)"
  using mod_m mod_n
  by simp

subsection \<open>Lemmata\<close>

lemma max_agg_eq_result:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    in_A: "x \<in> A"
  shows
    "mod_contains_result (m \<parallel>\<^sub>\<up> n) m A p x \<or>
      mod_contains_result (m \<parallel>\<^sub>\<up> n) n A p x"
proof cases
  assume a1: "x \<in> elect (m \<parallel>\<^sub>\<up> n) A p"
    have mod_contains_inst:
      "\<forall>p_mod q_mod a_set prof a.
        mod_contains_result p_mod q_mod a_set prof (a::'a) =
          (electoral_module p_mod \<and> electoral_module q_mod \<and>
            finite a_set \<and> profile a_set prof \<and> a \<in> a_set \<and>
            (a \<notin> elect p_mod a_set prof \<or> a \<in> elect q_mod a_set prof) \<and>
            (a \<notin> reject p_mod a_set prof \<or> a \<in> reject q_mod a_set prof) \<and>
            (a \<notin> defer p_mod a_set prof \<or> a \<in> defer q_mod a_set prof))"
      by (simp add: mod_contains_result_def)
  have module_mn: "electoral_module (m \<parallel>\<^sub>\<up> n)"
    by (simp add: module_m module_n)
  have not_defer_mn: "x \<notin> defer (m \<parallel>\<^sub>\<up> n) A p"
    using module_mn IntI a1 empty_iff f_prof result_disj
    by (metis (no_types))
  have not_reject_mn: "x \<notin> reject (m \<parallel>\<^sub>\<up> n) A p"
    using module_mn IntI a1 empty_iff f_prof result_disj
    by (metis (no_types))
  from a1 have
    "let (e1, r1, d1) = m A p;
        (e2, r2, d2) = n A p in
      x \<in> e1 \<union> e2"
    by auto
  hence union_mn: "x \<in> (elect m A p) \<union> (elect n A p)"
    by auto
  thus ?thesis
    using f_prof in_A module_m module_mn module_n
          not_defer_mn not_reject_mn union_mn
          mod_contains_inst
      by blast
next
  assume not_a1: "x \<notin> elect (m \<parallel>\<^sub>\<up> n) A p"
  thus ?thesis
  proof cases
    assume x_in_def: "x \<in> defer (m \<parallel>\<^sub>\<up> n) A p"
    thus ?thesis
    proof (safe)
      assume not_mod_cont_mn:
        "\<not> mod_contains_result (m \<parallel>\<^sub>\<up> n) n A p x"
      have par_emod:
        "\<forall>f g.
          (electoral_module (f::'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) \<and>
            electoral_module g) \<longrightarrow>
              electoral_module (f \<parallel>\<^sub>\<up> g)"
        using max_par_comp_sound
        by blast
      hence "electoral_module (m \<parallel>\<^sub>\<up> n)"
        using module_m module_n
        by blast
      hence max_par_emod:
        "electoral_module (m \<parallel>\<^sub>max_aggregator n)"
        by simp
      have set_intersect:
        "\<forall>(a::'a) A B. (a \<in> A \<inter> B) = (a \<in> A \<and> a \<in> B)"
        by blast
      obtain
        s_func :: "('a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) \<Rightarrow> 'a set" and
        p_func :: "('a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) \<Rightarrow> 'a Profile" where
        well_f:
        "\<forall>f.
          (\<not> electoral_module f \<or>
            (\<forall>A prof. (finite A \<and> profile A prof) \<longrightarrow> well_formed A (f A prof))) \<and>
          (electoral_module f \<or> finite (s_func f) \<and> profile (s_func f) (p_func f) \<and>
            \<not> well_formed (s_func f) (f (s_func f) (p_func f)))"
        using electoral_module_def
        by moura
      hence wf_n: "well_formed A (n A p)"
        using f_prof module_n
        by blast
      have wf_m: "well_formed A (m A p)"
        using well_f f_prof module_m
        by blast
      have a_exists: "\<forall>(a::'a). a \<notin> {}"
        by blast
      have e_mod_par:
        "electoral_module (m \<parallel>\<^sub>\<up> n)"
        using par_emod module_m module_n
        by blast
      hence "electoral_module (m \<parallel>\<^sub>max_aggregator n)"
        by simp
      hence result_disj_max:
        "elect (m \<parallel>\<^sub>max_aggregator n) A p \<inter> reject (m \<parallel>\<^sub>max_aggregator n) A p = {} \<and>
          elect (m \<parallel>\<^sub>max_aggregator n) A p \<inter> defer (m \<parallel>\<^sub>max_aggregator n) A p = {} \<and>
          reject (m \<parallel>\<^sub>max_aggregator n) A p \<inter> defer (m \<parallel>\<^sub>max_aggregator n) A p = {}"
        using f_prof result_disj
        by metis
      have x_not_elect:
        "x \<notin> elect (m \<parallel>\<^sub>max_aggregator n) A p"
        using result_disj_max x_in_def
        by force
      have result_m:
        "(elect m A p, reject m A p, defer m A p) = m A p"
        by auto
      have result_n:
        "(elect n A p, reject n A p, defer n A p) = n A p"
        by auto
      have max_pq:
        "\<forall>(A::'a set) p q.
          elect_r (max_aggregator A p q) = elect_r p \<union> elect_r q"
        by force
      have
        "x \<notin> elect (m \<parallel>\<^sub>max_aggregator n) A p"
        using x_not_elect
        by blast
      with max_pq
      have "x \<notin> elect m A p \<union> elect n A p"
        by (simp add: max_pq)
      hence x_not_elect_mn:
        "x \<notin> elect m A p \<and> x \<notin> elect n A p"
        by blast
      have x_not_mpar_rej:
        "x \<notin> reject (m \<parallel>\<^sub>max_aggregator n) A p"
        using result_disj_max x_in_def
        by fastforce
      hence x_not_par_rej:
        "x \<notin> reject (m \<parallel>\<^sub>\<up> n) A p"
        by auto
      have mod_cont_res_fg:
        "\<forall>f g A prof (a::'a).
          mod_contains_result f g A prof a =
            (electoral_module f \<and> electoral_module g \<and>
              finite A \<and> profile A prof \<and> a \<in> A \<and>
                (a \<notin> elect f A prof \<or> a \<in> elect g A prof) \<and>
                (a \<notin> reject f A prof \<or> a \<in> reject g A prof) \<and>
                (a \<notin> defer f A prof \<or> a \<in> defer g A prof))"
        by (simp add: mod_contains_result_def)
      have max_agg_res:
        "max_aggregator A (elect m A p, reject m A p, defer m A p)
          (elect n A p, reject n A p, defer n A p) = (m \<parallel>\<^sub>max_aggregator n) A p"
        by simp
      have well_f_max:
        "\<forall>r2 r1 e2 e1 d2 d1 A.
          well_formed A (e1, r1, d1) \<and> well_formed A (e2, r2, d2) \<longrightarrow>
            reject_r (max_aggregator A (e1, r1, d1) (e2, r2, d2)) = r1 \<inter> r2"
        using max_agg_rej_set
        by metis
      have e_mod_disj:
        "\<forall>f (A::'a set) prof.
          (electoral_module f \<and> finite (A::'a set) \<and> profile A prof) \<longrightarrow>
            elect f A prof \<union> reject f A prof \<union> defer f A prof = A"
        using result_presv_alts
        by blast
      hence e_mod_disj_n:
        "elect n A p \<union> reject n A p \<union> defer n A p = A"
        using f_prof module_n
        by metis
      have
        "\<forall>f g A prof (a::'a).
          mod_contains_result f g A prof a =
            (electoral_module f \<and> electoral_module g \<and>
              finite A \<and> profile A prof \<and> a \<in> A \<and>
              (a \<notin> elect f A prof \<or> a \<in> elect g A prof) \<and>
              (a \<notin> reject f A prof \<or> a \<in> reject g A prof) \<and>
              (a \<notin> defer f A prof \<or> a \<in> defer g A prof))"
        by (simp add: mod_contains_result_def)
      with e_mod_disj_n
      have "x \<in> reject n A p"
        using e_mod_par f_prof in_A module_n not_mod_cont_mn
              x_not_elect x_not_elect_mn x_not_mpar_rej
        by auto
      hence "x \<notin> reject m A p"
        using well_f_max max_agg_res result_m result_n
              set_intersect wf_m wf_n x_not_mpar_rej
        by (metis (no_types))
      with max_agg_res
      have
        "x \<notin> defer (m \<parallel>\<^sub>\<up> n) A p \<or> x \<in> defer m A p"
          using e_mod_disj f_prof in_A module_m x_not_elect_mn
          by blast
      with x_not_mpar_rej
      show "mod_contains_result (m \<parallel>\<^sub>\<up> n) m A p x"
        using mod_cont_res_fg x_not_par_rej e_mod_par f_prof
              in_A module_m x_not_elect
        by auto
    qed
  next
    assume not_a2: "x \<notin> defer (m \<parallel>\<^sub>\<up> n) A p"
    have el_rej_defer:
      "(elect m A p, reject m A p, defer m A p) = m A p"
      by auto
    from not_a1 not_a2 have a3:
      "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p"
      using electoral_mod_defer_elem in_A module_m module_n
            f_prof max_par_comp_sound
      by metis
    hence
      "case snd (m A p) of (Aa, Ab) \<Rightarrow>
        case n A p of (Ac, Ad, Ae) \<Rightarrow>
          x \<in> reject_r
            (max_aggregator A
              (elect m A p, Aa, Ab) (Ac, Ad, Ae))"
      using el_rej_defer
      by force
    hence
      "let (e1, r1, d1) = m A p;
          (e2, r2, d2) = n A p in
        x \<in> fst (snd (max_aggregator A
          (e1, r1, d1) (e2, r2, d2)))"
      by (simp add: case_prod_unfold)
    hence
      "let (e1, r1, d1) = m A p;
          (e2, r2, d2) = n A p in
        x \<in> A - (e1 \<union> e2 \<union> d1 \<union> d2)"
      by simp
    hence
      "x \<notin> elect m A p \<union> (defer n A p \<union> defer m A p)"
      by force
    thus ?thesis
      using mod_contains_result_comm mod_contains_result_def Un_iff
            a3 f_prof in_A module_m module_n max_par_comp_sound
      by (metis (no_types))
  qed
qed

lemma max_agg_rej_iff_both_reject:
  assumes
    f_prof: "finite_profile A p" and
    module_m: "electoral_module m" and
    module_n: "electoral_module n"
  shows
    "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p \<longleftrightarrow>
      (x \<in> reject m A p \<and> x \<in> reject n A p)"
proof
  assume a: "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p"
  hence
    "case n A p of (Aa, Ab, Ac) \<Rightarrow>
      x \<in> reject_r (max_aggregator A
        (elect m A p, reject m A p, defer m A p) (Aa, Ab, Ac))"
    by auto
  hence
    "case snd (m A p) of (Aa, Ab) \<Rightarrow>
      case n A p of (Ac, Ad, Ae) \<Rightarrow>
        x \<in> reject_r (max_aggregator A
          (elect m A p, Aa, Ab) (Ac, Ad, Ae))"
    by force
  with a have
    "let (e1, r1, d1) = m A p;
          (e2, r2, d2) = n A p in
      x \<in> fst (snd (max_aggregator A (e1, r1, d1) (e2, r2, d2)))"
    by (simp add: prod.case_eq_if)
  hence
    "let (e1, r1, d1) = m A p;
        (e2, r2, d2) = n A p in
      x \<in> A - (e1 \<union> e2 \<union> d1 \<union> d2)"
    by simp
  hence
    "x \<in> A - (elect m A p \<union> elect n A p \<union> defer m A p \<union> defer n A p)"
    by auto
  thus "x \<in> reject m A p \<and> x \<in> reject n A p"
    using Diff_iff Un_iff electoral_mod_defer_elem
          f_prof module_m module_n
    by metis
next
  assume a: "x \<in> reject m A p \<and> x \<in> reject n A p"
  hence
    "x \<notin> elect m A p \<and> x \<notin> defer m A p \<and>
      x \<notin> elect n A p \<and> x \<notin> defer n A p"
    using IntI empty_iff module_m module_n f_prof result_disj
    by metis
  thus "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p"
    using DiffD1 a f_prof max_agg_eq_result module_m module_n
          mod_contains_result_comm mod_contains_result_def
          reject_not_elec_or_def
      by (metis (no_types))
qed

lemma max_agg_rej1:
  assumes
    f_prof: "finite_profile A p" and
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    rejected: "x \<in> reject n A p"
  shows
    "mod_contains_result m (m \<parallel>\<^sub>\<up> n) A p x"
  unfolding mod_contains_result_def
proof (safe)
  show "electoral_module m"
    using module_m
    by simp
next
  show "electoral_module (m \<parallel>\<^sub>\<up> n)"
    using module_m module_n
    by simp
next
  show "finite A"
    using f_prof
    by simp
next
  show "profile A p"
    using f_prof
    by simp
next
  show "x \<in> A"
    using f_prof module_n reject_in_alts rejected
    by auto
next
  assume
    x_in_elect: "x \<in> elect m A p"
  hence x_not_reject:
    "x \<notin> reject m A p"
    using disjoint_iff_not_equal f_prof module_m result_disj
    by metis
  have rej_in_A:
    "reject n A p \<subseteq> A"
    using f_prof module_n
    by (simp add: reject_in_alts)
  have x_in_A: "x \<in> A"
    using rej_in_A in_mono rejected
    by metis
  with x_in_elect x_not_reject
  show "x \<in> elect (m \<parallel>\<^sub>\<up> n) A p"
    using f_prof max_agg_eq_result module_m module_n rejected
          max_agg_rej_iff_both_reject mod_contains_result_comm
          mod_contains_result_def
      by metis
next
  assume "x \<in> reject m A p"
  hence
    "x \<in> reject m A p \<and> x \<in> reject n A p"
    using rejected
    by simp
  thus "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p"
    using f_prof max_agg_rej_iff_both_reject module_m module_n
    by (metis (no_types))
next
  assume x_in_defer: "x \<in> defer m A p"
  hence defer_a:
    "\<exists>a. a \<in> defer m A p \<and> x = a"
    by simp
  then obtain x_inst :: 'a where
    inst_x: "x = x_inst \<and> x_inst \<in> defer m A p"
    by metis
  hence x_not_rej:
    "x \<notin> reject m A p"
    using disjoint_iff_not_equal f_prof inst_x module_m result_disj
    by (metis (no_types))
  have
    "\<forall>f A prof.
      (electoral_module f \<and> finite (A::'a set) \<and> profile A prof) \<longrightarrow>
        elect f A prof \<union> reject f A prof \<union> defer f A prof = A"
    using result_presv_alts
    by metis
  with x_in_defer
  have "x \<in> A"
    using f_prof module_m
    by blast
  with inst_x x_not_rej
  show "x \<in> defer (m \<parallel>\<^sub>\<up> n) A p"
    using f_prof max_agg_eq_result
          max_agg_rej_iff_both_reject
          mod_contains_result_comm
          mod_contains_result_def
          module_m module_n rejected
    by metis
qed

lemma max_agg_rej2:
  assumes
    f_prof: "finite_profile A p" and
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    rejected: "x \<in> reject n A p"
  shows
    "mod_contains_result (m \<parallel>\<^sub>\<up> n) m A p x"
  using mod_contains_result_comm max_agg_rej1
        module_m module_n f_prof rejected
  by metis

lemma max_agg_rej3:
  assumes
    f_prof:  "finite_profile A p" and
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    rejected: "x \<in> reject m A p"
  shows
    "mod_contains_result n (m \<parallel>\<^sub>\<up> n) A p x"
  unfolding mod_contains_result_def
proof (safe)
  show "electoral_module n"
    using module_n
    by simp
next
  show "electoral_module (m \<parallel>\<^sub>\<up> n)"
    using module_m module_n
    by simp
next
  show "finite A"
    using f_prof
    by simp
next
  show "profile A p"
    using f_prof
    by simp
next
  show "x \<in> A"
    using f_prof in_mono module_m reject_in_alts rejected
    by (metis (no_types))
next
  assume "x \<in> elect n A p"
  thus "x \<in> elect (m \<parallel>\<^sub>\<up> n) A p"
    using Un_iff combine_ele_rej_def fst_conv
          maximum_parallel_composition.simps
          max_aggregator.simps
          parallel_composition.simps
    by (metis (mono_tags, lifting))
next
  assume "x \<in> reject n A p"
  thus "x \<in> reject (m \<parallel>\<^sub>\<up> n) A p"
    using f_prof max_agg_rej_iff_both_reject module_m module_n rejected
    by metis
next
  assume x_in_def: "x \<in> defer n A p"
  have "x \<in> A"
    using f_prof max_agg_rej1 mod_contains_result_def module_m rejected
    by metis
  thus "x \<in> defer (m \<parallel>\<^sub>\<up> n) A p"
    using x_in_def disjoint_iff_not_equal f_prof
          max_agg_eq_result max_agg_rej_iff_both_reject
          mod_contains_result_comm mod_contains_result_def
          module_m module_n rejected result_disj
      by metis
qed

lemma max_agg_rej4:
  assumes
    f_prof: "finite_profile A p" and
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    rejected: "x \<in> reject m A p"
  shows
    "mod_contains_result (m \<parallel>\<^sub>\<up> n) n A p x"
  using mod_contains_result_comm max_agg_rej3
        module_m module_n f_prof rejected
  by metis

lemma max_agg_rej_intersect:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p"
  shows
    "reject (m \<parallel>\<^sub>\<up> n) A p =
      (reject m A p) \<inter> (reject n A p)"
proof -
  have
    "A = (elect m A p) \<union> (reject m A p) \<union> (defer m A p) \<and>
      A = (elect n A p) \<union> (reject n A p) \<union> (defer n A p)"
    by (simp add: module_m module_n f_prof result_presv_alts)
  hence
    "A - ((elect m A p) \<union> (defer m A p)) = (reject m A p) \<and>
      A - ((elect n A p) \<union> (defer n A p)) = (reject n A p)"
    using module_m module_n f_prof reject_not_elec_or_def
    by auto
  hence
    "A - ((elect m A p) \<union> (elect n A p) \<union> (defer m A p) \<union> (defer n A p)) =
      (reject m A p) \<inter> (reject n A p)"
    by blast
  hence
    "let (e1, r1, d1) = m A p;
        (e2, r2, d2) = n A p in
      A - (e1 \<union> e2 \<union> d1 \<union> d2) = r1 \<inter> r2"
    by fastforce
  thus ?thesis
    by auto
qed

lemma dcompat_dec_by_one_mod:
  assumes
    compatible: "disjoint_compatibility m n" and
    in_A: "x \<in> A"
  shows
    "(\<forall>p. finite_profile A p \<longrightarrow>
          mod_contains_result m (m \<parallel>\<^sub>\<up> n) A p x) \<or>
        (\<forall>p. finite_profile A p \<longrightarrow>
          mod_contains_result n (m \<parallel>\<^sub>\<up> n) A p x)"
  using DiffI compatible disjoint_compatibility_def
        in_A max_agg_rej1 max_agg_rej3
  by metis

subsection \<open>Composition Rules\<close>

(*
   Using a conservative aggregator, the parallel composition
   preserves the property non-electing.
*)
theorem conserv_max_agg_presv_non_electing[simp]:
  assumes
    non_electing_m: "non_electing m" and
    non_electing_n: "non_electing n"
  shows "non_electing (m \<parallel>\<^sub>\<up> n)"
  using non_electing_m non_electing_n
  by simp

(*
   Using the max aggregator, composing two compatible
   electoral modules in parallel preserves defer-lift-invariance.
*)
theorem par_comp_def_lift_inv[simp]:
  assumes
    compatible: "disjoint_compatibility m n" and
    monotone_m: "defer_lift_invariance m" and
    monotone_n: "defer_lift_invariance n"
  shows "defer_lift_invariance (m \<parallel>\<^sub>\<up> n)"
  unfolding defer_lift_invariance_def
proof (safe)
  have electoral_mod_m: "electoral_module m"
    using monotone_m
    by (simp add: defer_lift_invariance_def)
  have electoral_mod_n: "electoral_module n"
    using monotone_n
    by (simp add: defer_lift_invariance_def)
  show "electoral_module (m \<parallel>\<^sub>\<up> n)"
    using electoral_mod_m electoral_mod_n
    by simp
next
  fix
    S :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    x :: "'a"
  assume
    defer_x: "x \<in> defer (m \<parallel>\<^sub>\<up> n) S p" and
    lifted_x: "Profile.lifted S p q x"
  hence f_profs: "finite_profile S p \<and> finite_profile S q"
    by (simp add: lifted_def)
  from compatible
  obtain A::"'a set" where A:
    "A \<subseteq> S \<and> (\<forall>x \<in> A. indep_of_alt m S x \<and>
      (\<forall>p. finite_profile S p \<longrightarrow> x \<in> reject m S p)) \<and>
        (\<forall>x \<in> S-A. indep_of_alt n S x \<and>
      (\<forall>p. finite_profile S p \<longrightarrow> x \<in> reject n S p))"
    using disjoint_compatibility_def f_profs
    by (metis (no_types, lifting))
  have
    "\<forall>x \<in> S. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
  proof cases
    assume a0: "x \<in> A"
    hence "x \<in> reject m S p"
      using A f_profs
      by blast
    with defer_x
    have defer_n: "x \<in> defer n S p"
      using compatible disjoint_compatibility_def
            mod_contains_result_def f_profs max_agg_rej4
      by metis
    have
      "\<forall>x \<in> A. mod_contains_result (m \<parallel>\<^sub>\<up> n) n S p x"
      using A compatible disjoint_compatibility_def
            max_agg_rej4 f_profs
      by metis
    moreover have "\<forall>x \<in> S. prof_contains_result n S p q x"
      unfolding prof_contains_result_def
    proof (clarify)
      fix x :: "'a"
      assume
        x_in_S: "x \<in> S"
      show
        "electoral_module n \<and>
         finite_profile S p \<and>
         finite_profile S q \<and>
         x \<in> S \<and>
         (x \<in> elect n S p \<longrightarrow> x \<in> elect n S q) \<and>
         (x \<in> reject n S p \<longrightarrow> x \<in> reject n S q) \<and>
         (x \<in> defer n S p \<longrightarrow> x \<in> defer n S q)"
      proof (safe)
        show "electoral_module n"
          using monotone_n defer_lift_invariance_def
          by metis
      next
        show "finite S"
          using f_profs
          by simp
      next
        show "profile S p"
          using f_profs
          by simp
      next
        show "finite S"
          using f_profs
          by simp
      next
        show "profile S q"
          using f_profs
          by simp
      next
        show "x \<in> S"
          using x_in_S
          by simp
      next
        assume "x \<in> elect n S p"
        thus "x \<in> elect n S q"
          using defer_n lifted_x monotone_n
                f_profs defer_lift_invariance_def
          by metis
      next
        assume "x \<in> reject n S p"
        thus "x \<in> reject n S q"
          using defer_n lifted_x monotone_n
                f_profs defer_lift_invariance_def
          by metis
      next
        assume "x \<in> defer n S p"
        thus "x \<in> defer n S q"
          using defer_n lifted_x monotone_n
                f_profs defer_lift_invariance_def
          by metis
      qed
    qed
    moreover have
      "\<forall>x \<in> A. mod_contains_result n (m \<parallel>\<^sub>\<up> n) S q x"
      using A compatible disjoint_compatibility_def
            max_agg_rej3 f_profs
      by metis
    ultimately have 00:
      "\<forall>x \<in> A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
      by (simp add: mod_contains_result_def prof_contains_result_def)
    have
      "\<forall>x \<in> S-A. mod_contains_result (m \<parallel>\<^sub>\<up> n) m S p x"
      using A max_agg_rej2 monotone_m monotone_n f_profs
            defer_lift_invariance_def
      by metis
    moreover have "\<forall>x \<in> S. prof_contains_result m S p q x"
      unfolding prof_contains_result_def
    proof (clarify)
      fix x :: "'a"
      assume
        x_in_S: "x \<in> S"
      show
        "electoral_module m \<and>
         finite_profile S p \<and>
         finite_profile S q \<and>
         x \<in> S \<and>
         (x \<in> elect m S p \<longrightarrow> x \<in> elect m S q) \<and>
         (x \<in> reject m S p \<longrightarrow> x \<in> reject m S q) \<and>
         (x \<in> defer m S p \<longrightarrow> x \<in> defer m S q)"
      proof (safe)
        show "electoral_module m"
          using monotone_m defer_lift_invariance_def
          by metis
      next
        show "finite S"
          using f_profs
          by simp
      next
        show "profile S p"
          using f_profs
          by simp
      next
        show "finite S"
          using f_profs
          by simp
      next
        show "profile S q"
          using f_profs
          by simp
      next
        show "x \<in> S"
          using x_in_S
          by simp
      next
        assume "x \<in> elect m S p"
        thus "x \<in> elect m S q"
          using A a0 indep_of_alt_def lifted_x
                lifted_imp_equiv_prof_except_a
          by metis
      next
        assume "x \<in> reject m S p"
        thus "x \<in> reject m S q"
          using A a0 indep_of_alt_def lifted_x
                lifted_imp_equiv_prof_except_a
          by metis
      next
        assume "x \<in> defer m S p"
        thus "x \<in> defer m S q"
          using A a0 indep_of_alt_def lifted_x
                lifted_imp_equiv_prof_except_a
          by metis
      qed
    qed
    moreover have
      "\<forall>x \<in> S-A. mod_contains_result m (m \<parallel>\<^sub>\<up> n) S q x"
      using A max_agg_rej1 monotone_m monotone_n f_profs
            defer_lift_invariance_def
      by metis
    ultimately have 01:
      "\<forall>x \<in> S-A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
      by (simp add: mod_contains_result_def prof_contains_result_def)
    from 00 01
    show ?thesis
      by blast
  next
    assume "x \<notin> A"
    hence a1: "x \<in> S-A"
      using DiffI lifted_x compatible f_profs
            Profile.lifted_def
      by (metis (no_types, lifting))
    hence "x \<in> reject n S p"
      using A f_profs
      by blast
    with defer_x
    have defer_m: "x \<in> defer m S p"
      using DiffD1 DiffD2 compatible dcompat_dec_by_one_mod
            defer_not_elec_or_rej disjoint_compatibility_def
            not_rej_imp_elec_or_def mod_contains_result_def
            max_agg_sound par_comp_sound f_profs
            maximum_parallel_composition.simps
      by metis
    have
      "\<forall>x \<in> A. mod_contains_result (m \<parallel>\<^sub>\<up> n) n S p x"
      using A compatible disjoint_compatibility_def
            max_agg_rej4 f_profs
      by metis
    moreover have "\<forall>x \<in> S. prof_contains_result n S p q x"
      unfolding prof_contains_result_def
    proof (clarify)
      fix x :: "'a"
        assume
          x_in_S: "x \<in> S"
        show
          "electoral_module n \<and>
           finite_profile S p \<and>
           finite_profile S q \<and>
           x \<in> S \<and>
           (x \<in> elect n S p \<longrightarrow> x \<in> elect n S q) \<and>
           (x \<in> reject n S p \<longrightarrow> x \<in> reject n S q) \<and>
           (x \<in> defer n S p \<longrightarrow> x \<in> defer n S q)"
        proof (safe)
          show "electoral_module n"
            using monotone_n defer_lift_invariance_def
            by metis
        next
          show "finite S"
            using f_profs
            by simp
        next
          show "profile S p"
            using f_profs
            by simp
        next
          show "finite S"
            using f_profs
            by simp
        next
          show "profile S q"
            using f_profs
            by simp
        next
          show "x \<in> S"
            using x_in_S
            by simp
        next
          assume "x \<in> elect n S p"
          thus "x \<in> elect n S q"
            using A a1 indep_of_alt_def lifted_x
                  lifted_imp_equiv_prof_except_a
            by metis
        next
          assume "x \<in> reject n S p"
          thus "x \<in> reject n S q"
            using A a1 indep_of_alt_def lifted_x
                  lifted_imp_equiv_prof_except_a
            by metis
        next
          assume "x \<in> defer n S p"
          thus "x \<in> defer n S q"
            using A a1 indep_of_alt_def lifted_x
                  lifted_imp_equiv_prof_except_a
            by metis
        qed
    qed
    moreover have
      "\<forall>x \<in> A. mod_contains_result n (m \<parallel>\<^sub>\<up> n) S q x"
      using A compatible disjoint_compatibility_def
            max_agg_rej3 f_profs
      by metis
    ultimately have 10:
      "\<forall>x \<in> A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
      by (simp add: mod_contains_result_def prof_contains_result_def)
    have
      "\<forall>x \<in> S-A. mod_contains_result (m \<parallel>\<^sub>\<up> n) m S p x"
      using A max_agg_rej2 monotone_m monotone_n
            f_profs defer_lift_invariance_def
      by metis
    moreover have "\<forall>x \<in> S. prof_contains_result m S p q x"
      unfolding prof_contains_result_def
    proof (clarify)
      fix x :: "'a"
        assume
          x_in_S: "x \<in> S"
        show
          "electoral_module m \<and>
           finite_profile S p \<and>
           finite_profile S q \<and>
           x \<in> S \<and>
           (x \<in> elect m S p \<longrightarrow> x \<in> elect m S q) \<and>
           (x \<in> reject m S p \<longrightarrow> x \<in> reject m S q) \<and>
           (x \<in> defer m S p \<longrightarrow> x \<in> defer m S q)"
        proof (safe)
          show "electoral_module m"
            using monotone_m defer_lift_invariance_def
            by metis
        next
          show "finite S"
            using f_profs
            by simp
        next
          show "profile S p"
            using f_profs
            by simp
        next
          show "finite S"
            using f_profs
            by simp
        next
          show "profile S q"
            using f_profs
            by simp
        next
          show "x \<in> S"
            using x_in_S
            by simp
        next
          assume "x \<in> elect m S p"
          thus "x \<in> elect m S q"
            using defer_lift_invariance_def defer_m
                  lifted_x monotone_m
            by metis
        next
          assume "x \<in> reject m S p"
          thus "x \<in> reject m S q"
            using defer_lift_invariance_def defer_m
                  lifted_x monotone_m
            by metis
        next
          assume "x \<in> defer m S p"
          thus "x \<in> defer m S q"
            using defer_lift_invariance_def defer_m
                  lifted_x monotone_m
            by metis
        qed
    qed
    moreover have
      "\<forall>x \<in> S-A. mod_contains_result m (m \<parallel>\<^sub>\<up> n) S q x"
      using A max_agg_rej1 monotone_m monotone_n
            f_profs defer_lift_invariance_def
      by metis
    ultimately have 11:
      "\<forall>x \<in> S-A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
      using electoral_mod_defer_elem
      by (simp add: mod_contains_result_def prof_contains_result_def)
    from 10 11
    show ?thesis
      by blast
  qed
  thus "(m \<parallel>\<^sub>\<up> n) S p = (m \<parallel>\<^sub>\<up> n) S q"
    using compatible disjoint_compatibility_def f_profs
          eq_alts_in_profs_imp_eq_results max_par_comp_sound
    by metis
qed

lemma par_comp_rej_card:
  assumes
    compatible: "disjoint_compatibility x y" and
    f_prof: "finite_profile S p" and
    reject_sum: "card (reject x S p) + card (reject y S p) = card S + n"
  shows "card (reject (x \<parallel>\<^sub>\<up> y) S p) = n"
proof -
  from compatible obtain A where A:
    "A \<subseteq> S \<and>
      (\<forall>a \<in> A. indep_of_alt x S a \<and>
          (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject x S p)) \<and>
      (\<forall>a \<in> S-A. indep_of_alt y S a \<and>
          (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject y S p))"
    using disjoint_compatibility_def f_prof
    by metis
  from f_prof compatible
  have reject_representation:
    "reject (x \<parallel>\<^sub>\<up> y) S p = (reject x S p) \<inter> (reject y S p)"
    using max_agg_rej_intersect disjoint_compatibility_def
    by blast
  have "electoral_module x \<and> electoral_module y"
    using compatible disjoint_compatibility_def
    by auto
  hence subsets: "(reject x S p) \<subseteq> S \<and> (reject y S p) \<subseteq> S"
    by (simp add: f_prof reject_in_alts)
  hence "finite (reject x S p) \<and> finite (reject y S p)"
    using rev_finite_subset f_prof reject_in_alts
    by auto
  hence 0:
    "card (reject (x \<parallel>\<^sub>\<up> y) S p) =
        card S + n -
          card ((reject x S p) \<union> (reject y S p))"
    using card_Un_Int reject_representation reject_sum
    by fastforce
  have
    "\<forall>a \<in> S. a \<in> (reject x S p) \<or> a \<in> (reject y S p)"
    using A f_prof
    by blast
  hence "S = reject x S p \<union> reject y S p"
    using subsets
    by force
  hence 1: "card ((reject x S p) \<union> (reject y S p)) = card S"
    by presburger
  from 0 1
  show "card (reject (x \<parallel>\<^sub>\<up> y) S p) = n"
    by simp
qed

(*
   Using the max-aggregator for composing two compatible modules in parallel,
   whereof the first one is non-electing and defers exactly one alternative,
   and the second one rejects exactly two alternatives, the composition
   results in an electoral module that eliminates exactly one alternative.
*)
theorem par_comp_elim_one[simp]:
  assumes
    defers_m_1: "defers 1 m" and
    non_elec_m: "non_electing m" and
    rejec_n_2: "rejects 2 n" and
    disj_comp: "disjoint_compatibility m n"
  shows "eliminates 1 (m \<parallel>\<^sub>\<up> n)"
  unfolding eliminates_def
proof (safe)
  have electoral_mod_m: "electoral_module m"
    using non_elec_m
    by (simp add: non_electing_def)
  have electoral_mod_n: "electoral_module n"
    using rejec_n_2
    by (simp add: rejects_def)
  show "electoral_module (m \<parallel>\<^sub>\<up> n)"
    using electoral_mod_m electoral_mod_n
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    min_2_card: "1 < card A" and
    fin_A: "finite A" and
    prof_A: "profile A p"
  have card_geq_1: "card A \<ge> 1"
    using min_2_card dual_order.strict_trans2 less_imp_le_nat
    by blast
  have module: "electoral_module m"
    using non_elec_m non_electing_def
    by auto
  have elec_card_0: "card (elect m A p) = 0"
    using fin_A prof_A non_elec_m card_eq_0_iff non_electing_def
    by metis
  moreover
  from card_geq_1 have def_card_1:
    "card (defer m A p) = 1"
    using defers_m_1 module fin_A prof_A
    by (simp add: defers_def)
  ultimately have card_reject_m:
    "card (reject m A p) = card A - 1"
  proof -
    have "finite A"
      by (simp add: fin_A)
    moreover have
      "well_formed A
        (elect m A p, reject m A p, defer m A p)"
      using fin_A prof_A electoral_module_def module
      by auto
    ultimately have
      "card A =
        card (elect m A p) + card (reject m A p) +
          card (defer m A p)"
      using result_count
      by blast
    thus ?thesis
      using def_card_1 elec_card_0
      by simp
  qed
  have case1: "card A \<ge> 2"
    using min_2_card
    by auto
  from case1 have card_reject_n:
    "card (reject n A p) = 2"
    using fin_A prof_A rejec_n_2 rejects_def
    by blast
  from card_reject_m card_reject_n
  have
    "card (reject m A p) + card (reject n A p) =
      card A + 1"
    using card_geq_1
    by linarith
  with disj_comp prof_A fin_A card_reject_m card_reject_n
  show
    "card (reject (m \<parallel>\<^sub>\<up> n) A p) = 1"
    using par_comp_rej_card
    by blast
qed

end


(*
Title: SIFUM-Type-Systems
Authors: Sylvia Grewe, Heiko Mantel, Daniel Schoepe
*)
section \<open>Language for Instantiating the SIFUM-Security Property\<close>

theory Language
imports Main Preliminaries
begin

subsection \<open>Syntax\<close>

datatype 'var ModeUpd = Acq "'var" Mode (infix "+=\<^sub>m" 75)
  | Rel "'var" Mode (infix "-=\<^sub>m" 75)

datatype ('var, 'aexp, 'bexp) Stmt = Assign "'var" "'aexp" (infix "\<leftarrow>" 130)
  | Skip
  | ModeDecl "('var, 'aexp, 'bexp) Stmt" "'var ModeUpd" ("_@[_]" [0, 0] 150)
  | Seq "('var, 'aexp, 'bexp) Stmt" "('var, 'aexp, 'bexp) Stmt" (infixr ";;" 150)
  | If "'bexp" "('var, 'aexp, 'bexp) Stmt" "('var, 'aexp, 'bexp) Stmt"
  | While "'bexp" "('var, 'aexp, 'bexp) Stmt"
  | Stop

type_synonym ('var, 'aexp, 'bexp) EvalCxt = "('var, 'aexp, 'bexp) Stmt list"

locale sifum_lang =
  fixes eval\<^sub>A :: "('Var, 'Val) Mem \<Rightarrow> 'AExp \<Rightarrow> 'Val"
  fixes eval\<^sub>B :: "('Var, 'Val) Mem \<Rightarrow> 'BExp \<Rightarrow> bool"
  fixes aexp_vars :: "'AExp \<Rightarrow> 'Var set"
  fixes bexp_vars :: "'BExp \<Rightarrow> 'Var set"
  fixes dma :: "'Var \<Rightarrow> Sec"
  assumes Var_finite : "finite {(x :: 'Var). True}"
  assumes eval_vars_det\<^sub>A : "\<lbrakk> \<forall> x \<in> aexp_vars e. mem\<^sub>1 x = mem\<^sub>2 x \<rbrakk> \<Longrightarrow> eval\<^sub>A mem\<^sub>1 e = eval\<^sub>A mem\<^sub>2 e"
  assumes eval_vars_det\<^sub>B : "\<lbrakk> \<forall> x \<in> bexp_vars b. mem\<^sub>1 x = mem\<^sub>2 x \<rbrakk> \<Longrightarrow> eval\<^sub>B mem\<^sub>1 b = eval\<^sub>B mem\<^sub>2 b"

context sifum_lang
begin

(* To make the examples look a bit nicer in the PDF. *)

notation (latex output)
  Seq ("_; _" 60)

notation (Rule output)
  Seq ("_ ; _" 60)

notation (Rule output)
  If ("if _ then _ else _ fi" 50)

notation (Rule output)
  While ("while _ do _ done")

abbreviation conf\<^sub>w_abv :: "('Var, 'AExp, 'BExp) Stmt \<Rightarrow>
  'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_,_,_) LocalConf"
  ("\<langle>_, _, _\<rangle>\<^sub>w" [0, 120, 120] 100)
  where
  "\<langle> c, mds, mem \<rangle>\<^sub>w \<equiv> ((c, mds), mem)"

subsection \<open>Semantics\<close>

primrec update_modes :: "'Var ModeUpd \<Rightarrow> 'Var Mds \<Rightarrow> 'Var Mds"
  where
  "update_modes (Acq x m) mds = mds (m := insert x (mds m))" |
  "update_modes (Rel x m) mds = mds (m := {y. y \<in> mds m \<and> y \<noteq> x})"

fun updated_var :: "'Var ModeUpd \<Rightarrow> 'Var"
  where
  "updated_var (Acq x _) = x" |
  "updated_var (Rel x _) = x"

fun updated_mode :: "'Var ModeUpd \<Rightarrow> Mode"
  where
  "updated_mode (Acq _ m) = m" |
  "updated_mode (Rel _ m) = m"

inductive_set eval\<^sub>w_simple :: "(('Var, 'AExp, 'BExp) Stmt \<times> ('Var, 'Val) Mem) rel"
and eval\<^sub>w_simple_abv :: "(('Var, 'AExp, 'BExp) Stmt \<times> ('Var, 'Val) Mem) \<Rightarrow>
  ('Var, 'AExp, 'BExp) Stmt \<times> ('Var, 'Val) Mem \<Rightarrow> bool"
  (infixr "\<leadsto>\<^sub>s" 60)
  where
  "c \<leadsto>\<^sub>s c' \<equiv> (c, c') \<in> eval\<^sub>w_simple" |
  assign: "((x \<leftarrow> e, mem), (Stop, mem (x := eval\<^sub>A mem e))) \<in> eval\<^sub>w_simple" |
  skip: "((Skip, mem), (Stop, mem)) \<in> eval\<^sub>w_simple" |
  seq_stop: "((Seq Stop c, mem), (c, mem)) \<in> eval\<^sub>w_simple" |
  if_true: "\<lbrakk> eval\<^sub>B mem b \<rbrakk> \<Longrightarrow> ((If b t e, mem), (t, mem)) \<in> eval\<^sub>w_simple" |
  if_false: "\<lbrakk> \<not> eval\<^sub>B mem b \<rbrakk> \<Longrightarrow> ((If b t e, mem), (e, mem)) \<in> eval\<^sub>w_simple" |
  while: "((While b c, mem), (If b (c ;; While b c) Stop, mem)) \<in> eval\<^sub>w_simple"

primrec cxt_to_stmt :: "('Var, 'AExp, 'BExp) EvalCxt \<Rightarrow> ('Var, 'AExp, 'BExp) Stmt
  \<Rightarrow> ('Var, 'AExp, 'BExp) Stmt"
  where
  "cxt_to_stmt [] c = c" |
  "cxt_to_stmt (c # cs) c' = Seq c' (cxt_to_stmt cs c)"

(* Design decision: Add "normal" rule for sequential statements here as well.
  Otherwise, one would have to take care of adding some sort of normalization
  later, so that one doesn't get stuck on expressions of the form (c ;; c') ;; c''.
*)
(* Normalization turned out to be more difficult, as it made the proofs of several
  helpful lemmas below quite difficult. *)

inductive_set eval\<^sub>w :: "(('Var, 'AExp, 'BExp) Stmt, 'Var, 'Val) LocalConf rel"
and eval\<^sub>w_abv :: "(('Var, 'AExp, 'BExp) Stmt, 'Var, 'Val) LocalConf \<Rightarrow>
                  (('Var, 'AExp, 'BExp) Stmt, 'Var, 'Val) LocalConf \<Rightarrow> bool"
  (infixr "\<leadsto>\<^sub>w" 60)
  where
  "c \<leadsto>\<^sub>w c' \<equiv> (c, c') \<in> eval\<^sub>w" |
  unannotated: "\<lbrakk> (c, mem) \<leadsto>\<^sub>s (c', mem') \<rbrakk>
    \<Longrightarrow> (\<langle>cxt_to_stmt E c, mds, mem\<rangle>\<^sub>w, \<langle>cxt_to_stmt E c', mds, mem'\<rangle>\<^sub>w) \<in> eval\<^sub>w" |
  seq: "\<lbrakk> \<langle>c\<^sub>1, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c\<^sub>1', mds', mem'\<rangle>\<^sub>w \<rbrakk> \<Longrightarrow> (\<langle>(c\<^sub>1 ;; c\<^sub>2), mds, mem\<rangle>\<^sub>w, \<langle>(c\<^sub>1' ;; c\<^sub>2), mds', mem'\<rangle>\<^sub>w) \<in> eval\<^sub>w" |
  decl: "\<lbrakk> \<langle>c, update_modes mu mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<rbrakk> \<Longrightarrow>
         (\<langle>cxt_to_stmt E (ModeDecl c mu), mds, mem\<rangle>\<^sub>w, \<langle>cxt_to_stmt E c', mds', mem'\<rangle>\<^sub>w) \<in> eval\<^sub>w"

subsection \<open>Semantic Properties\<close>

text \<open>The following lemmas simplify working with evaluation contexts
  in the soundness proofs for the type system(s).\<close>

inductive_cases eval_elim: "(((c, mds), mem), ((c', mds'), mem')) \<in> eval\<^sub>w"
inductive_cases stop_no_eval' [elim]: "((Stop, mem), (c', mem')) \<in> eval\<^sub>w_simple"
inductive_cases assign_elim' [elim]: "((x \<leftarrow> e, mem), (c', mem')) \<in> eval\<^sub>w_simple"
inductive_cases skip_elim' [elim]: "(Skip, mem) \<leadsto>\<^sub>s (c', mem')"

lemma cxt_inv:
  "\<lbrakk> cxt_to_stmt E c = c' ; \<And> p q. c' \<noteq> Seq p q \<rbrakk> \<Longrightarrow> E = [] \<and> c' = c"
  by (metis cxt_to_stmt.simps(1) cxt_to_stmt.simps(2) neq_Nil_conv)

lemma cxt_inv_assign:
  "\<lbrakk> cxt_to_stmt E c = x \<leftarrow> e \<rbrakk> \<Longrightarrow> c = x \<leftarrow> e \<and> E = []"
  by (metis Stmt.simps(11) cxt_inv)

lemma cxt_inv_skip:
  "\<lbrakk> cxt_to_stmt E c = Skip \<rbrakk> \<Longrightarrow> c = Skip \<and> E = []"
  by (metis Stmt.simps(21) cxt_inv)

lemma cxt_inv_stop:
  "cxt_to_stmt E c = Stop \<Longrightarrow> c = Stop \<and> E = []"
  by (metis Stmt.simps(40) cxt_inv)

lemma cxt_inv_if:
  "cxt_to_stmt E c = If e p q \<Longrightarrow> c = If e p q \<and> E = []"
  by (metis Stmt.simps(37) cxt_inv)

lemma cxt_inv_while:
  "cxt_to_stmt E c = While e p \<Longrightarrow> c = While e p \<and> E = []"
  by (metis Stmt.simps(39) cxt_inv)

lemma skip_elim [elim]:
  "\<langle>Skip, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<Longrightarrow> c' = Stop \<and> mds = mds' \<and> mem = mem'"
  apply (erule eval_elim)
    apply (metis (lifting) cxt_inv_skip cxt_to_stmt.simps(1) skip_elim')
   apply (metis Stmt.simps(20))
  by (metis Stmt.simps(18) cxt_inv_skip)

lemma assign_elim [elim]:
  "\<langle>x \<leftarrow> e, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<Longrightarrow> c' = Stop \<and> mds = mds' \<and> mem' = mem (x := eval\<^sub>A mem e)"
  apply (erule eval_elim)
    apply (rename_tac c c'a E)
    apply (subgoal_tac "c = x \<leftarrow> e \<and> E = []")
     apply auto
      apply (metis cxt_inv_assign)
     apply (metis cxt_inv_assign)
    apply (metis Stmt.simps(8) cxt_inv_assign)
   apply (metis Stmt.simps(8) cxt_inv_assign)
  by (metis Stmt.simps(8) cxt_inv_assign)

inductive_cases if_elim' [elim!]: "(If b p q, mem) \<leadsto>\<^sub>s (c', mem')"

lemma if_elim [elim]:
  "\<And> P.
    \<lbrakk> \<langle>If b p q, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w ;
     \<lbrakk> c' = p; mem' = mem ; mds' = mds ; eval\<^sub>B mem b \<rbrakk> \<Longrightarrow> P ;
     \<lbrakk> c' = q; mem' = mem ; mds' = mds ; \<not> eval\<^sub>B mem b \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (erule eval_elim)
    apply (metis (no_types) cxt_inv_if cxt_to_stmt.simps(1) if_elim')
   apply (metis Stmt.simps(36))
  by (metis Stmt.simps(30) cxt_inv_if)

inductive_cases while_elim' [elim!]: "(While e c, mem) \<leadsto>\<^sub>s (c', mem')"

lemma while_elim [elim]:
  "\<lbrakk> \<langle>While e c, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<rbrakk> \<Longrightarrow> c' = If e (c ;; While e c) Stop \<and> mds' = mds \<and> mem' = mem"
  apply (erule eval_elim)
    apply (metis (no_types) cxt_inv_while cxt_to_stmt.simps(1) while_elim')
   apply (metis Stmt.simps(38))
  by (metis (lifting) Stmt.simps(33) cxt_inv_while)

inductive_cases upd_elim' [elim]: "(c@[upd], mem) \<leadsto>\<^sub>s (c', mem')"

lemma upd_elim [elim]:
  "\<langle>c@[upd], mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<Longrightarrow> \<langle>c, update_modes upd mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w"
  apply (erule eval_elim)
    apply (metis (lifting) Stmt.simps(28) cxt_inv upd_elim')
   apply (metis Stmt.simps(29))
  by (metis (lifting) Stmt.simps(2) Stmt.simps(29) cxt_inv cxt_to_stmt.simps(1))

lemma cxt_seq_elim [elim]:
  "c\<^sub>1 ;; c\<^sub>2 = cxt_to_stmt E c \<Longrightarrow> (E = [] \<and> c = c\<^sub>1 ;; c\<^sub>2) \<or> (\<exists> c' cs. E = c' # cs \<and> c = c\<^sub>1 \<and> c\<^sub>2 = cxt_to_stmt cs c')"
  apply (cases E)
   apply (metis cxt_to_stmt.simps(1))
  by (metis Stmt.simps(3) cxt_to_stmt.simps(2))

inductive_cases seq_elim' [elim]: "(c\<^sub>1 ;; c\<^sub>2, mem) \<leadsto>\<^sub>s (c', mem')"

lemma stop_no_eval: "\<not> (\<langle>Stop, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w)"
  apply auto
  apply (erule eval_elim)
    apply (metis cxt_inv_stop stop_no_eval')
   apply (metis Stmt.simps(41))
  by (metis Stmt.simps(35) cxt_inv_stop)

lemma seq_stop_elim [elim]:
  "\<langle>Stop ;; c, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w \<Longrightarrow> c' = c \<and> mds' = mds \<and> mem' = mem"
  apply (erule eval_elim)
    apply clarify
    apply (metis (no_types) cxt_seq_elim cxt_to_stmt.simps(1) seq_elim' stop_no_eval')
   apply (metis Stmt.inject(3) stop_no_eval)
  by (metis Stmt.distinct(23) Stmt.distinct(29) cxt_seq_elim)

lemma cxt_stmt_seq:
  "c ;; cxt_to_stmt E c' = cxt_to_stmt (c' # E) c"
  by (metis cxt_to_stmt.simps(2))

lemma seq_elim [elim]:
  "\<lbrakk> \<langle>c\<^sub>1 ;; c\<^sub>2, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c', mds', mem'\<rangle>\<^sub>w ; c\<^sub>1 \<noteq> Stop \<rbrakk> \<Longrightarrow>
  (\<exists> c\<^sub>1'. \<langle>c\<^sub>1, mds, mem\<rangle>\<^sub>w \<leadsto>\<^sub>w \<langle>c\<^sub>1', mds', mem'\<rangle>\<^sub>w \<and> c' = c\<^sub>1' ;; c\<^sub>2)"
  apply (erule eval_elim)
    apply clarify
    apply (drule cxt_seq_elim)
    apply (erule disjE)
     apply (metis seq_elim')
    apply auto
   apply (metis cxt_to_stmt.simps(1) eval\<^sub>w.unannotated)
  apply (subgoal_tac "c\<^sub>1 = (c@[mu])")
   apply simp
   apply (drule cxt_seq_elim)
   apply (metis Stmt.distinct(23) cxt_stmt_seq cxt_to_stmt.simps(1) eval\<^sub>w.decl)
  by (metis Stmt.distinct(23) cxt_seq_elim)

lemma stop_cxt: "Stop = cxt_to_stmt E c \<Longrightarrow> c = Stop"
  by (metis Stmt.simps(41) cxt_to_stmt.simps(1) cxt_to_stmt.simps(2) neq_Nil_conv)

end

end


section {* UTP variables *}

theory utp_urel_laws
  imports "../../Isabelle-UTP-Extended/theories/Rel/utp_rel_more"
begin

subsection {* Unrestriction Laws *}
lemma unrest_iuvar [unrest]:
  "out\<alpha> \<sharp> $x"
  by ( rel_auto)

lemma unrest_ouvar [unrest]:
  "in\<alpha> \<sharp> $x\<acute>"
  by (rel_auto)

lemma unrest_semir_undash [unrest]:
  fixes x :: "('a\<Longrightarrow> '\<alpha>)"
  assumes "$x \<sharp> P"
  shows "$x \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_semir_dash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x\<acute> \<sharp> Q"
  shows "$x\<acute> \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_in\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; in\<alpha> \<sharp> (P :: ('\<alpha>, '\<beta>) rel) \<rbrakk> \<Longrightarrow> $x \<sharp> P"
  by (pred_auto)

lemma unrest_out\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; out\<alpha> \<sharp> (P :: ('\<alpha>, '\<beta>) rel) \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (pred_auto)

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma unrest_pre_out\<alpha> [unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def)

lemma unrest_post_in\<alpha> [unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def)

lemma unrest_pre_in_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x \<sharp> \<lceil>p1\<rceil>\<^sub><"
  by (transfer, simp)

lemma unrest_post_out_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x\<acute> \<sharp> \<lceil>p1\<rceil>\<^sub>>"
  by (transfer, simp)

lemma unrest_convr_out\<alpha> [unrest]:
  "in\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> p\<^sup>-"
  by (pred_auto)

lemma unrest_convr_in\<alpha> [unrest]:
  "out\<alpha> \<sharp> p \<Longrightarrow> in\<alpha> \<sharp> p\<^sup>-"
  by (pred_auto)

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_in_rel_var_res_mwb [unrest]:
  "mwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res_mwb [unrest]:
  "mwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

subsection {* Substitution laws *}

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by transfer (rel_auto, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by transfer (rel_auto, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

text {* The following laws support substitution in heterogeneous relations for polymorphically
  types literal expressions. These cannot be supported more generically due to limitations
  in HOL's type system. The laws are presented in a slightly strange way so as to be as
  general as possible. *}

lemma bool_seqr_laws [usubst]:
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (transfer, rel_auto)+

lemma zero_one_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>0/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>1/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>0/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>1/$x\<acute>\<rbrakk>)"
    by (transfer, rel_auto)+

lemma numeral_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>numeral n/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>numeral n/$x\<acute>\<rbrakk>)"
  by (transfer, rel_auto)+

lemma usubst_condr [usubst]:
  "\<sigma> \<dagger> ( P \<triangleleft> b \<triangleright> Q) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> b \<triangleright> \<sigma> \<dagger> Q)"
  unfolding cond_def
  by rel_auto

lemma subst_skip_r [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> II = \<langle>\<lfloor>\<sigma>\<rfloor>\<^sub>s\<rangle>\<^sub>a"
  by (rel_simp, (metis (mono_tags, lifting) prod.sel(1) sndI surjective_pairing)+)

lemma usubst_upd_in_comp [usubst]:
  "\<sigma>(&in\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x \<mapsto>\<^sub>s v)"
  by (pred_auto)

lemma usubst_upd_out_comp [usubst]:
  "\<sigma>(&out\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x\<acute> \<mapsto>\<^sub>s v)"
  by (pred_auto)

lemma subst_lift_upd [usubst]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lceil>\<sigma>(x \<mapsto>\<^sub>s v)\<rceil>\<^sub>s = \<lceil>\<sigma>\<rceil>\<^sub>s($x \<mapsto>\<^sub>s \<lceil>v\<rceil>\<^sub><)"
  by pred_auto

lemma subst_drop_upd [usubst]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lfloor>\<sigma>($x \<mapsto>\<^sub>s v)\<rfloor>\<^sub>s = \<lfloor>\<sigma>\<rfloor>\<^sub>s(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub><)"
  by  (pred_simp)

lemma subst_lift_pre [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>b\<rceil>\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub><"
  by (metis apply_subst_ext fst_vwb_lens in\<alpha>_def)

lemma unrest_usubst_lift_in [unrest]:
  "x \<sharp> P \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by (pred_simp)

lemma unrest_usubst_lift_out [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by (pred_simp)

subsection {* Relation laws *}

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp)

lemma seqr_true_lemma:
  "(P = (\<not> ((\<not> P) ;; true))) = (P = (P ;; true))"
  by (rel_auto)
 theorem precond_equiv:
  "P = (P ;; true) \<longleftrightarrow> (out\<alpha> \<sharp> P)"
  by (rel_auto)

theorem postcond_equiv:
  "P = (true ;; P) \<longleftrightarrow> (in\<alpha> \<sharp> P)"
  by (rel_auto)
lemma precond_right_unit: "out\<alpha> \<sharp> p \<Longrightarrow> (p ;; true) = p"
  by (metis precond_equiv)

theorem seqr_post_transfer: "out\<alpha> \<sharp> q \<Longrightarrow> (P ;; (q \<and> R)) = ((P \<and> q\<^sup>-) ;; R)"
  by (rel_auto)

lemma seqr_pre_out: "out\<alpha> \<sharp> p \<Longrightarrow> ((p \<and> Q) ;; R) = (p \<and> (Q ;; R))"
  by (rel_blast)

lemma postcond_left_unit: "in\<alpha> \<sharp> p \<Longrightarrow> (true ;; p) = p"
  by (metis postcond_equiv)

lemma seqr_to_conj: "\<lbrakk> out\<alpha> \<sharp> P; in\<alpha> \<sharp> Q \<rbrakk> \<Longrightarrow> (P ;; Q) = (P \<and> Q)"
  by (metis postcond_left_unit seqr_pre_out utp_pred_laws.inf_top.right_neutral)

lemma shEx_lift_seq_1 [uquant_lift]:
  "((\<^bold>\<exists> x \<bullet> P x) ;; Q) = (\<^bold>\<exists> x \<bullet> (P x ;; Q))"
  by pred_auto

lemma shEx_lift_seq_2 [uquant_lift]:
  "(P ;; (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P ;; Q x))"
  by pred_auto

subsection {* Iterated Sequential Composition Laws *}

lemma iter_seqr_nil [simp]: "(;; i : [] \<bullet> P(i)) = II"
  by (simp add: seqr_iter_def)

lemma iter_seqr_cons [simp]: "(;; i : (x # xs) \<bullet> P(i)) = P(x) ;; (;; i : xs \<bullet> P(i))"
  by (simp add: seqr_iter_def)

text {* Quantale laws for relations *}

lemma seq_Sup_distl: "P ;; (\<Sqinter> A) = (\<Sqinter> Q\<in>A. P ;; Q)"
  by (transfer, rel_auto)

lemma seq_Sup_distr: "(\<Sqinter> A) ;; Q = (\<Sqinter> P\<in>A. P ;; Q)"
  by (transfer, auto)

lemma seq_UINF_distl: "P ;; (\<Sqinter> Q\<in>A \<bullet> F(Q)) = (\<Sqinter> Q\<in>A \<bullet> P ;; F(Q))"
  by (simp add: UINF_as_Sup_collect seq_Sup_distl)

lemma seq_UINF_distl': "P ;; (\<Sqinter> Q \<bullet> F(Q)) = (\<Sqinter> Q \<bullet> P ;; F(Q))"
  by (metis UINF_mem_UNIV seq_UINF_distl)

lemma seq_UINF_distr: "(\<Sqinter> P\<in>A \<bullet> F(P)) ;; Q = (\<Sqinter> P\<in>A \<bullet> F(P) ;; Q)"
  by (simp add: UINF_as_Sup_collect seq_Sup_distr)

lemma seq_UINF_distr': "(\<Sqinter> P \<bullet> F(P)) ;; Q = (\<Sqinter> P \<bullet> F(P) ;; Q)"
  by (metis UINF_mem_UNIV seq_UINF_distr)

lemma seq_SUP_distl: "P ;; (\<Sqinter>i\<in>A. Q(i)) = (\<Sqinter>i\<in>A. P ;; Q(i))"
  by (metis image_image seq_Sup_distl)

lemma seq_SUP_distr: "(\<Sqinter>i\<in>A. P(i)) ;; Q = (\<Sqinter>i\<in>A. P(i) ;; Q)"
  by (simp add: seq_Sup_distr)

lemma impl_seqr_mono: "\<lbrakk> `P \<Rightarrow> Q`; `R \<Rightarrow> S` \<rbrakk> \<Longrightarrow> `(P ;; R) \<Rightarrow> (Q ;; S)`"
  by transfer (pred_blast)

lemma seqr_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 ;; Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 ;; Q\<^sub>2)"
  by transfer (rel_blast)

lemma seqr_monotonic:
  "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X ;; Q X)"
  by (simp add: mono_def, transfer ,rel_blast)

lemma cond_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2)"
  unfolding cond_def
  by transfer (rel_auto)

lemma cond_monotonic:
  "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X \<triangleleft> b \<triangleright> Q X)"
  unfolding cond_def
  by (simp add: mono_def, rel_blast)

lemma spec_refine:
  "Q \<sqsubseteq> (P \<and> R) \<Longrightarrow> (P \<Rightarrow> Q) \<sqsubseteq> R"
  by (rel_auto)

lemma cond_skip: "out\<alpha> \<sharp> b \<Longrightarrow> (b \<and> II) = (II \<and> b\<^sup>-)"
  by (rel_auto)

lemma assigns_subst [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ> \<sigma>\<rangle>\<^sub>a"
  by transfer (rel_auto)

lemma assigns_r_comp: "(\<langle>\<sigma>\<rangle>\<^sub>a ;; P) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P)"
  by transfer rel_auto

lemma assigns_r_feasible:
  "(\<langle>\<sigma>\<rangle>\<^sub>a ;; true) = true"
  by (simp add: assigns_r_comp subst_true)

lemma assign_subst [usubst]:
  "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> [$x \<mapsto>\<^sub>s \<lceil>u\<rceil>\<^sub><] \<dagger> (y :== v) = (x, y :== u, [x \<mapsto>\<^sub>s u] \<dagger> v)"
  by rel_auto

lemma assigns_idem: "mwb_lens x \<Longrightarrow> (x,x :== u,v) = (x :== v)"
  by (simp add: usubst)

lemma assigns_comp: "(\<langle>f\<rangle>\<^sub>a ;; \<langle>g\<rangle>\<^sub>a) = \<langle>g \<circ> f\<rangle>\<^sub>a"
  by (simp add: assigns_r_comp usubst)

lemma assigns_r_conv:
  "bij f \<Longrightarrow> \<langle>f\<rangle>\<^sub>a\<^sup>- = \<langle>inv f\<rangle>\<^sub>a"
  by transfer (rel_auto, simp_all add: bij_is_inj bij_is_surj surj_f_inv_f)

lemma assign_pred_transfer:
  fixes x :: "('a\<Longrightarrow> '\<alpha>)"
  assumes "$x \<sharp> b" "out\<alpha> \<sharp> b"
  shows "(b \<and> x :== v) = (x :== v \<and> b\<^sup>-)"
  using assms by rel_blast

lemma assigns_r_ufunc: "ufunctional \<langle>f\<rangle>\<^sub>a"
  by (rel_auto)

lemma assigns_r_uinj: "inj f \<Longrightarrow> uinj \<langle>f\<rangle>\<^sub>a"
  by (rel_simp, simp add: inj_eq)

lemma assigns_r_swap_uinj:
  "\<lbrakk> vwb_lens x; vwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> uinj (x,y :== &y,&x)"
  using assigns_r_uinj swap_usubst_inj by rel_auto

lemma skip_r_unfold:
  "vwb_lens x \<Longrightarrow> II = ($x\<acute> =\<^sub>u $x \<and> II\<restriction>\<^sub>\<alpha>x)"
  by (rel_auto, metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)

lemma skip_ra_unfold:
  "II\<^bsub>x;y\<^esub> = ($x\<acute> =\<^sub>u $x \<and> II\<^bsub>y\<^esub>)"
  by (rel_auto)

lemma skip_res_as_ra:
  "\<lbrakk> vwb_lens y; x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L; x \<bowtie> y \<rbrakk> \<Longrightarrow> II\<restriction>\<^sub>\<alpha>x = II\<^bsub>y\<^esub>"
  apply (rel_auto)
  apply (metis (no_types, lifting) lens_indep_def)
  apply (metis vwb_lens.put_eq)
done

lemma assign_unfold:
  "vwb_lens x \<Longrightarrow> (x :== v) = ($x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub>< \<and> II\<restriction>\<^sub>\<alpha>x)"
  apply (rel_auto, auto simp add: comp_def)
  using vwb_lens.put_eq by fastforce

lemma seqr_and_distr_ufunc:
  "ufunctional P \<Longrightarrow> (P ;; (Q \<and> R)) = ((P ;; Q) \<and> (P ;; R))"
  by rel_auto

lemma seqr_and_distl_uinj:
  "uinj R \<Longrightarrow> ((P \<and> Q) ;; R) = ((P ;; R) \<and> (Q ;; R))"
  by (rel_auto)

theorem precond_left_zero:
  assumes "out\<alpha> \<sharp> p" "p \<noteq> false"
  shows "(true ;; p) = true"
  using assms by pred_auto

subsection {* Converse laws *}

lemma convr_invol [simp]: "p\<^sup>-\<^sup>- = p"
  by pred_auto

lemma lit_convr [simp]: "\<guillemotleft>v\<guillemotright>\<^sup>- = \<guillemotleft>v\<guillemotright>"
  by pred_auto

lemma uivar_convr [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "($x)\<^sup>- = $x\<acute>"
  by pred_auto

lemma uovar_convr [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "($x\<acute>)\<^sup>- = $x"
  by pred_auto

lemma uop_convr [simp]: "(uop f u)\<^sup>- = uop f (u\<^sup>-)"
  by (pred_auto)

lemma bop_convr [simp]: "(bop f u v)\<^sup>- = bop f (u\<^sup>-) (v\<^sup>-)"
  by (pred_auto)

lemma eq_convr [simp]: "(p =\<^sub>u q)\<^sup>- = (p\<^sup>- =\<^sub>u q\<^sup>-)"
  by (pred_auto)

lemma not_convr [simp]: "(\<not> p)\<^sup>- = (\<not> p\<^sup>-)"
  by (pred_auto)

lemma disj_convr [simp]: "(p \<or> q)\<^sup>- = (q\<^sup>- \<or> p\<^sup>-)"
  by (pred_auto)

lemma conj_convr [simp]: "(p \<and> q)\<^sup>- = (q\<^sup>- \<and> p\<^sup>-)"
  by (pred_auto)

lemma seqr_convr [simp]: "(p ;; q)\<^sup>- = (q\<^sup>- ;; p\<^sup>-)"
  by rel_auto

lemma pre_convr [simp]: "\<lceil>p\<rceil>\<^sub><\<^sup>- = \<lceil>p\<rceil>\<^sub>>"
  by (rel_auto)

lemma post_convr [simp]: "\<lceil>p\<rceil>\<^sub>>\<^sup>- = \<lceil>p\<rceil>\<^sub><"
  by (rel_auto)

theorem seqr_pre_transfer: "in\<alpha> \<sharp> q \<Longrightarrow> ((P \<and> q) ;; R) = (P ;; (q\<^sup>- \<and> R))"
  by (rel_auto)

theorem seqr_pre_transfer':
  "((P \<and> \<lceil>q\<rceil>\<^sub>>) ;; R) = (P ;; (\<lceil>q\<rceil>\<^sub>< \<and> R))"
  by (rel_auto)

theorem seqr_post_out: "in\<alpha> \<sharp> r \<Longrightarrow> (P ;; (Q \<and> r)) = ((P ;; Q) \<and> r)"
  by (rel_blast)

lemma seqr_post_var_out:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows "(P ;; (Q \<and> $x\<acute>)) = ((P ;; Q) \<and> $x\<acute>)"
  by (rel_auto)

lemma seqr_pre_var_out:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows "(($x \<and> P) ;; Q) = ($x \<and> (P ;; Q))"
  by (rel_auto)

subsection {* Relational unrestriction *}

text {* Relational unrestriction states that a variable is unchanged by a relation. Eventually
  I'd also like to have it state that the relation also does not depend on the variable's
  initial value, but I'm not sure how to state that yet. For now we represent this by
  the parametric healthiness condition RID. *}

definition RID :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"
where "RID x P = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x)"

declare RID_def [urel_defs]

lemma RID_idem:
  "mwb_lens x \<Longrightarrow> RID(x)(RID(x)(P)) = RID(x)(P)"
  by (rel_auto)

lemma RID_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> RID(x)(P) \<sqsubseteq> RID(x)(Q)"
  by (rel_auto)

lemma RID_skip_r:
  "vwb_lens x \<Longrightarrow> RID(x)(II) = II"
  apply (rel_auto) using vwb_lens.put_eq by fastforce

lemma RID_disj:
  "RID(x)(P \<or> Q) = (RID(x)(P) \<or> RID(x)(Q))"
  by (rel_auto)

lemma RID_conj:
  "vwb_lens x \<Longrightarrow> RID(x)(RID(x)(P) \<and> RID(x)(Q)) = (RID(x)(P) \<and> RID(x)(Q))"
  by (rel_auto)

lemma RID_assigns_r_diff:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> RID(x)(\<langle>\<sigma>\<rangle>\<^sub>a) = \<langle>\<sigma>\<rangle>\<^sub>a"
  apply (rel_auto)
  apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
done

lemma RID_assign_r_same:
  "vwb_lens x \<Longrightarrow> RID(x)(x :== v) = II"
  apply (rel_auto)
  using vwb_lens.put_eq apply fastforce
done

lemma RID_seq_left:
  assumes "vwb_lens x"
  shows "RID(x)(RID(x)(P) ;; Q) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(RID(x)(P) ;; Q) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; Q) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> (\<exists> $x \<bullet> $x\<acute> =\<^sub>u $x)) ;; (\<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
    apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
  done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma RID_seq_right:
  assumes "vwb_lens x"
  shows "RID(x)(P ;; RID(x)(Q)) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(P ;; RID(x)(Q)) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = (((\<exists> $x \<bullet>  P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> (\<exists> $x\<acute> \<bullet> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
    apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
  done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

definition unrest_relation :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> bool" (infix "\<sharp>\<sharp>" 20)
where "(x \<sharp>\<sharp> P) \<longleftrightarrow> (P = RID(x)(P))"

declare unrest_relation_def [urel_defs]

lemma skip_r_runrest [unrest]:
  "vwb_lens x \<Longrightarrow> x \<sharp>\<sharp> II"
  by (simp add: RID_skip_r unrest_relation_def)

lemma assigns_r_runrest:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: RID_assigns_r_diff unrest_relation_def)

lemma seq_r_runrest [unrest]:
  assumes "vwb_lens x" "x \<sharp>\<sharp> P" "x \<sharp>\<sharp> Q"
  shows "x \<sharp>\<sharp> (P ;; Q)"
  by (metis RID_seq_left assms unrest_relation_def)

lemma false_runrest [unrest]: "x \<sharp>\<sharp> false"
  by (rel_auto)

lemma and_runrest [unrest]: "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<and> Q)"
  by (metis RID_conj unrest_relation_def)

lemma or_runrest [unrest]: "\<lbrakk> x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<or> Q)"
  by (simp add: RID_disj unrest_relation_def)

subsection {* Alphabet laws *}

lemma aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright> Q) \<oplus>\<^sub>p a = ((P \<oplus>\<^sub>p a) \<triangleleft>(b \<oplus>\<^sub>p a)\<triangleright>(Q \<oplus>\<^sub>p a))"
  by (rel_auto)

lemma aext_seq [alpha]:
  "wb_lens a \<Longrightarrow> ((P ;; Q) \<oplus>\<^sub>p (a \<times>\<^sub>L a)) = ((P \<oplus>\<^sub>p (a \<times>\<^sub>L a)) ;; (Q \<oplus>\<^sub>p (a \<times>\<^sub>L a)))"
  by (rel_simp, metis wb_lens_weak weak_lens.put_get)
text {* We introduce the power syntax derived from semirings *}

subsection {* Algebraic Properties *}

interpretation upred_semiring: semiring_1
  where times = seqr and one = skip_r and zero = false\<^sub>h and plus = Lattices.sup
  by (unfold_locales, (rel_auto)+)

abbreviation upower :: "'\<alpha> hrel \<Rightarrow> nat \<Rightarrow> '\<alpha> hrel" (infixr "\<^bold>^" 100) where
"upower P n \<equiv> upred_semiring.power P n"

translations
  "P \<^bold>^ i" <= "CONST power.power II op ;; P i"
  "P \<^bold>^ i" <= "(CONST power.power II op ;; P) i"

text {* Set up transfer tactic for powers *}

lemma upower_rep_eq:
  "\<lbrakk>P \<^bold>^ i\<rbrakk>\<^sub>e = (\<lambda> b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p} ^^ i))"
proof (induct i arbitrary: P)
  case 0
  then show ?case
    by (auto, rel_auto)
next
  case (Suc i)
  show ?case
    by (simp add: Suc seqr.rep_eq relpow_commute)
qed

lemma upower_rep_eq_alt:
  "\<lbrakk>power.power \<langle>id\<rangle>\<^sub>a op ;; P i\<rbrakk>\<^sub>e = (\<lambda>b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p} ^^ i))"
  by (metis skip_r_def upower_rep_eq)

update_uexpr_rep_eq_thms

lemma Sup_power_expand:
  fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
  shows "P(0) \<sqinter> (\<Sqinter>i. P(i+1)) = (\<Sqinter>i. P(i))"
proof -
  have "UNIV = insert (0::nat) {1..}"
    by auto
  moreover have "(\<Sqinter>i. P(i)) = \<Sqinter> (P ` UNIV)"
    by (blast)
  moreover have "\<Sqinter> (P ` insert 0 {1..}) = P(0) \<sqinter> SUPREMUM {1..} P"
    by (simp)
  moreover have "SUPREMUM {1..} P = (\<Sqinter>i. P(i+1))"
    by (simp add: atLeast_Suc_greaterThan)
  ultimately show ?thesis
    by (simp only:)
qed

lemma Sup_upto_Suc: "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i) \<sqinter> P \<^bold>^ Suc n"
proof -
  have "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>insert (Suc n) {0..n}. P \<^bold>^ i)"
    by (simp add: atLeast0_atMost_Suc)
  also have "... = P \<^bold>^ Suc n \<sqinter> (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i)"
    by (simp)
  finally show ?thesis
    by (simp add: Lattices.sup_commute)
qed

text {* The following two proofs are adapted from the AFP entry
  \href{https://www.isa-afp.org/entries/Kleene_Algebra.shtml}{Kleene Algebra}.
  See also~\cite{Armstrong2012,Armstrong2015}. *}

lemma seqr_left_unit [simp]:
  "II ;; P = P"
  by rel_auto

lemma seqr_right_unit [simp]:
  "P ;; II = P"
  by rel_auto

lemma seqr_assoc: "P ;; (Q ;; R) = (P ;; Q) ;; R"
  by rel_auto

lemma seqr_assoc': "(P ;; Q) ;; R = P ;; (Q ;; R) "
  by rel_auto

lemma upower_inductl: "Q \<sqsubseteq> (P ;; Q \<sqinter> R) \<Longrightarrow> Q \<sqsubseteq> P \<^bold>^ n ;; R"
proof (induct n)
  case 0
  then show ?case by (auto)
next
  case (Suc n)
  then show ?case
    by (auto, metis (no_types, hide_lams) dual_order.trans order_refl seqr_assoc seqr_mono)
qed

lemma upower_inductr:
  assumes "Q \<sqsubseteq> (R \<sqinter> Q ;; P)"
  shows "Q \<sqsubseteq> R ;; (P \<^bold>^ n)"
using assms proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "R ;; P \<^bold>^ Suc n = (R ;; P \<^bold>^ n) ;; P"
    by (metis seqr_assoc upred_semiring.power_Suc2)
  also have "Q ;; P \<sqsubseteq> ..."
    using Suc.hyps assms seqr_mono by auto
  also have "Q \<sqsubseteq> ..."
    using assms by auto
  finally show ?case .
qed

lemma SUP_atLeastAtMost_first:
  fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
  assumes "m \<le> n"
  shows "(\<Sqinter>i\<in>{m..n}. P(i)) = P(m) \<sqinter> (\<Sqinter>i\<in>{Suc m..n}. P(i))"
  by (metis SUP_insert assms atLeastAtMost_insertL)

lemma upower_seqr_iter: "P \<^bold>^ n = (;; Q : replicate n P \<bullet> Q)"
  by (induct n) simp_all

subsubsection {* Kleene Star *}

definition ustar :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<star>" [999] 999) where
"P\<^sup>\<star> = (\<Sqinter>i\<in>{0..} \<bullet> P\<^bold>^i)"

lemma ustar_rep_eq:
  "\<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>e = (\<lambda>b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p}\<^sup>*))"
  by (simp add: ustar_def, rel_auto, simp_all add: relpow_imp_rtrancl rtrancl_imp_relpow)

update_uexpr_rep_eq_thms

subsubsection {* Omega *}

definition uomega :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<omega>" [999] 999) where
"P\<^sup>\<omega> = (\<mu> X \<bullet> P ;; X)"

subsection {* Relation Algebra Laws *}

theorem RA1: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
  using seqr_assoc by auto

theorem RA2: "(P ;; II) = P" "(II ;; P) = P"
  by simp_all

theorem RA3: "P\<^sup>-\<^sup>- = P"
  by simp

theorem RA4: "(P ;; Q)\<^sup>- = (Q\<^sup>- ;; P\<^sup>-)"
  by simp

theorem RA5: "(P \<or> Q)\<^sup>- = (P\<^sup>- \<or> Q\<^sup>-)"
  by (rel_auto)

named_theorems urel_comp

lemma seqr_or_distl[urel_comp]:
  "((P \<or> Q) ;; R) = ((P ;; R) \<or> (Q ;; R))"
  by rel_auto

theorem RA6: "((P \<or> Q) ;; R) = (P;;R \<or> Q;;R)"
  using seqr_or_distl by blast

subsection {* Kleene Algebra Laws *}

theorem ustar_unfoldl: "P\<^sup>\<star> \<sqsubseteq> II \<sqinter> P;;P\<^sup>\<star>"
  by (rel_simp, simp add: rtrancl_into_trancl2 trancl_into_rtrancl)

theorem ustar_inductl:
  assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> P ;; Q"
  shows "Q \<sqsubseteq> P\<^sup>\<star> ;; R"
proof -
  have "P\<^sup>\<star> ;; R = (\<Sqinter> i. P \<^bold>^ i ;; R)"
    by (simp add: ustar_def UINF_as_Sup_collect' seq_SUP_distr)
  also have "Q \<sqsubseteq> ..."
    by (simp add: SUP_least assms upower_inductl)
  finally show ?thesis .
qed

theorem ustar_inductr:
  assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> Q ;; P"
  shows "Q \<sqsubseteq> R ;; P\<^sup>\<star>"
proof -
  have "R ;; P\<^sup>\<star> = (\<Sqinter> i. R ;; P \<^bold>^ i)"
    by (simp add: ustar_def UINF_as_Sup_collect' seq_SUP_distl)
  also have "Q \<sqsubseteq> ..."
    by (simp add: SUP_least assms upower_inductr)
  finally show ?thesis .
qed

lemma ustar_refines_nu: "(\<nu> X \<bullet> P ;; X \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
  by (metis (no_types, lifting) lfp_greatest semilattice_sup_class.le_sup_iff
      semilattice_sup_class.sup_idem upred_semiring.mult_2_right
      upred_semiring.one_add_one ustar_inductl)

lemma ustar_as_nu: "P\<^sup>\<star> = (\<nu> X \<bullet> P ;; X \<sqinter> II)"
proof (rule antisym)
  show "(\<nu> X \<bullet> P ;; X \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
    by (simp add: ustar_refines_nu)
  show "P\<^sup>\<star> \<sqsubseteq> (\<nu> X \<bullet> P ;; X \<sqinter> II)"
    by (metis lfp_lowerbound upred_semiring.add_commute ustar_unfoldl)
qed

subsection {* Omega Algebra Laws *}

lemma uomega_induct:
  "P ;; P\<^sup>\<omega> \<sqsubseteq> P\<^sup>\<omega>"
  by (simp add: uomega_def, metis eq_refl gfp_unfold monoI seqr_mono)

end