(*  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))"
      unfolding mod_contains_result_def
      by simp
    have module_mn: "electoral_module (m \<parallel>\<^sub>\<up> n)"
      using module_m module_n
      by simp
  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)))"
        unfolding 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"
proof (unfold mod_contains_result_def, 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"
proof (unfold mod_contains_result_def, 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
    unfolding 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)"
    using module_m module_n f_prof result_presv_alts
    by metis
  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 in_A max_agg_rej1 max_agg_rej3
  unfolding disjoint_compatibility_def
  by metis

subsection \<open>Composition Rules\<close>

text \<open>
  Using a conservative aggregator, the parallel composition
  preserves the property non-electing.
\<close>

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

text \<open>
  Using the max aggregator, composing two compatible
  electoral modules in parallel preserves defer-lift-invariance.
\<close>

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)"
proof (unfold defer_lift_invariance_def, safe)
  have electoral_mod_m: "electoral_module m"
    using monotone_m
    unfolding defer_lift_invariance_def
    by simp
  have electoral_mod_n: "electoral_module n"
    using monotone_n
    unfolding defer_lift_invariance_def
    by simp
  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"
    unfolding lifted_def
    by simp
  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 f_profs
    unfolding disjoint_compatibility_def
    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 f_profs max_agg_rej4
      unfolding disjoint_compatibility_def mod_contains_result_def
      by metis
    have "\<forall> x \<in> A. mod_contains_result (m \<parallel>\<^sub>\<up> n) n S p x"
      using A compatible max_agg_rej4 f_profs
      unfolding disjoint_compatibility_def
      by metis
    moreover have "\<forall> x \<in> S. prof_contains_result n S p q x"
    proof (unfold prof_contains_result_def, 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
          unfolding 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
          unfolding 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
          unfolding 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
          unfolding 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 max_agg_rej3 f_profs
      unfolding disjoint_compatibility_def
      by metis
    ultimately have 00:
      "\<forall> x \<in> A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
      unfolding mod_contains_result_def prof_contains_result_def
      by simp
    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
      unfolding defer_lift_invariance_def
      by metis
    moreover have "\<forall> x \<in> S. prof_contains_result m S p q x"
    proof (unfold prof_contains_result_def, 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
          unfolding 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 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_def
          by metis
      next
        assume "x \<in> reject m S p"
        thus "x \<in> reject m S q"
          using A a0 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_def
          by metis
      next
        assume "x \<in> defer m S p"
        thus "x \<in> defer m S q"
          using A a0 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_def
          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
      unfolding 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"
      unfolding mod_contains_result_def prof_contains_result_def
      by simp
    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
      unfolding 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 f_profs
            defer_not_elec_or_rej max_agg_sound par_comp_sound
            disjoint_compatibility_def not_rej_imp_elec_or_def
            mod_contains_result_def
      unfolding 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 max_agg_rej4 f_profs
      unfolding disjoint_compatibility_def
      by metis
    moreover have "\<forall> x \<in> S. prof_contains_result n S p q x"
    proof (unfold prof_contains_result_def, 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
          unfolding 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 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_def
          by metis
      next
        assume "x \<in> reject n S p"
        thus "x \<in> reject n S q"
          using A a1 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_def
          by metis
      next
        assume "x \<in> defer n S p"
        thus "x \<in> defer n S q"
          using A a1 lifted_x lifted_imp_equiv_prof_except_a
          unfolding indep_of_alt_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 max_agg_rej3 f_profs
    unfolding disjoint_compatibility_def
    by metis
  ultimately have 10:
    "\<forall> x \<in> A. prof_contains_result (m \<parallel>\<^sub>\<up> n) S p q x"
    unfolding mod_contains_result_def prof_contains_result_def
    by simp
  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
    unfolding defer_lift_invariance_def
    by metis
  moreover have "\<forall> x \<in> S. prof_contains_result m S p q x"
  proof (unfold prof_contains_result_def, 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
        unfolding defer_lift_invariance_def
        by simp
    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_m lifted_x monotone_m
        unfolding defer_lift_invariance_def
        by metis
    next
      assume "x \<in> reject m S p"
      thus "x \<in> reject m S q"
        using defer_m lifted_x monotone_m
        unfolding defer_lift_invariance_def
        by metis
    next
      assume "x \<in> defer m S p"
      thus "x \<in> defer m S q"
        using defer_m lifted_x monotone_m
        unfolding defer_lift_invariance_def
        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
    unfolding 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
    unfolding mod_contains_result_def prof_contains_result_def
    by simp
  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 f_profs eq_alts_in_profs_imp_eq_results
          max_par_comp_sound
    unfolding disjoint_compatibility_def
    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 f_prof
    unfolding disjoint_compatibility_def
    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
    unfolding disjoint_compatibility_def
    by metis
  have "electoral_module x \<and> electoral_module y"
    using compatible
    unfolding disjoint_compatibility_def
    by simp
  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
    by metis
  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

text \<open>
  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.
\<close>

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)"
proof (unfold eliminates_def, safe)
  have electoral_mod_m: "electoral_module m"
    using non_elec_m
    unfolding non_electing_def
    by simp
  have electoral_mod_n: "electoral_module n"
    using rejec_n_2
    unfolding rejects_def
    by simp
  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
    unfolding non_electing_def
    by simp
  have elec_card_0: "card (elect m A p) = 0"
    using fin_A prof_A non_elec_m card_eq_0_iff
    unfolding non_electing_def
    by simp
  moreover
  from card_geq_1 have def_card_1:
    "card (defer m A p) = 1"
    using defers_m_1 module fin_A prof_A
    unfolding defers_def
    by simp
  ultimately have card_reject_m:
    "card (reject m A p) = card A - 1"
  proof -
    have "finite A"
      using fin_A
      by simp
    moreover have
      "well_formed A
        (elect m A p, reject m A p, defer m A p)"
      using fin_A prof_A module
      unfolding electoral_module_def
      by simp
    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 simp
  from case1
  have card_reject_n: "card (reject n A p) = 2"
    using fin_A prof_A rejec_n_2
    unfolding 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:      HOL/Extraction.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Program extraction for HOL\<close>

theory Extraction
imports Option
begin

ML_file "Tools/rewrite_hol_proof.ML"

subsection \<open>Setup\<close>

setup \<open>
  Extraction.add_types
      [("bool", ([], NONE))] #>
  Extraction.set_preprocessor (fn thy =>
    let val ctxt = Proof_Context.init_global thy in
      Proofterm.rewrite_proof_notypes
        ([], RewriteHOLProof.elim_cong :: ProofRewriteRules.rprocs true) o
      Proofterm.rewrite_proof thy
        (RewriteHOLProof.rews,
         ProofRewriteRules.rprocs true @ [ProofRewriteRules.expand_of_class ctxt]) o
      ProofRewriteRules.elim_vars (curry Const @{const_name default})
    end)
\<close>

lemmas [extraction_expand] =
  meta_spec atomize_eq atomize_all atomize_imp atomize_conj
  allE rev_mp conjE Eq_TrueI Eq_FalseI eqTrueI eqTrueE eq_cong2
  notE' impE' impE iffE imp_cong simp_thms eq_True eq_False
  induct_forall_eq induct_implies_eq induct_equal_eq induct_conj_eq
  induct_atomize induct_atomize' induct_rulify induct_rulify'
  induct_rulify_fallback induct_trueI
  True_implies_equals implies_True_equals TrueE
  False_implies_equals implies_False_swap

lemmas [extraction_expand_def] =
  HOL.induct_forall_def HOL.induct_implies_def HOL.induct_equal_def HOL.induct_conj_def
  HOL.induct_true_def HOL.induct_false_def

datatype (plugins only: code extraction) sumbool = Left | Right

subsection \<open>Type of extracted program\<close>

extract_type
  "typeof (Trueprop P) \<equiv> typeof P"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE('Q))"

  "typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE(Null))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<longrightarrow> Q) \<equiv> Type (TYPE('P \<Rightarrow> 'Q))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     typeof (\<forall>x. P x) \<equiv> Type (TYPE(Null))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE('P))) \<Longrightarrow>
     typeof (\<forall>x::'a. P x) \<equiv> Type (TYPE('a \<Rightarrow> 'P))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     typeof (\<exists>x::'a. P x) \<equiv> Type (TYPE('a))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE('P))) \<Longrightarrow>
     typeof (\<exists>x::'a. P x) \<equiv> Type (TYPE('a \<times> 'P))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE(sumbool))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('Q option))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('P option))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<or> Q) \<equiv> Type (TYPE('P + 'Q))"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('Q))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('P))"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow> typeof Q \<equiv> Type (TYPE('Q)) \<Longrightarrow>
     typeof (P \<and> Q) \<equiv> Type (TYPE('P \<times> 'Q))"

  "typeof (P = Q) \<equiv> typeof ((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P))"

  "typeof (x \<in> P) \<equiv> typeof P"

subsection \<open>Realizability\<close>

realizability
  "(realizes t (Trueprop P)) \<equiv> (Trueprop (realizes t P))"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<longrightarrow> Q)) \<equiv> (realizes Null P \<longrightarrow> realizes t Q)"

  "(typeof P) \<equiv> (Type (TYPE('P))) \<Longrightarrow>
   (typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<longrightarrow> Q)) \<equiv> (\<forall>x::'P. realizes x P \<longrightarrow> realizes Null Q)"

  "(realizes t (P \<longrightarrow> Q)) \<equiv> (\<forall>x. realizes x P \<longrightarrow> realizes (t x) Q)"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (\<forall>x. P x)) \<equiv> (\<forall>x. realizes Null (P x))"

  "(realizes t (\<forall>x. P x)) \<equiv> (\<forall>x. realizes (t x) (P x))"

  "(\<lambda>x. typeof (P x)) \<equiv> (\<lambda>x. Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (\<exists>x. P x)) \<equiv> (realizes Null (P t))"

  "(realizes t (\<exists>x. P x)) \<equiv> (realizes (snd t) (P (fst t)))"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
   (typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of Left \<Rightarrow> realizes Null P | Right \<Rightarrow> realizes Null Q)"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of None \<Rightarrow> realizes Null P | Some q \<Rightarrow> realizes q Q)"

  "(typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<or> Q)) \<equiv>
     (case t of None \<Rightarrow> realizes Null Q | Some p \<Rightarrow> realizes p P)"

  "(realizes t (P \<or> Q)) \<equiv>
   (case t of Inl p \<Rightarrow> realizes p P | Inr q \<Rightarrow> realizes q Q)"

  "(typeof P) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<and> Q)) \<equiv> (realizes Null P \<and> realizes t Q)"

  "(typeof Q) \<equiv> (Type (TYPE(Null))) \<Longrightarrow>
     (realizes t (P \<and> Q)) \<equiv> (realizes t P \<and> realizes Null Q)"

  "(realizes t (P \<and> Q)) \<equiv> (realizes (fst t) P \<and> realizes (snd t) Q)"

  "typeof P \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     realizes t (\<not> P) \<equiv> \<not> realizes Null P"

  "typeof P \<equiv> Type (TYPE('P)) \<Longrightarrow>
     realizes t (\<not> P) \<equiv> (\<forall>x::'P. \<not> realizes x P)"

  "typeof (P::bool) \<equiv> Type (TYPE(Null)) \<Longrightarrow>
   typeof Q \<equiv> Type (TYPE(Null)) \<Longrightarrow>
     realizes t (P = Q) \<equiv> realizes Null P = realizes Null Q"

  "(realizes t (P = Q)) \<equiv> (realizes t ((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)))"

subsection \<open>Computational content of basic inference rules\<close>

theorem disjE_realizer:
  assumes r: "case x of Inl p \<Rightarrow> P p | Inr q \<Rightarrow> Q q"
  and r1: "\<And>p. P p \<Longrightarrow> R (f p)" and r2: "\<And>q. Q q \<Longrightarrow> R (g q)"
  shows "R (case x of Inl p \<Rightarrow> f p | Inr q \<Rightarrow> g q)"
proof (cases x)
  case Inl
  with r show ?thesis by simp (rule r1)
next
  case Inr
  with r show ?thesis by simp (rule r2)
qed

theorem disjE_realizer2:
  assumes r: "case x of None \<Rightarrow> P | Some q \<Rightarrow> Q q"
  and r1: "P \<Longrightarrow> R f" and r2: "\<And>q. Q q \<Longrightarrow> R (g q)"
  shows "R (case x of None \<Rightarrow> f | Some q \<Rightarrow> g q)"
proof (cases x)
  case None
  with r show ?thesis by simp (rule r1)
next
  case Some
  with r show ?thesis by simp (rule r2)
qed

theorem disjE_realizer3:
  assumes r: "case x of Left \<Rightarrow> P | Right \<Rightarrow> Q"
  and r1: "P \<Longrightarrow> R f" and r2: "Q \<Longrightarrow> R g"
  shows "R (case x of Left \<Rightarrow> f | Right \<Rightarrow> g)"
proof (cases x)
  case Left
  with r show ?thesis by simp (rule r1)
next
  case Right
  with r show ?thesis by simp (rule r2)
qed

theorem conjI_realizer:
  "P p \<Longrightarrow> Q q \<Longrightarrow> P (fst (p, q)) \<and> Q (snd (p, q))"
  by simp

theorem exI_realizer:
  "P y x \<Longrightarrow> P (snd (x, y)) (fst (x, y))" by simp

theorem exE_realizer: "P (snd p) (fst p) \<Longrightarrow>
  (\<And>x y. P y x \<Longrightarrow> Q (f x y)) \<Longrightarrow> Q (let (x, y) = p in f x y)"
  by (cases p) (simp add: Let_def)

theorem exE_realizer': "P (snd p) (fst p) \<Longrightarrow>
  (\<And>x y. P y x \<Longrightarrow> Q) \<Longrightarrow> Q" by (cases p) simp

realizers
  impI (P, Q): "\<lambda>pq. pq"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h \<cdot> x))"

  impI (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h \<cdot> x))"

  impI (Q): "\<lambda>q. q" "\<^bold>\<lambda>(c: _) P Q q. impI \<cdot> _ \<cdot> _"

  impI: "Null" "impI"

  mp (P, Q): "\<lambda>pq. pq"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _) p. mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  mp (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (h: _) p. mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  mp (Q): "\<lambda>q. q" "\<^bold>\<lambda>(c: _) P Q q. mp \<cdot> _ \<cdot> _"

  mp: "Null" "mp"

  allI (P): "\<lambda>p. p" "\<^bold>\<lambda>(c: _) P (d: _) p. allI \<cdot> _ \<bullet> d"

  allI: "Null" "allI"

  spec (P): "\<lambda>x p. p x" "\<^bold>\<lambda>(c: _) P x (d: _) p. spec \<cdot> _ \<cdot> x \<bullet> d"

  spec: "Null" "spec"

  exI (P): "\<lambda>x p. (x, p)" "\<^bold>\<lambda>(c: _) P x (d: _) p. exI_realizer \<cdot> P \<cdot> p \<cdot> x \<bullet> c \<bullet> d"

  exI: "\<lambda>x. x" "\<^bold>\<lambda>P x (c: _) (h: _). h"

  exE (P, Q): "\<lambda>p pq. let (x, y) = p in pq x y"
    "\<^bold>\<lambda>(c: _) (d: _) P Q (e: _) p (h: _) pq. exE_realizer \<cdot> P \<cdot> p \<cdot> Q \<cdot> pq \<bullet> c \<bullet> e \<bullet> d \<bullet> h"

  exE (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q (d: _) p. exE_realizer' \<cdot> _ \<cdot> _ \<cdot> _ \<bullet> c \<bullet> d"

  exE (Q): "\<lambda>x pq. pq x"
    "\<^bold>\<lambda>(c: _) P Q (d: _) x (h1: _) pq (h2: _). h2 \<cdot> x \<bullet> h1"

  exE: "Null"
    "\<^bold>\<lambda>P Q (c: _) x (h1: _) (h2: _). h2 \<cdot> x \<bullet> h1"

  conjI (P, Q): "Pair"
    "\<^bold>\<lambda>(c: _) (d: _) P Q p (h: _) q. conjI_realizer \<cdot> P \<cdot> p \<cdot> Q \<cdot> q \<bullet> c \<bullet> d \<bullet> h"

  conjI (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjI \<cdot> _ \<cdot> _"

  conjI (Q): "\<lambda>q. q"
    "\<^bold>\<lambda>(c: _) P Q (h: _) q. conjI \<cdot> _ \<cdot> _ \<bullet> h"

  conjI: "Null" "conjI"

  conjunct1 (P, Q): "fst"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1 (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q q. conjunct1 \<cdot> _ \<cdot> _"

  conjunct1: "Null" "conjunct1"

  conjunct2 (P, Q): "snd"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2 (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2 (Q): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p. conjunct2 \<cdot> _ \<cdot> _"

  conjunct2: "Null" "conjunct2"

  disjI1 (P, Q): "Inl"
    "\<^bold>\<lambda>(c: _) (d: _) P Q p. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sum.case_1 \<cdot> P \<cdot> _ \<cdot> p \<bullet> arity_type_bool \<bullet> c \<bullet> d)"

  disjI1 (P): "Some"
    "\<^bold>\<lambda>(c: _) P Q p. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_2 \<cdot> _ \<cdot> P \<cdot> p \<bullet> arity_type_bool \<bullet> c)"

  disjI1 (Q): "None"
    "\<^bold>\<lambda>(c: _) P Q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool \<bullet> c)"

  disjI1: "Left"
    "\<^bold>\<lambda>P Q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sumbool.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool)"

  disjI2 (P, Q): "Inr"
    "\<^bold>\<lambda>(d: _) (c: _) Q P q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sum.case_2 \<cdot> _ \<cdot> Q \<cdot> q \<bullet> arity_type_bool \<bullet> c \<bullet> d)"

  disjI2 (P): "None"
    "\<^bold>\<lambda>(c: _) Q P. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_1 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool \<bullet> c)"

  disjI2 (Q): "Some"
    "\<^bold>\<lambda>(c: _) Q P q. iffD2 \<cdot> _ \<cdot> _ \<bullet> (option.case_2 \<cdot> _ \<cdot> Q \<cdot> q \<bullet> arity_type_bool \<bullet> c)"

  disjI2: "Right"
    "\<^bold>\<lambda>Q P. iffD2 \<cdot> _ \<cdot> _ \<bullet> (sumbool.case_2 \<cdot> _ \<cdot> _ \<bullet> arity_type_bool)"

  disjE (P, Q, R): "\<lambda>pq pr qr.
     (case pq of Inl p \<Rightarrow> pr p | Inr q \<Rightarrow> qr q)"
    "\<^bold>\<lambda>(c: _) (d: _) (e: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> d \<bullet> e \<bullet> h1 \<bullet> h2"

  disjE (Q, R): "\<lambda>pq pr qr.
     (case pq of None \<Rightarrow> pr | Some q \<Rightarrow> qr q)"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> d \<bullet> h1 \<bullet> h2"

  disjE (P, R): "\<lambda>pq pr qr.
     (case pq of None \<Rightarrow> qr | Some p \<Rightarrow> pr p)"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq (h1: _) pr (h2: _) qr (h3: _).
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> qr \<cdot> pr \<bullet> c \<bullet> d \<bullet> h1 \<bullet> h3 \<bullet> h2"

  disjE (R): "\<lambda>pq pr qr.
     (case pq of Left \<Rightarrow> pr | Right \<Rightarrow> qr)"
    "\<^bold>\<lambda>(c: _) P Q R pq (h1: _) pr (h2: _) qr.
       disjE_realizer3 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> R \<cdot> pr \<cdot> qr \<bullet> c \<bullet> h1 \<bullet> h2"

  disjE (P, Q): "Null"
    "\<^bold>\<lambda>(c: _) (d: _) P Q R pq. disjE_realizer \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> d \<bullet> arity_type_bool"

  disjE (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q R pq. disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> arity_type_bool"

  disjE (P): "Null"
    "\<^bold>\<lambda>(c: _) P Q R pq (h1: _) (h2: _) (h3: _).
       disjE_realizer2 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> c \<bullet> arity_type_bool \<bullet> h1 \<bullet> h3 \<bullet> h2"

  disjE: "Null"
    "\<^bold>\<lambda>P Q R pq. disjE_realizer3 \<cdot> _ \<cdot> _ \<cdot> pq \<cdot> (\<lambda>x. R) \<cdot> _ \<cdot> _ \<bullet> arity_type_bool"

  FalseE (P): "default"
    "\<^bold>\<lambda>(c: _) P. FalseE \<cdot> _"

  FalseE: "Null" "FalseE"

  notI (P): "Null"
    "\<^bold>\<lambda>(c: _) P (h: _). allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. notI \<cdot> _ \<bullet> (h \<cdot> x))"

  notI: "Null" "notI"

  notE (P, R): "\<lambda>p. default"
    "\<^bold>\<lambda>(c: _) (d: _) P R (h: _) p. notE \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  notE (P): "Null"
    "\<^bold>\<lambda>(c: _) P R (h: _) p. notE \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> c \<bullet> h)"

  notE (R): "default"
    "\<^bold>\<lambda>(c: _) P R. notE \<cdot> _ \<cdot> _"

  notE: "Null" "notE"

  subst (P): "\<lambda>s t ps. ps"
    "\<^bold>\<lambda>(c: _) s t P (d: _) (h: _) ps. subst \<cdot> s \<cdot> t \<cdot> P ps \<bullet> d \<bullet> h"

  subst: "Null" "subst"

  iffD1 (P, Q): "fst"
    "\<^bold>\<lambda>(d: _) (c: _) Q P pq (h: _) p.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> p \<bullet> d \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD1 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) Q P p (h: _). mp \<cdot> _ \<cdot> _ \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h)"

  iffD1 (Q): "Null"
    "\<^bold>\<lambda>(c: _) Q P q1 (h: _) q2.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q2 \<bullet> c \<bullet> (conjunct1 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD1: "Null" "iffD1"

  iffD2 (P, Q): "snd"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h: _) q.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q \<bullet> d \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD2 (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q p (h: _). mp \<cdot> _ \<cdot> _ \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h)"

  iffD2 (Q): "Null"
    "\<^bold>\<lambda>(c: _) P Q q1 (h: _) q2.
       mp \<cdot> _ \<cdot> _ \<bullet> (spec \<cdot> _ \<cdot> q2 \<bullet> c \<bullet> (conjunct2 \<cdot> _ \<cdot> _ \<bullet> h))"

  iffD2: "Null" "iffD2"

  iffI (P, Q): "Pair"
    "\<^bold>\<lambda>(c: _) (d: _) P Q pq (h1 : _) qp (h2 : _). conjI_realizer \<cdot>
       (\<lambda>pq. \<forall>x. P x \<longrightarrow> Q (pq x)) \<cdot> pq \<cdot>
       (\<lambda>qp. \<forall>x. Q x \<longrightarrow> P (qp x)) \<cdot> qp \<bullet>
       (arity_type_fun \<bullet> c \<bullet> d) \<bullet>
       (arity_type_fun \<bullet> d \<bullet> c) \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h1 \<cdot> x))) \<bullet>
       (allI \<cdot> _ \<bullet> d \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h2 \<cdot> x)))"

  iffI (P): "\<lambda>p. p"
    "\<^bold>\<lambda>(c: _) P Q (h1 : _) p (h2 : _). conjI \<cdot> _ \<cdot> _ \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h1 \<cdot> x))) \<bullet>
       (impI \<cdot> _ \<cdot> _ \<bullet> h2)"

  iffI (Q): "\<lambda>q. q"
    "\<^bold>\<lambda>(c: _) P Q q (h1 : _) (h2 : _). conjI \<cdot> _ \<cdot> _ \<bullet>
       (impI \<cdot> _ \<cdot> _ \<bullet> h1) \<bullet>
       (allI \<cdot> _ \<bullet> c \<bullet> (\<^bold>\<lambda>x. impI \<cdot> _ \<cdot> _ \<bullet> (h2 \<cdot> x)))"

  iffI: "Null" "iffI"

end


theory M_Basic_No_Repl
  imports "ZF-Constructible.Relative"
begin

txt\<open>This locale is exactly \<^locale>\<open>M_basic\<close> without its only replacement
instance.\<close>

locale M_basic_no_repl = M_trivial +
  assumes Inter_separation:
    "M(A) ==> separation(M, \<lambda>x. \<forall>y[M]. y\<in>A \<longrightarrow> x\<in>y)"
    and Diff_separation:
    "M(B) ==> separation(M, \<lambda>x. x \<notin> B)"
    and cartprod_separation:
    "[| M(A); M(B) |]
      ==> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A & (\<exists>y[M]. y\<in>B & pair(M,x,y,z)))"
    and image_separation:
    "[| M(A); M(r) |]
      ==> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r & (\<exists>x[M]. x\<in>A & pair(M,x,y,p)))"
    and converse_separation:
    "M(r) ==> separation(M,
         \<lambda>z. \<exists>p[M]. p\<in>r & (\<exists>x[M]. \<exists>y[M]. pair(M,x,y,p) & pair(M,y,x,z)))"
    and restrict_separation:
    "M(A) ==> separation(M, \<lambda>z. \<exists>x[M]. x\<in>A & (\<exists>y[M]. pair(M,x,y,z)))"
    and comp_separation:
    "[| M(r); M(s) |]
      ==> separation(M, \<lambda>xz. \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. \<exists>xy[M]. \<exists>yz[M].
                  pair(M,x,z,xz) & pair(M,x,y,xy) & pair(M,y,z,yz) &
                  xy\<in>s & yz\<in>r)"
    and pred_separation:
    "[| M(r); M(x) |] ==> separation(M, \<lambda>y. \<exists>p[M]. p\<in>r & pair(M,y,x,p))"
    and Memrel_separation:
    "separation(M, \<lambda>z. \<exists>x[M]. \<exists>y[M]. pair(M,x,y,z) & x \<in> y)"
    and is_recfun_separation:
    \<comment> \<open>for well-founded recursion: used to prove \<open>is_recfun_equal\<close>\<close>
    "[| M(r); M(f); M(g); M(a); M(b) |]
     ==> separation(M,
            \<lambda>x. \<exists>xa[M]. \<exists>xb[M].
                pair(M,x,a,xa) & xa \<in> r & pair(M,x,b,xb) & xb \<in> r &
                (\<exists>fx[M]. \<exists>gx[M]. fun_apply(M,f,x,fx) & fun_apply(M,g,x,gx) &
                                   fx \<noteq> gx))"
    and power_ax:         "power_ax(M)"

lemma (in M_basic_no_repl) cartprod_iff:
  "[| M(A); M(B); M(C) |]
      ==> cartprod(M,A,B,C) \<longleftrightarrow>
          (\<exists>p1[M]. \<exists>p2[M]. powerset(M,A \<union> B,p1) & powerset(M,p1,p2) &
                   C = {z \<in> p2. \<exists>x\<in>A. \<exists>y\<in>B. z = <x,y>})"
  apply (simp add: Pair_def cartprod_def, safe)
    defer 1
    apply (simp add: powerset_def)
   apply blast
  txt\<open>Final, difficult case: the left-to-right direction of the theorem.\<close>
  apply (insert power_ax, simp add: power_ax_def)
  apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
   apply (blast, clarify)
  apply (drule_tac x=z and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
   apply assumption
  apply (blast intro: cartprod_iff_lemma)
  done

lemma (in M_basic_no_repl) cartprod_closed_lemma:
  "[| M(A); M(B) |] ==> \<exists>C[M]. cartprod(M,A,B,C)"
  apply (simp del: cartprod_abs add: cartprod_iff)
  apply (insert power_ax, simp add: power_ax_def)
  apply (frule_tac x="A \<union> B" and P="\<lambda>x. rex(M,Q(x))" for Q in rspec)
   apply (blast, clarify)
  apply (drule_tac x=z and P="\<lambda>x. rex(M,Q(x))" for Q in rspec, auto)
  apply (intro rexI conjI, simp+)
  apply (insert cartprod_separation [of A B], simp)
  done

text\<open>All the lemmas above are necessary because Powerset is not absolute.
      I should have used Replacement instead!\<close>
lemma (in M_basic_no_repl) cartprod_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A*B)"
  by (frule cartprod_closed_lemma, assumption, force)

lemma (in M_basic_no_repl) sum_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A+B)"
  by (simp add: sum_def)

lemma (in M_basic_no_repl) sum_abs [simp]:
  "[| M(A); M(B); M(Z) |] ==> is_sum(M,A,B,Z) \<longleftrightarrow> (Z = A+B)"
  by (simp add: is_sum_def sum_def singleton_0 nat_into_M)

lemma (in M_basic_no_repl) M_converse_iff:
  "M(r) ==>
      converse(r) =
      {z \<in> \<Union>(\<Union>(r)) * \<Union>(\<Union>(r)).
       \<exists>p\<in>r. \<exists>x[M]. \<exists>y[M]. p = \<langle>x,y\<rangle> & z = \<langle>y,x\<rangle>}"
  apply (rule equalityI)
   prefer 2 apply (blast dest: transM, clarify, simp)
  apply (simp add: Pair_def)
  apply (blast dest: transM)
  done

lemma (in M_basic_no_repl) converse_closed [intro,simp]:
  "M(r) ==> M(converse(r))"
  apply (simp add: M_converse_iff)
  apply (insert converse_separation [of r], simp)
  done

lemma (in M_basic_no_repl) converse_abs [simp]:
  "[| M(r); M(z) |] ==> is_converse(M,r,z) \<longleftrightarrow> z = converse(r)"
  apply (simp add: is_converse_def)
  apply (rule iffI)
   prefer 2 apply blast
  apply (rule M_equalityI)
    apply simp
    apply (blast dest: transM)+
  done

subsubsection \<open>image, preimage, domain, range\<close>

lemma (in M_basic_no_repl) image_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(r``A)"
  apply (simp add: image_iff_Collect)
  apply (insert image_separation [of A r], simp)
  done

lemma (in M_basic_no_repl) vimage_abs [simp]:
  "[| M(r); M(A); M(z) |] ==> pre_image(M,r,A,z) \<longleftrightarrow> z = r-``A"
  apply (simp add: pre_image_def)
  apply (rule iffI)
   apply (blast intro!: equalityI dest: transM, blast)
  done

lemma (in M_basic_no_repl) vimage_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(r-``A)"
  by (simp add: vimage_def)

subsubsection\<open>Domain, range and field\<close>

lemma (in M_basic_no_repl) domain_closed [intro,simp]:
  "M(r) ==> M(domain(r))"
  apply (simp add: domain_eq_vimage)
  done

lemma (in M_basic_no_repl) range_closed [intro,simp]:
  "M(r) ==> M(range(r))"
  apply (simp add: range_eq_image)
  done

lemma (in M_basic_no_repl) field_abs [simp]:
  "[| M(r); M(z) |] ==> is_field(M,r,z) \<longleftrightarrow> z = field(r)"
  by (simp add: is_field_def field_def)

lemma (in M_basic_no_repl) field_closed [intro,simp]:
  "M(r) ==> M(field(r))"
  by (simp add: field_def)

subsubsection\<open>Relations, functions and application\<close>

lemma (in M_basic_no_repl) apply_closed [intro,simp]:
  "[|M(f); M(a)|] ==> M(f`a)"
  by (simp add: apply_def)

lemma (in M_basic_no_repl) apply_abs [simp]:
  "[| M(f); M(x); M(y) |] ==> fun_apply(M,f,x,y) \<longleftrightarrow> f`x = y"
  apply (simp add: fun_apply_def apply_def, blast)
  done

lemma (in M_basic_no_repl) injection_abs [simp]:
  "[| M(A); M(f) |] ==> injection(M,A,B,f) \<longleftrightarrow> f \<in> inj(A,B)"
  apply (simp add: injection_def apply_iff inj_def)
  apply (blast dest: transM [of _ A])
  done

lemma (in M_basic_no_repl) surjection_abs [simp]:
  "[| M(A); M(B); M(f) |] ==> surjection(M,A,B,f) \<longleftrightarrow> f \<in> surj(A,B)"
  by (simp add: surjection_def surj_def)

lemma (in M_basic_no_repl) bijection_abs [simp]:
  "[| M(A); M(B); M(f) |] ==> bijection(M,A,B,f) \<longleftrightarrow> f \<in> bij(A,B)"
  by (simp add: bijection_def bij_def)

subsubsection\<open>Composition of relations\<close>

lemma (in M_basic_no_repl) M_comp_iff:
  "[| M(r); M(s) |]
      ==> r O s =
          {xz \<in> domain(s) * range(r).
            \<exists>x[M]. \<exists>y[M]. \<exists>z[M]. xz = \<langle>x,z\<rangle> & \<langle>x,y\<rangle> \<in> s & \<langle>y,z\<rangle> \<in> r}"
  apply (simp add: comp_def)
  apply (rule equalityI)
   apply clarify
   apply simp
   apply  (blast dest:  transM)+
  done

lemma (in M_basic_no_repl) comp_closed [intro,simp]:
  "[| M(r); M(s) |] ==> M(r O s)"
  apply (simp add: M_comp_iff)
  apply (insert comp_separation [of r s], simp)
  done

lemma (in M_basic_no_repl) composition_abs [simp]:
  "[| M(r); M(s); M(t) |] ==> composition(M,r,s,t) \<longleftrightarrow> t = r O s"
  apply safe
  txt\<open>Proving \<^term>\<open>composition(M, r, s, r O s)\<close>\<close>
   prefer 2
   apply (simp add: composition_def comp_def)
   apply (blast dest: transM)
  txt\<open>Opposite implication\<close>
  apply (rule M_equalityI)
    apply (simp add: composition_def comp_def)
    apply (blast del: allE dest: transM)+
  done

text\<open>no longer needed\<close>
lemma (in M_basic_no_repl) restriction_is_function:
  "[| restriction(M,f,A,z); function(f); M(f); M(A); M(z) |]
      ==> function(z)"
  apply (simp add: restriction_def ball_iff_equiv)
  apply (unfold function_def, blast)
  done

lemma (in M_basic_no_repl) restrict_closed [intro,simp]:
  "[| M(A); M(r) |] ==> M(restrict(r,A))"
  apply (simp add: M_restrict_iff)
  apply (insert restrict_separation [of A], simp)
  done

lemma (in M_basic_no_repl) Inter_closed [intro,simp]:
  "M(A) ==> M(\<Inter>(A))"
  by (insert Inter_separation, simp add: Inter_def)

lemma (in M_basic_no_repl) Int_closed [intro,simp]:
  "[| M(A); M(B) |] ==> M(A \<inter> B)"
  apply (subgoal_tac "M({A,B})")
   apply (frule Inter_closed, force+)
  done

lemma (in M_basic_no_repl) Diff_closed [intro,simp]:
  "[|M(A); M(B)|] ==> M(A-B)"
  by (insert Diff_separation, simp add: Diff_def)

subsubsection\<open>Some Facts About Separation Axioms\<close>

lemma (in M_basic_no_repl) separation_conj:
  "[|separation(M,P); separation(M,Q)|] ==> separation(M, \<lambda>z. P(z) & Q(z))"
  by (simp del: separation_closed
      add: separation_iff Collect_Int_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_disj:
  "[|separation(M,P); separation(M,Q)|] ==> separation(M, \<lambda>z. P(z) | Q(z))"
  by (simp del: separation_closed
      add: separation_iff Collect_Un_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_neg:
  "separation(M,P) ==> separation(M, \<lambda>z. ~P(z))"
  by (simp del: separation_closed
      add: separation_iff Diff_Collect_eq [symmetric])

lemma (in M_basic_no_repl) separation_imp:
  "[|separation(M,P); separation(M,Q)|]
      ==> separation(M, \<lambda>z. P(z) \<longrightarrow> Q(z))"
  by (simp add: separation_neg separation_disj not_disj_iff_imp [symmetric])

text\<open>This result is a hint of how little can be done without the Reflection
  Theorem.  The quantifier has to be bounded by a set.  We also need another
  instance of Separation!\<close>
lemma (in M_basic_no_repl) separation_rall:
  "[|M(Y); \<forall>y[M]. separation(M, \<lambda>x. P(x,y));
        \<forall>z[M]. strong_replacement(M, \<lambda>x y. y = {u \<in> z . P(u,x)})|]
      ==> separation(M, \<lambda>x. \<forall>y[M]. y\<in>Y \<longrightarrow> P(x,y))"
  apply (simp del: separation_closed rall_abs
      add: separation_iff Collect_rall_eq)
  apply (blast intro!:  RepFun_closed dest: transM)
  done

subsubsection\<open>Functions and function space\<close>

lemma (in M_basic_no_repl) succ_fun_eq2:
  "[|M(B); M(n->B)|] ==>
      succ(n) -> B =
      \<Union>{z. p \<in> (n->B)*B, \<exists>f[M]. \<exists>b[M]. p = <f,b> & z = {cons(<n,b>, f)}}"
  apply (simp add: succ_fun_eq)
  apply (blast dest: transM)
  done

lemma (in M_basic_no_repl) list_case'_closed [intro,simp]:
  "[|M(k); M(a); \<forall>x[M]. \<forall>y[M]. M(b(x,y))|] ==> M(list_case'(a,b,k))"
  apply (case_tac "quasilist(k)")
   apply (simp add: quasilist_def, force)
  apply (simp add: non_list_case)
  done

lemma (in M_basic_no_repl) tl'_closed: "M(x) ==> M(tl'(x))"
  apply (simp add: tl'_def)
  apply (force simp add: quasilist_def)
  done

sublocale M_basic \<subseteq> mbnr:M_basic_no_repl
  using Inter_separation Diff_separation cartprod_separation image_separation
    converse_separation restrict_separation comp_separation pred_separation
    Memrel_separation is_recfun_separation power_ax by unfold_locales

end


theory Proof_3_6
  imports Proofs_3
begin

thm VC6_def

context
  fixes s2 s0:: state
fixes user_value pressure_value:: bool
assumes toEnvPs2:  "toEnvP s2 \<and> toEnvP s0" and extraInvs0: "extraInv s0"
and vc: " env (setVarAny s0 user_value pressure_value) \<and>
         getPstate (setVarAny s0 user_value pressure_value) ERROR = Controller'rotating \<and>
 getVarBool (setVarAny s0 user_value pressure_value) pressure \<and>
\<not> DELAY'TIMEOUT
   \<le> ltime
       (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
         Controller'suspended)
       ERROR"
begin

lemma VC6_R3_ind_step_aux1: " toEnvP s2a \<Longrightarrow>
         substate s2 s2a \<and>
         substate s2a
        (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
         s2 \<noteq> s2a \<Longrightarrow>
         substate s1 s2 \<and>
         substate s2
          (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
         toEnvP s1 \<and>
         toEnvP s2 \<and>
         toEnvNum s1 s2 = ERROR \<and>
         DELAY'TIMEOUT =
         toEnvNum s2
          (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
         getVarBool s1 rotation = True \<and>
         \<not> getVarBool s2 user \<and>
         (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s2a \<and> s4 \<noteq> s2a \<longrightarrow>
               getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
         (\<exists>s4. toEnvP s4 \<and>
               substate s2a s4 \<and>
               substate s4
                (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
               toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
               (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
               (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                     getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)) \<Longrightarrow>
         substate s1 s2 \<and>
         substate s2
         (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))\<and>
         toEnvP s1 \<and>
         toEnvP s2 \<and>
         toEnvNum s1 s2 = ERROR \<and>
         DELAY'TIMEOUT =
         toEnvNum s2
         (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
         getVarBool s1 rotation = True \<and>
         \<not> getVarBool s2 user \<and>
         (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 (predEnv s2a) \<and> s4 \<noteq> predEnv s2a \<longrightarrow>
               getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<Longrightarrow>
         \<not> (getVarBool (predEnv s2a) rotation = False \<or> getVarBool (predEnv s2a) user) \<Longrightarrow>
         toEnvP x \<and>
         substate s2a x \<and>
         substate x
         (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
         toEnvNum s2 x \<le> DELAY'TIMEOUT \<and>
         (getVarBool x rotation = False \<or> getVarBool x user) \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 x \<and> s3 \<noteq> x \<longrightarrow>
               getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user) \<Longrightarrow>
         \<exists>s4. toEnvP s4 \<and>
              substate (predEnv s2a) s4 \<and>
              substate s4
              (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
              toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
              (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
              (\<forall>s3. toEnvP s3 \<and> substate (predEnv s2a) s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)"
  apply(rule exI[of _ x])
  by (smt (z3) predEnv_substate predEnv_substate_imp_eq_or_substate substate_trans)

lemma VC6_R3_ind_step: " toEnvP s2a \<Longrightarrow>
           substate s2 s2a \<and>
           substate s2a
           (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
           s2 \<noteq> s2a \<Longrightarrow>
           substate s1 s2 \<and>
           substate s2
           (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
           toEnvP s1 \<and>
           toEnvP s2 \<and>
           toEnvNum s1 s2 = ERROR \<and>
           DELAY'TIMEOUT =
           toEnvNum s2
            (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
           getVarBool s1 rotation = True \<and>
           \<not> getVarBool s2 user \<and>
           (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s2a \<and> s4 \<noteq> s2a \<longrightarrow>
                 getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
           (\<exists>s4. toEnvP s4 \<and>
                 substate s2a s4 \<and>
                 substate s4
                 (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
                 toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                 (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                 (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                       getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)) \<Longrightarrow>
           substate s1 s2 \<and>
           substate s2
           (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
           toEnvP s1 \<and>
           toEnvP s2 \<and>
           toEnvNum s1 s2 = ERROR \<and>
           DELAY'TIMEOUT =
           toEnvNum s2
            (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
           getVarBool s1 rotation = True \<and>
           \<not> getVarBool s2 user \<and>
           (\<forall>s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 (predEnv s2a) \<and> s4 \<noteq> predEnv s2a \<longrightarrow>
                 getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user) \<longrightarrow>
           (\<exists>s4. toEnvP s4 \<and>
                 substate (predEnv s2a) s4 \<and>
                 substate s4
                 (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
                 toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                 (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                 (\<forall>s3. toEnvP s3 \<and> substate (predEnv s2a) s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                       getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"
  apply(rule impI)
  apply(cases "(getVarBool (predEnv s2a) rotation = False \<or> getVarBool (predEnv s2a) user)")
   apply(rule exI[of _ "predEnv s2a"])
   apply(rule conjI)
    apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
  using toEnvPs2 substate_eq_or_predEnv apply fast
   apply(rule conjI)
  using substate_refl apply fast
   apply(rule conjI)
  using predEnv_substate substate_trans apply fast
   apply(rule conjI)
    apply(rule cut_rl[of "substate s2 (predEnv s2a) \<and>
 substate (predEnv s2a)
(toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))"])
  using toEnvNum3[of s2 "predEnv s2a"
"(toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))"]
     apply arith
  using substate_eq_or_predEnv predEnv_substate substate_trans apply fast
   apply(rule conjI)
    apply assumption
  using substate_asym apply fast
  apply(rule exE[of "\<lambda> s4. toEnvP s4 \<and>
          substate s2a s4 \<and>
          substate s4
          (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended)) \<and>
          toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
          (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
          (\<forall>s3. toEnvP s3 \<and> substate s2a s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)"])
  using substate_eq_or_predEnv apply blast
  by (rule VC6_R3_ind_step_aux1)

lemma VC6_R3_ind_proof:   "toEnvP s5 \<and>  substate s2 s5 \<and>
 substate s5 (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))
 \<longrightarrow> pred3 s1 s2 (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))
 s5"
  apply(induction rule: state_down_ind)
  using toEnvPs2 apply simp
   apply(simp only: pred3_def)
   apply(rule impI)
  apply(rule exI[of _ "(toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) Controller
     Controller'suspended))"])
   apply(rule conjI)
    apply simp
   apply(rule conjI)
    apply simp
apply(rule conjI)
    apply simp
apply(rule conjI)
    apply simp
apply(rule conjI)
    apply simp
  using substate_asym apply blast
   apply(simp only: pred3_def)
  by ((rule VC6_R3_ind_step);fast)
end

lemma VC6_R3: " (((((toEnvP s0 \<and>
            (\<forall>s1 s2.
                substate s1 s2 \<and>
                substate s2 s0 \<and>
                toEnvP s1 \<and>
                toEnvP s2 \<and>
                toEnvNum s1 s2 = ERROR \<and>
                DELAY'TIMEOUT \<le> toEnvNum s2 s0 \<and> getVarBool s1 rotation = True \<and> \<not> getVarBool s2 user \<longrightarrow>
                (\<exists>s4. toEnvP s4 \<and>
                      substate s2 s4 \<and>
                      substate s4 s0 \<and>
                      toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                      (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                      (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                            getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user)))) \<and>
           extraInv s0) \<and>
          env (setVarAny s0 user_value pressure_value)) \<and>
         getPstate (setVarAny s0 user_value pressure_value) ERROR = Controller'rotating) \<and>
        getVarBool (setVarAny s0 user_value pressure_value) pressure) \<and>
       \<not> DELAY'TIMEOUT
          \<le> ltime
              (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True)
                ERROR Controller'suspended)
              ERROR \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2
        (toEnv
          (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
            Controller'suspended)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = ERROR \<and>
       DELAY'TIMEOUT
       \<le> toEnvNum s2
           (toEnv
             (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True)
               ERROR Controller'suspended)) \<and>
       getVarBool s1 rotation = True \<and> \<not> getVarBool s2 user \<longrightarrow>
       (\<exists>s4. toEnvP s4 \<and>
             substate s2 s4 \<and>
             substate s4
              (toEnv
                (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True)
                  ERROR Controller'suspended)) \<and>
             toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
             (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
             (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                   getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"
  apply(rule impI)
  apply(rule disjE[of "DELAY'TIMEOUT < toEnvNum s2 (toEnv
          (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
            Controller'suspended))"
"DELAY'TIMEOUT = toEnvNum s2 (toEnv
          (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
            Controller'suspended))"])
  using le_imp_less_or_eq apply fast
   apply(rule cut_rl[of "substate s2 s0 \<and> toEnvNum s2 s0 \<ge> DELAY'TIMEOUT"])
  apply(rule cut_rl[of "(\<exists>s4. toEnvP s4 \<and>
                   substate s2 s4 \<and>
                   substate s4 s0 \<and>
                   toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
                   (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
                   (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                         getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"])
  apply (metis substate.simps(10) substate.simps(2) substate.simps(3) substate.simps(9))
    apply blast
   apply(simp split: if_splits)
  apply(rule cut_rl[of "pred3 s1 s2
 (toEnv
          (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
            Controller'suspended))
s2"])
   apply(simp only: pred3_def)
   apply (smt (z3) substate_asym)
   apply(rule mp[of "toEnvP s2 \<and>  substate s2 s2 \<and>
 substate s2 (toEnv
          (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) rotation False) brake True) ERROR
            Controller'suspended))"])
   apply((rule VC6_R3_ind_proof);blast)
  using substate_refl by fast

theorem proof_3_6: "VC6 inv3 env s0 user_value pressure_value"
  apply(simp only: VC6_def inv3_def R3_def)
  apply(rule impI)
  apply(rule conjI)
  apply(rule conjI)
   apply(simp)
   apply((rule allI);(rule allI))
  print_state
   apply((rule VC6_R3);blast)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               February 2006               |
            |                  April 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                  May 2016  (modified)     |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_nf_def
imports CSP_F_Main
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)
(* Isabelle 2017: split_if --> if_split *)

declare if_split  [split del]

(*****************************************************************

         1. definition of full normalisation
         2.
         3.

 *****************************************************************)

(*----------------------------------------------------------------------*
 |                         full normal form                             |
 *----------------------------------------------------------------------*)

definition
  fnfF_set_condition  :: "'a set => 'a set set => bool"
  where
  fnfF_set_condition_def :
   "fnfF_set_condition A Ys ==
    (ALL Y. ((EX Y0:Ys. Y0 <= Y) & Y <= A Un Union Ys) --> Y:Ys)"

definition
  fnfF_set_completion :: "'a set => 'a set set => 'a set set"
  where
  fnfF_set_completion_def :
   "fnfF_set_completion A Ys == {Y. (EX Y0:Ys. Y0 <= Y) & Y <= (A Un Union Ys)}"

(* Isabelle 2005
consts
  fnfF_proc      :: "('p,'a) proc set"

inductive "fnfF_proc"
intros
fnfF_proc_rule:
  "[| (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) ;
      fnfF_set_condition A Ys ; Union Ys <= A ;
      Q = SKIP | Q = DIV |]
   ==> ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV))
        : fnfF_proc"
*)

inductive_set
  fnfF_proc      :: "('p,'a) proc set"
where
fnfF_proc_rule:
  "[| (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) ;
      fnfF_set_condition A Ys ; Union Ys <= A ;
      Q = SKIP | Q = DIV |]
   ==> ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV))
        : fnfF_proc"

(* .elims ---> .cases *)

definition
  XfnfF_proc           :: "('p,'a) proc set"
  where
  XfnfF_proc_def :
   "XfnfF_proc == {!nat n .. Pf n |Pf.
                  (ALL n. Pf n =F (!nat n .. Pf n) |. n) &
                  (ALL n. Pf n : fnfF_proc) }"

(*** convenient lemmas ***)

lemma fnfF_set_completion_sat_condition[simp]:
  "fnfF_set_condition A (fnfF_set_completion A Ys)"
apply (simp add: fnfF_set_condition_def)
apply (intro allI impI)
apply (elim conjE bexE)

apply (simp add: fnfF_set_completion_def)
apply (elim conjE bexE)
apply (rule conjI)
apply (rule_tac x="Y0a" in bexI)
apply (simp)
apply (simp)

apply (rule subsetI)
apply (erule subsetE)
apply (drule_tac x="x" in bspec, simp)
apply (simp)
apply (elim disjE conjE exE bexE)
apply (simp)

apply (rotate_tac 5)
apply (erule subsetE)
apply (simp)
done

lemma fnfF_set_completion_subset:
  "Ys <= fnfF_set_completion A Ys"
by (auto simp add: fnfF_set_completion_def)

lemma fnfF_set_completion_Union_subset:
  "Union Ys <= A ==>
   Union (fnfF_set_completion A Ys) <= A"
apply (auto simp add: fnfF_set_completion_def)
apply (subgoal_tac "x : A Un Union Ys")
apply (simp)
apply (erule disjE)
apply (auto)
done

(*----------------------------------------------------------*
 |                   intro, elim, simp                      |
 *----------------------------------------------------------*)

lemma fnfF_proc_iff:
  "(NP : fnfF_proc) =
     (EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))"
apply (rule iffI)

(* => *)
(* apply (erule fnfF_proc.elims) *)
 apply (erule fnfF_proc.cases)
 apply (force)

(* <= *)
 apply (elim conjE exE)
 apply (simp add: fnfF_proc.intros)
done

lemma fnfF_proc_EX_I:
     "(EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))
    ==> NP : fnfF_proc"
apply (simp add: fnfF_proc_iff[of NP])
done

lemma fnfF_proc_EX_E:
  "[| NP : fnfF_proc ;
     (EX A Ys Pf Q.
      NP = ((? :A -> Pf) [+] Q) |~| (!set Y:Ys .. (? a:Y -> DIV)) &
      (ALL a. if a:A then Pf a : fnfF_proc else Pf a = DIV) &
       fnfF_set_condition A Ys & Union Ys <= A &
       (Q = SKIP | Q = DIV))
      ==> S |]
    ==> S"
apply (simp add: fnfF_proc_iff[of NP])
done

(*----------------------------------------------------------*
 |                 ALL fnfF_proc_iff                   |
 *----------------------------------------------------------*)

lemma ALL_fnfF_proc_only_if:
  "ALL x:X. NPf x : fnfF_proc
   ==>
     (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))"
apply (simp add: fnfF_proc_iff)
apply (simp add: choice_BALL_EX)
apply (elim exE)
apply (rule_tac x="f" in exI)
apply (rule_tac x="fa" in exI)
apply (rule_tac x="fb" in exI)
apply (rule_tac x="fc" in exI)

(* NPf *)
apply (rule conjI)
apply (simp add: fun_eq_iff)
apply (rule allI)
apply (case_tac "x:X")
apply (simp_all)

apply (intro allI ballI)
apply (drule_tac x="x" in bspec, simp)
apply (elim conjE)
apply (drule_tac x="a" in spec)
apply (simp)
done

lemma ALL_fnfF_proc_iff:
  "(ALL x:X. NPf x : fnfF_proc)
   =
     (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))"
apply (rule)
apply (simp add: ALL_fnfF_proc_only_if)

apply (elim conjE exE)
apply (intro ballI)
apply (simp add: fun_eq_iff)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in bspec, simp)+
apply (simp)
apply (simp add: fnfF_proc.intros)
done

lemma ALL_fnfF_procI:
  "(EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))
   ==> ALL x:X. NPf x : fnfF_proc"
apply (simp add: ALL_fnfF_proc_iff)
done

lemma ALL_fnfF_procE:
  "[| ALL x:X. NPf x : fnfF_proc ;
      (EX Af Ysf Pff Qf.
      NPf = (%x. if x:X then (((? :(Af x) -> (Pff x)) [+] Qf x) |~|
                             (!set Y:(Ysf x) .. (? a:Y -> DIV)))
                        else NPf x) &
      (ALL x:X. ALL a. if a:(Af x) then (Pff x a) : fnfF_proc
                       else (Pff x a) = DIV) &
      (ALL x:X. fnfF_set_condition (Af x) (Ysf x)) &
      (ALL x:X. Union (Ysf x) <= Af x) &
      (ALL x:X. Qf x = SKIP | Qf x = DIV))
   ==> S |] ==> S"
apply (simp add: ALL_fnfF_proc_iff)
done

(*======================================================*
 |         function to decompose : fnfF_decompo         |
 *======================================================*)
(*
isabelle 2011

consts
  fnfF_A ::
     "('p,'a) proc => ('a set)"
  fnfF_Ys ::
     "('p,'a) proc => ('a set set)"
  fnfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
  fnfF_Q ::
     "('p,'a) proc => ('p,'a) proc"

(* they are partial functions *)

recdef fnfF_A "{}"
  "fnfF_A (((? :A -> Pf) [+] Q) |~| R) = A"

recdef fnfF_Ys "{}"
  "fnfF_Ys (P |~| !! : type1 Ys .. Pf) = Ys"

recdef fnfF_Pf "{}"
  "fnfF_Pf (((? :A -> Pf) [+] Q) |~| R) = Pf"

recdef fnfF_Q "{}"
  "fnfF_Q (((? :A -> Pf) [+] Q) |~| R) = Q"
*)

(* they are partial functions *)

fun
  fnfF_A ::
     "('p,'a) proc => ('a set)"
where
  "fnfF_A (((? :A -> Pf) [+] Q) |~| R) = A"

fun
  fnfF_Ys ::
     "('p,'a) proc => ('a set set)"
where
  "fnfF_Ys (P |~| !! : type1 Ys .. Pf) = Ys"

fun
  fnfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
where
  "fnfF_Pf (((? :A -> Pf) [+] Q) |~| R) = Pf"

fun
  fnfF_Q ::
     "('p,'a) proc => ('p,'a) proc"
where
  "fnfF_Q (((? :A -> Pf) [+] Q) |~| R) = Q"

lemma fnfF_Ys_get[simp]:
  "fnfF_Ys (P |~| !set :Ys .. Pf) = Ys"
by (simp add: Rep_int_choice_ss_def)

(*------------------------*
 |     decomposition      |
 *------------------------*)

lemma cspF_fnfF_nat_decompo:
   "P : fnfF_proc ==>
    P =F ((? : (fnfF_A P) -> (fnfF_Pf P)) [+] fnfF_Q P)
         |~| (!set Y: fnfF_Ys P .. (? a:Y -> DIV))"
(* apply (erule fnfF_proc.elims) *)
apply (erule fnfF_proc.cases)
apply (simp)
done

(*--------------------------------------*
 |   properties of fnfF decomposition   |
 *--------------------------------------*)

lemma fnfF_Pf_A:
   "[| P : fnfF_proc ; a : (fnfF_A P) |]
    ==> (fnfF_Pf P) a : fnfF_proc"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Pf_DIV:
   "[| P : fnfF_proc ; a ~: (fnfF_A P) |]
    ==> (fnfF_Pf P) a = DIV"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Q_range:
   "P : fnfF_proc
    ==> (fnfF_Q P) = SKIP | (fnfF_Q P) = DIV"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_condition_A_Ys:
   "P : fnfF_proc ==>
    fnfF_set_condition (fnfF_A P) (fnfF_Ys P)"
apply (erule fnfF_proc.cases)
apply (simp)
done

lemma fnfF_Union_Ys_A:
   "P : fnfF_proc ==>
    Union (fnfF_Ys P)  <= (fnfF_A P)"
apply (erule fnfF_proc.cases)
apply (simp)
done

(*-----------------------*
 |    DIV, SKIP, STOP    |
 *-----------------------*)

definition
  NSKIP     :: "('p,'a) proc"
  where
  NSKIP_def : "NSKIP == ((? a:{} -> DIV) [+] SKIP) |~| (!set Y:{} .. (? a:Y -> DIV))"

definition
  NDIV      :: "('p,'a) proc"
  where
  NDIV_def  : "NDIV  == ((? a:{} -> DIV) [+] DIV)  |~| (!set Y:{} .. (? a:Y -> DIV))"

definition
  NSTOP     :: "('p,'a) proc"
  where
  NSTOP_def : "NSTOP == ((? a:{} -> DIV) [+] DIV)  |~| (!set Y:{{}} .. (? a:Y -> DIV))"

(*** in fnfF ***)

lemma fnfF_NSKIP[simp]: "NSKIP : fnfF_proc"
apply (simp add: NSKIP_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

lemma fnfF_NDIV[simp]: "NDIV : fnfF_proc"
apply (simp add: NDIV_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

lemma fnfF_NSTOP[simp]: "NSTOP : fnfF_proc"
apply (simp add: NSTOP_def)
apply (rule fnfF_proc.intros)
apply (simp_all add: fnfF_set_condition_def)
done

(*** eqF ***)

lemma cspF_NSKIP_eqF: "SKIP =F NSKIP"
apply (simp add: NSKIP_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)
done

lemma cspF_NDIV_eqF: "DIV =F NDIV"
apply (simp add: NDIV_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)
done

lemma cspF_NSTOP_eqF: "STOP =F NSTOP"
apply (simp add: NSTOP_def)
apply (rule cspF_rw_right)
apply (rule cspF_decompo)
apply (rule cspF_choice_rule)
apply (rule cspF_Rep_int_choice_singleton)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_step)
done

(*==============================================================*
 |               convenient rules for fnfF                      |
 *==============================================================*)

lemma cspF_fnfF_Depth_rest_dist:
  "Q = SKIP | Q = DIV ==>
   (? :A -> Pf [+] Q
   |~| !set Y:Ys .. ? a:Y -> DIV) |. Suc n
  =F
   (? a:A -> (Pf a |. n) [+] Q
   |~| !set Y:Ys .. ? a:Y -> DIV)"
apply (rule cspF_rw_left)
apply (rule cspF_dist)
apply (rule cspF_decompo)
apply (rule cspF_rw_left)
apply (rule cspF_Ext_dist)
apply (rule cspF_decompo)
apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_reflex)
apply (erule disjE)
apply (simp_all)

apply (rule cspF_rw_left)
apply (rule cspF_Dist)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_DIV_Depth_rest)
done

(* left DIV *)

lemma cspF_fsfF_left_DIV:
  "(? a:{} -> DIV [+] DIV) |~| P =F P"
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (rule cspF_Ext_choice_rule)
apply (rule cspF_reflex)
apply (rule cspF_unit)
done

lemma cspF_fsfF_right_DIV:
  "P |~| (!set :{} .. Pf) =F P"
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (rule cspF_reflex)
apply (rule cspF_Rep_int_choice_DIV)
apply (rule cspF_unit)
done

(****************** to add them again ******************)

declare if_split    [split]
declare disj_not1   [simp]

end


section\<open>Option Helpers\<close>
text\<open>These definitions were contributed by Peter Lammich.\<close>
theory Option_Helpers
imports Main "~~/src/HOL/Library/Monad_Syntax"
begin

primrec oassert :: "bool \<Rightarrow> unit option" where
  "oassert True = Some ()" | "oassert False = None"

lemma oassert_iff[simp]:
  "oassert \<Phi> = Some x \<longleftrightarrow> \<Phi>"
  "oassert \<Phi> = None \<longleftrightarrow> \<not>\<Phi>"
  by (cases \<Phi>) auto

text\<open>The idea is that we want the result of some computation to be @{term "Some v"} and the contents of @{term v} to satisfy some property @{term Q}.\<close>

primrec ospec :: "('a option) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "ospec None _ = False"
| "ospec (Some v) Q = Q v"

named_theorems ospec_rules

lemma oreturn_rule[ospec_rules]: "\<lbrakk> P r \<rbrakk> \<Longrightarrow> ospec (Some r) P" by simp

lemma obind_rule[ospec_rules]: "\<lbrakk> ospec m Q; \<And>r. Q r \<Longrightarrow> ospec (f r) P \<rbrakk> \<Longrightarrow> ospec (m \<bind> f) P"
  apply (cases m)
   apply (auto split: Option.bind_splits)
  done

lemma ospec_alt: "ospec m P = (case m of None \<Rightarrow> False | Some x \<Rightarrow> P x)"
  by (auto split: option.splits)

lemma ospec_bind_simp: "ospec (m \<bind> f) P \<longleftrightarrow> (ospec m (\<lambda>r. ospec (f r) P))"
  apply (cases m)
   apply (auto split: Option.bind_splits)
  done

lemma ospec_cons:
  assumes "ospec m Q"
  assumes "\<And>r. Q r \<Longrightarrow> P r"
  shows "ospec m P"
  using assms by (cases m) auto

lemma oreturn_synth: "ospec (Some x) (\<lambda>r. r=x)" by simp

lemma ospecD: "ospec x P \<Longrightarrow> x = Some y \<Longrightarrow> P y" by simp
lemma ospecD2: "ospec x P \<Longrightarrow> \<exists>y. x = Some y \<and> P y" by(cases x) simp_all

end


section \<open> Semantic Model for Stateful-Failures \<close>

theory utp_action_circus
  imports "UTP1-Stateful-Failures.utp_sf_rdes" utp_action_language
begin

fun sfrd_sem :: "('s, 'e) Action \<Rightarrow> ('s, 'e) action" ("\<lbrakk>_\<rbrakk>\<^sub>C") where
"\<lbrakk>P ; Q\<rbrakk>\<^sub>C = \<lbrakk>P\<rbrakk>\<^sub>C ;; \<lbrakk>Q\<rbrakk>\<^sub>C" |
"\<lbrakk>if b then P else Q end\<rbrakk>\<^sub>C = \<lbrakk>P\<rbrakk>\<^sub>C \<triangleleft> b \<triangleright>\<^sub>R \<lbrakk>Q\<rbrakk>\<^sub>C" |
"\<lbrakk>intchoice P Q\<rbrakk>\<^sub>C = \<lbrakk>P\<rbrakk>\<^sub>C \<sqinter> \<lbrakk>Q\<rbrakk>\<^sub>C" |
"\<lbrakk>assigns \<sigma>\<rbrakk>\<^sub>C = \<langle>\<sigma>\<rangle>\<^sub>C" |
"\<lbrakk>stop\<rbrakk>\<^sub>C = Stop" |
"\<lbrakk>event E\<rbrakk>\<^sub>C = (\<box> e\<in>UNIV \<bullet> ev_pred E e &\<^sub>C do\<^sub>C(\<guillemotleft>e\<guillemotright>) ;; \<langle>ev_update E e\<rangle>\<^sub>C)" |
"\<lbrakk>extchoice P Q\<rbrakk>\<^sub>C = (\<lbrakk>P\<rbrakk>\<^sub>C \<box> \<lbrakk>Q\<rbrakk>\<^sub>C)" |
"\<lbrakk>guard b P\<rbrakk>\<^sub>C = (b &\<^sub>C \<lbrakk>P\<rbrakk>\<^sub>C)"

lemma sfrd_sem_NCSP [closure]: "\<lbrakk>A\<rbrakk>\<^sub>C is NCSP"
  by (induct A, simp_all add: closure)

definition sfrd_semantics :: "('s, 'e, ('s, 'e) sfrd \<times> ('s, 'e) sfrd) Action_Semantics" where
"sfrd_semantics = \<lparr> act_sem = sfrd_sem, act_hcond = NCSP \<rparr>"

interpretation sfrd_semantic: action_semantics sfrd_semantics
  by (unfold_locales,
      simp_all add: sfrd_semantics_def asem_eq_def skips_def csp_theory.Unit_Left
      csp_theory.Unit_Right AssignsCSP_id seqr_assoc cond_st_true cond_st_false closure)

end