(*  File:       Loop_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>Loop Composition\<close>

theory Loop_Composition
  imports "Basic_Modules/Component_Types/Termination_Condition"
          "Basic_Modules/Defer_Module"
          Sequential_Composition
begin

text
\<open>The loop composition uses the same module in sequence,
combined with a termination condition, until either
  (1) the termination condition is met or
  (2) no new decisions are made (i.e., a fixed point is reached).\<close>

subsection \<open>Definition\<close>

lemma loop_termination_helper:
  assumes
    not_term: "\<not>t (acc A p)" and
    subset: "defer (acc \<triangleright> m) A p \<subset> defer acc A p" and
    not_inf: "\<not>infinite (defer acc A p)"
  shows
    "((acc \<triangleright> m, m, t, A, p), (acc, m, t, A, p)) \<in>
        measure (\<lambda>(acc, m, t, A, p). card (defer acc A p))"
  using assms psubset_card_mono
  by auto

(*
   This function handles the accumulator for the following loop composition
   function.
*)
function loop_comp_helper ::
    "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
        'a Termination_Condition \<Rightarrow> 'a Electoral_Module" where
  "t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
    infinite (defer acc A p) \<Longrightarrow>
      loop_comp_helper acc m t A p = acc A p" |
  "\<not>(t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
    infinite (defer acc A p)) \<Longrightarrow>
      loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
proof -
  fix
    P :: bool and
    x :: "('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
          ('a Termination_Condition) \<times> 'a set \<times> 'a Profile"
  assume
    a1: "\<And>t acc A p m.
          \<lbrakk>t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
              infinite (defer acc A p);
            x = (acc, m, t, A, p)\<rbrakk> \<Longrightarrow> P" and
    a2: "\<And>t acc A p m.
          \<lbrakk>\<not> (t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
              infinite (defer acc A p));
            x = (acc, m, t, A, p)\<rbrakk> \<Longrightarrow> P"
  have "\<exists>f A p p2 g. (g, f, p, A, p2) = x"
    using prod_cases5
    by metis
  then show P
    using a2 a1
    by (metis (no_types))
next
  show
    "\<And>t acc A p m ta acca Aa pa ma.
       t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
        infinite (defer acc A p) \<Longrightarrow>
          ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
          infinite (defer acca Aa pa) \<Longrightarrow>
           (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
              acc A p = acca Aa pa"
    by fastforce
next
  show
    "\<And>t acc A p m ta acca Aa pa ma.
       t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
        infinite (defer acc A p) \<Longrightarrow>
          \<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
          infinite (defer acca Aa pa)) \<Longrightarrow>
           (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
              acc A p = loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
  proof -
    fix
      t :: "'a Termination_Condition" and
      acc :: "'a Electoral_Module" and
      A :: "'a set" and
      p :: "'a Profile" and
      m :: "'a Electoral_Module" and
      ta :: "'a Termination_Condition" and
      acca :: "'a Electoral_Module" and
      Aa :: "'a set" and
      pa :: "'a Profile" and
      ma :: "'a Electoral_Module"
    assume
      a1: "t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
            infinite (defer acc A p)" and
      a2: "\<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
            infinite (defer acca Aa pa))" and
      "(acc, m, t, A, p) = (acca, ma, ta, Aa, pa)"
    hence False
      using a2 a1
      by force
  thus "acc A p = loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
    by auto
qed
next
  show
    "\<And>t acc A p m ta acca Aa pa ma.
       \<not> (t (acc A p) \<or> \<not> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<or>
          infinite (defer acc A p)) \<Longrightarrow>
           \<not> (ta (acca Aa pa) \<or> \<not> defer (acca \<triangleright> ma) Aa pa \<subset> defer acca Aa pa \<or>
            infinite (defer acca Aa pa)) \<Longrightarrow>
             (acc, m, t, A, p) = (acca, ma, ta, Aa, pa) \<Longrightarrow>
                loop_comp_helper_sumC (acc \<triangleright> m, m, t, A, p) =
                  loop_comp_helper_sumC (acca \<triangleright> ma, ma, ta, Aa, pa)"
    by force
qed
termination
proof -
  have f0:
    "\<exists>r. wf r \<and>
        (\<forall>p f (A::'a set) prof g.
          p (f A prof) \<or>
          \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<or>
          infinite (defer f A prof) \<or>
          ((f \<triangleright> g, g, p, A, prof), (f, g, p, A, prof)) \<in> r)"
    using loop_termination_helper wf_measure "termination"
    by (metis (no_types))
  hence
    "\<forall>r p.
      Ex ((\<lambda>ra. \<forall>f (A::'a set) prof pa g.
            \<exists>prof2 pb p_rel pc pd h (B::'a set) prof3 i pe.
        \<not> wf r \<or>
          loop_comp_helper_dom
            (p::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
              (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
          infinite (defer f A prof) \<or>
          pa (f A prof) \<and>
            wf
              (prof2::((
                ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
                ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times> _) set) \<and>
            \<not> loop_comp_helper_dom (pb::
                ('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
          wf p_rel \<and> \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<and>
            \<not> loop_comp_helper_dom
                (pc::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                  (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
            ((f \<triangleright> g, g, pa, A, prof), f, g, pa, A, prof) \<in> p_rel \<and> wf p_rel \<and>
            \<not> loop_comp_helper_dom
                (pd::('a Electoral_Module) \<times> (_ Electoral_Module) \<times>
                  (_ Termination_Condition) \<times> _ set \<times> _ Profile) \<or>
            finite (defer h B prof3) \<and>
            defer (h \<triangleright> i) B prof3 \<subset> defer h B prof3 \<and>
            \<not> pe (h B prof3) \<and>
            ((h \<triangleright> i, i, pe, B, prof3), h, i, pe, B, prof3) \<notin> r)::
          ((('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
            ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times>
            ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
            ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) set \<Rightarrow> bool)"
    by metis
  obtain
    p_rel ::  "((('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
               ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) \<times>
               ('a Electoral_Module) \<times> ('a Electoral_Module) \<times>
               ('a Termination_Condition) \<times> 'a set \<times> 'a Profile) set" where
      "wf p_rel \<and>
        (\<forall>p f A prof g. p (f A prof) \<or>
          \<not> defer (f \<triangleright> g) A prof \<subset> defer f A prof \<or>
          infinite (defer f A prof) \<or>
          ((f \<triangleright> g, g, p, A, prof), f, g, p, A, prof) \<in> p_rel)"
    using f0
    by presburger
  thus ?thesis
    using "termination"
    by metis
qed

lemma loop_comp_code_helper[code]:
  "loop_comp_helper acc m t A p =
    (if (t (acc A p) \<or> \<not>((defer (acc \<triangleright> m) A p) \<subset> (defer acc A p)) \<or>
      infinite (defer acc A p))
    then (acc A p) else (loop_comp_helper (acc \<triangleright> m) m t A p))"
  by simp

function loop_composition ::
    "'a Electoral_Module \<Rightarrow> 'a Termination_Condition \<Rightarrow>
        'a Electoral_Module" where
  "t ({}, {}, A) \<Longrightarrow>
    loop_composition m t A p = defer_module A p" |
  "\<not>(t ({}, {}, A)) \<Longrightarrow>
    loop_composition m t A p = (loop_comp_helper m m t) A p"
  by (fastforce, simp_all)
termination
  using  "termination" wf_empty
  by blast

abbreviation loop ::
  "'a Electoral_Module \<Rightarrow> 'a Termination_Condition \<Rightarrow> 'a Electoral_Module"
    ("_ \<circlearrowleft>\<^sub>_" 50) where
  "m \<circlearrowleft>\<^sub>t \<equiv> loop_composition m t"

lemma loop_comp_code[code]:
  "loop_composition m t A p =
    (if (t ({},{},A))
    then (defer_module A p) else (loop_comp_helper m m t) A p)"
  by simp

lemma loop_comp_helper_imp_partit:
  assumes
    module_m: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "electoral_module acc \<and> (n = card (defer acc A p)) \<Longrightarrow>
        well_formed A (loop_comp_helper acc m t A p)"
proof (induct arbitrary: acc rule: less_induct)
  case (less)
  have
    "\<forall>(f::'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) g.
      (electoral_module f \<and> electoral_module g) \<longrightarrow>
        electoral_module (f \<triangleright> g)"
    by auto
  hence "electoral_module (acc \<triangleright> m)"
    using less.prems module_m
    by metis
  hence wf_acc:
    "\<not> t (acc A p) \<and> \<not> t (acc A p) \<and>
      defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
      finite (defer acc A p) \<longrightarrow>
        well_formed A (loop_comp_helper acc m t A p)"
    using less.hyps less.prems loop_comp_helper.simps(2)
          psubset_card_mono
  by metis
  have "well_formed A (acc A p)"
    using electoral_module_def less.prems profile
    by blast
  thus ?case
    using wf_acc loop_comp_helper.simps(1)
    by (metis (no_types))
qed

subsection \<open>Soundness\<close>

theorem loop_comp_sound:
  assumes m_module: "electoral_module m"
  shows "electoral_module (m \<circlearrowleft>\<^sub>t)"
  using def_mod_sound electoral_module_def loop_composition.simps(1)
        loop_composition.simps(2) loop_comp_helper_imp_partit m_module
  by metis

lemma loop_comp_helper_imp_no_def_incr:
  assumes
    module_m: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "(electoral_module acc \<and> n = card (defer acc A p)) \<Longrightarrow>
        defer (loop_comp_helper acc m t) A p \<subseteq> defer acc A p"
proof (induct arbitrary: acc rule: less_induct)
  case (less)
  have emod_acc_m: "electoral_module (acc \<triangleright> m)"
    using less.prems module_m
    by simp
  have "\<forall>A Aa. infinite (A::'a set) \<or> \<not> Aa \<subset> A \<or> card Aa < card A"
    using psubset_card_mono
    by metis
  hence
    "\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
      finite (defer acc A p) \<longrightarrow>
        defer (loop_comp_helper (acc \<triangleright> m) m t) A p \<subseteq> defer acc A p"
    using emod_acc_m less.hyps less.prems
    by blast
  hence
    "\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
        finite (defer acc A p) \<longrightarrow>
          defer (loop_comp_helper acc m t) A p \<subseteq> defer acc A p"
    using loop_comp_helper.simps(2)
    by (metis (no_types))
  thus ?case
    using eq_iff loop_comp_helper.simps(1)
    by (metis (no_types))
qed

subsection \<open>Lemmata\<close>

lemma loop_comp_helper_def_lift_inv_helper:
  assumes
    monotone_m: "defer_lift_invariance m" and
    f_prof: "finite_profile A p"
  shows
    "(defer_lift_invariance acc \<and> n = card (defer acc A p)) \<longrightarrow>
        (\<forall>q a.
          (a \<in> (defer (loop_comp_helper acc m t) A p) \<and>
            lifted A p q a) \<longrightarrow>
                (loop_comp_helper acc m t) A p =
                  (loop_comp_helper acc m t) A q)"
proof (induct n arbitrary: acc rule: less_induct)
  case (less n)
  have defer_card_comp:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc \<triangleright> m) A p) = card (defer (acc \<triangleright> m) A q))"
    using monotone_m def_lift_inv_seq_comp_help
    by metis
  have defer_card_acc:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall>q a. (a \<in> (defer (acc) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc) A p) = card (defer (acc) A q))"
    by (simp add: defer_lift_invariance_def)
  hence defer_card_acc_2:
    "defer_lift_invariance acc \<longrightarrow>
        (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
            card (defer (acc) A p) = card (defer (acc) A q))"
    using monotone_m f_prof defer_lift_invariance_def seq_comp_def_set_trans
    by metis
  thus ?case
  proof cases
    assume card_unchanged: "card (defer (acc \<triangleright> m) A p) = card (defer acc A p)"
    with defer_card_comp defer_card_acc monotone_m
    have
      "defer_lift_invariance (acc) \<longrightarrow>
          (\<forall>q a. (a \<in> (defer (acc) A p) \<and> lifted A p q a) \<longrightarrow>
              (loop_comp_helper acc m t) A q = acc A q)"
    proof (safe)
      fix
        q :: "'a Profile" and
        a :: "'a"
      assume
        def_card_eq:
        "card (defer (acc \<triangleright> m) A p) = card (defer acc A p)" and
        dli_acc: "defer_lift_invariance acc" and
        def_seq_lift_card:
        "\<forall>q a. a \<in> defer (acc \<triangleright> m) A p \<and> Profile.lifted A p q a \<longrightarrow>
          card (defer (acc \<triangleright> m) A p) = card (defer (acc \<triangleright> m) A q)" and
        a_in_def_acc: "a \<in> defer acc A p" and
        lifted_A: "Profile.lifted A p q a"
      have emod_m: "electoral_module m"
        using defer_lift_invariance_def monotone_m
        by auto
      have emod_acc: "electoral_module acc"
        using defer_lift_invariance_def dli_acc
        by blast
      have acc_eq_pq: "acc A q = acc A p"
        using a_in_def_acc defer_lift_invariance_def dli_acc lifted_A
        by (metis (full_types))
      with emod_acc emod_m
      have
        "finite (defer acc A p) \<longrightarrow>
          loop_comp_helper acc m t A q = acc A q"
        using a_in_def_acc def_card_eq def_seq_lift_card
              dual_order.strict_iff_order f_prof lifted_A
              loop_comp_code_helper psubset_card_mono
              seq_comp_def_set_bounded
        by (metis (no_types))
      thus "loop_comp_helper acc m t A q = acc A q"
        using acc_eq_pq loop_comp_code_helper
        by (metis (full_types))
    qed
    moreover from card_unchanged have
      "(loop_comp_helper acc m t) A p = acc A p"
      using loop_comp_helper.simps(1) order.strict_iff_order
            psubset_card_mono
      by metis
    ultimately have
      "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance acc) \<longrightarrow>
          (\<forall>q a. (a \<in> (defer (loop_comp_helper acc m t) A p) \<and>
              lifted A p q a) \<longrightarrow>
                  (loop_comp_helper acc m t) A p =
                    (loop_comp_helper acc m t) A q)"
      using defer_lift_invariance_def
      by metis
    thus ?thesis
      using monotone_m seq_comp_presv_def_lift_inv
      by blast
  next
    assume card_changed:
      "\<not> (card (defer (acc \<triangleright> m) A p) = card (defer acc A p))"
    with f_prof seq_comp_def_card_bounded have card_smaller_for_p:
      "electoral_module (acc) \<longrightarrow>
          (card (defer (acc \<triangleright> m) A p) < card (defer acc A p))"
      using monotone_m order.not_eq_order_implies_strict
            defer_lift_invariance_def
      by (metis (full_types))
    with defer_card_acc_2 defer_card_comp
    have card_changed_for_q:
      "defer_lift_invariance (acc) \<longrightarrow>
          (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
              (card (defer (acc \<triangleright> m) A q) < card (defer acc A q)))"
      using defer_lift_invariance_def
      by (metis (no_types, lifting))
    thus ?thesis
    proof cases
      assume t_not_satisfied_for_p: "\<not> t (acc A p)"
      hence t_not_satisfied_for_q:
        "defer_lift_invariance (acc) \<longrightarrow>
            (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                \<not> t (acc A q))"
        using monotone_m f_prof defer_lift_invariance_def seq_comp_def_set_trans
        by metis
      from card_changed defer_card_comp defer_card_acc
      have dli_card_def:
        "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc)) \<longrightarrow>
            (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> Profile.lifted A p q a) \<longrightarrow>
                card (defer (acc \<triangleright> m) A q) \<noteq> (card (defer acc A q)))"
      proof -
        have
          "\<forall>f.
            (defer_lift_invariance f \<or>
              (\<exists>A prof prof2 (a::'a).
                f A prof \<noteq> f A prof2 \<and>
                  Profile.lifted A prof prof2 a \<and>
                  a \<in> defer f A prof) \<or> \<not> electoral_module f) \<and>
                  ((\<forall>A p1 p2 b. f A p1 = f A p2 \<or> \<not> Profile.lifted A p1 p2 b \<or>
                    b \<notin> defer f A p1) \<and>
                  electoral_module f \<or> \<not> defer_lift_invariance f)"
          using defer_lift_invariance_def
          by blast
        thus ?thesis
          using card_changed monotone_m f_prof seq_comp_def_set_trans
          by (metis (no_types, hide_lams))
      qed
      hence dli_def_subset:
        "defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc) \<longrightarrow>
            (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                defer (acc \<triangleright> m) A q \<subset> defer acc A q)"
      proof -
        {
          fix
            alt :: 'a and
            prof :: "'a Profile"
          have
            "(\<not> defer_lift_invariance (acc \<triangleright> m) \<or> \<not> defer_lift_invariance acc) \<or>
              (alt \<notin> defer (acc \<triangleright> m) A p \<or> \<not> lifted A p prof alt) \<or>
              defer (acc \<triangleright> m) A prof \<subset> defer acc A prof"
            using Profile.lifted_def dli_card_def defer_lift_invariance_def
                  monotone_m psubsetI seq_comp_def_set_bounded
            by (metis (no_types))
        }
        thus ?thesis
          by metis
      qed
      with t_not_satisfied_for_p
      have rec_step_q:
        "(defer_lift_invariance (acc \<triangleright> m) \<and> defer_lift_invariance (acc)) \<longrightarrow>
            (\<forall>q a. (a \<in> (defer (acc \<triangleright> m) A p) \<and> lifted A p q a) \<longrightarrow>
                loop_comp_helper acc m t A q =
                  loop_comp_helper (acc \<triangleright> m) m t A q)"
      proof (safe)
        fix
          q :: "'a Profile" and
          a :: "'a"
        assume
          a_in_def_impl_def_subset:
          "\<forall>q a. a \<in> defer (acc \<triangleright> m) A p \<and> lifted A p q a \<longrightarrow>
            defer (acc \<triangleright> m) A q \<subset> defer acc A q" and
          dli_acc: "defer_lift_invariance acc" and
          a_in_def_seq_acc_m: "a \<in> defer (acc \<triangleright> m) A p" and
          lifted_pq_a: "lifted A p q a"
        have defer_subset_acc:
          "defer (acc \<triangleright> m) A q \<subset> defer acc A q"
          using a_in_def_impl_def_subset lifted_pq_a
                a_in_def_seq_acc_m
          by metis
        have "electoral_module acc"
          using dli_acc defer_lift_invariance_def
          by auto
        hence "finite (defer acc A q) \<and> \<not> t (acc A q)"
          using lifted_def dli_acc a_in_def_seq_acc_m
                lifted_pq_a def_presv_fin_prof
                t_not_satisfied_for_q
          by metis
        with defer_subset_acc
        show
          "loop_comp_helper acc m t A q =
            loop_comp_helper (acc \<triangleright> m) m t A q"
          using loop_comp_code_helper
          by metis
      qed
      have rec_step_p:
        "electoral_module acc \<longrightarrow>
            loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
      proof (safe)
        assume emod_acc: "electoral_module acc"
        have emod_implies_defer_subset:
          "electoral_module m \<longrightarrow> defer (acc \<triangleright> m) A p \<subseteq> defer acc A p"
          using emod_acc f_prof seq_comp_def_set_bounded
          by blast
        have card_ineq: "card (defer (acc \<triangleright> m) A p) < card (defer acc A p)"
          using card_smaller_for_p emod_acc
          by force
        have fin_def_limited_acc:
          "finite_profile (defer acc A p) (limit_profile (defer acc A p) p)"
          using def_presv_fin_prof emod_acc f_prof
          by metis
        have "defer (acc \<triangleright> m) A p \<subseteq> defer acc A p"
          using emod_implies_defer_subset defer_lift_invariance_def monotone_m
          by blast
        hence "defer (acc \<triangleright> m) A p \<subset> defer acc A p"
          using fin_def_limited_acc card_ineq card_psubset
          by metis
        with fin_def_limited_acc
        show "loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
          using loop_comp_code_helper t_not_satisfied_for_p
          by (metis (no_types))
      qed
      show ?thesis
      proof (safe)
        fix
          q :: "'a Profile" and
          a :: "'a"
        assume
          dli_acc: "defer_lift_invariance acc" and
          n_card_acc: "n = card (defer acc A p)" and
          a_in_defer_lch: "a \<in> defer (loop_comp_helper acc m t) A p" and
          a_lifted: "Profile.lifted A p q a"
        hence emod_acc: "electoral_module acc"
          using defer_lift_invariance_def
          by metis
        have "defer_lift_invariance (acc \<triangleright> m) \<and> a \<in> defer (acc \<triangleright> m) A p"
          using a_in_defer_lch defer_lift_invariance_def dli_acc
                f_prof loop_comp_helper_imp_no_def_incr monotone_m
                rec_step_p seq_comp_presv_def_lift_inv subsetD
          by (metis (no_types))
        with emod_acc
        show "loop_comp_helper acc m t A p = loop_comp_helper acc m t A q"
          using a_in_defer_lch a_lifted card_smaller_for_p dli_acc
                less.hyps n_card_acc rec_step_p rec_step_q
          by (metis (full_types))
      qed
    next
      assume "\<not> \<not>t (acc A p)"
      with defer_lift_invariance_def
      show ?thesis
        using loop_comp_helper.simps(1)
        by metis
    qed
  qed
qed

lemma loop_comp_helper_def_lift_inv:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc" and
    profile: "finite_profile A p"
  shows
    "\<forall>q a. (lifted A p q a \<and> a \<in> (defer (loop_comp_helper acc m t) A p)) \<longrightarrow>
        (loop_comp_helper acc m t) A p = (loop_comp_helper acc m t) A q"
  using loop_comp_helper_def_lift_inv_helper
        monotone_m monotone_acc profile
  by blast

lemma loop_comp_helper_def_lift_inv2:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc" and
    finite_A_p: "finite_profile A p" and
    lifted_A_pq: "lifted A p q a" and
    a_in_defer_acc: "a \<in> defer (loop_comp_helper acc m t) A p"
  shows
    "(loop_comp_helper acc m t) A p = (loop_comp_helper acc m t) A q"
  using finite_A_p lifted_A_pq a_in_defer_acc
        loop_comp_helper_def_lift_inv
        monotone_acc monotone_m
  by blast

lemma lifted_imp_fin_prof:
  assumes "lifted A p q a"
  shows "finite_profile A p"
  using assms Profile.lifted_def
  by fastforce

lemma loop_comp_helper_presv_def_lift_inv:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_acc: "defer_lift_invariance acc"
  shows "defer_lift_invariance (loop_comp_helper acc m t)"
proof -
  have
    "\<forall>f. (defer_lift_invariance f \<or>
         (\<exists>A prof prof2 (a::'a).
            f A prof \<noteq> f A prof2 \<and>
              Profile.lifted A prof prof2 a \<and>
              a \<in> defer f A prof) \<or>
         \<not> electoral_module f) \<and>
      ((\<forall>A prof prof2 a. f A prof = f A prof2 \<or>
          \<not> Profile.lifted A prof prof2 a \<or>
          a \<notin> defer f A prof) \<and>
      electoral_module f \<or> \<not> defer_lift_invariance f)"
    using defer_lift_invariance_def
    by blast
  thus ?thesis
    using electoral_module_def lifted_imp_fin_prof
          loop_comp_helper_def_lift_inv loop_comp_helper_imp_partit
          monotone_acc monotone_m
    by (metis (full_types))
qed

lemma loop_comp_presv_non_electing_helper:
  assumes
    non_electing_m: "non_electing m" and
    non_electing_acc: "non_electing acc" and
    f_prof: "finite_profile A p" and
    acc_defer_card: "n = card (defer acc A p)"
  shows "elect (loop_comp_helper acc m t) A p = {}"
  using acc_defer_card non_electing_acc
proof (induct n arbitrary: acc rule: less_induct)
  case (less n)
  thus ?case
  proof (safe)
    fix x :: "'a"
    assume
      y_acc_no_elect:
      "(\<And>y acc'. y < card (defer acc A p) \<Longrightarrow>
        y = card (defer acc' A p) \<Longrightarrow> non_electing acc' \<Longrightarrow>
          elect (loop_comp_helper acc' m t) A p = {})" and
      acc_non_elect:
      "non_electing acc" and
      x_in_acc_elect:
      "x \<in> elect (loop_comp_helper acc m t) A p"
    have
      "\<forall>(f::'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result) g.
        (non_electing f \<and> non_electing g) \<longrightarrow>
          non_electing (f \<triangleright> g)"
      by simp
    hence seq_acc_m_non_elect: "non_electing (acc \<triangleright> m)"
      using acc_non_elect non_electing_m
      by blast
    have "\<forall>A B. (finite (A::'a set) \<and> B \<subset> A) \<longrightarrow> card B < card A"
      using psubset_card_mono
      by metis
    hence card_ineq:
      "\<forall>A B. (finite (A::'a set) \<and> B \<subset> A) \<longrightarrow> card B < card A"
      by presburger
    have no_elect_acc: "elect acc A p = {}"
      using acc_non_elect f_prof non_electing_def
      by auto
    have card_n_no_elect:
      "\<forall>n f.
        (n < card (defer acc A p) \<and> n = card (defer f A p) \<and> non_electing f) \<longrightarrow>
          elect (loop_comp_helper f m t) A p = {}"
      using y_acc_no_elect
      by blast
    have
      "\<And>f.
        (finite (defer acc A p) \<and> defer f A p \<subset> defer acc A p \<and> non_electing f) \<longrightarrow>
          elect (loop_comp_helper f m t) A p = {}"
      using card_n_no_elect psubset_card_mono
      by metis
    hence f0:
      "(\<not> t (acc A p) \<and> defer (acc \<triangleright> m) A p \<subset> defer acc A p \<and>
            finite (defer acc A p)) \<and>
          \<not> t (acc A p) \<longrightarrow>
        elect (loop_comp_helper acc m t) A p = {}"
      using loop_comp_code_helper seq_acc_m_non_elect
      by (metis (no_types))
    obtain set_func :: "'a set \<Rightarrow> 'a" where
      "\<forall>A. (A = {} \<longrightarrow> (\<forall>a. a \<notin> A)) \<and> (A \<noteq> {} \<longrightarrow> set_func A \<in> A)"
      using all_not_in_conv
      by (metis (no_types))
    thus "x \<in> {}"
      using loop_comp_code_helper no_elect_acc x_in_acc_elect f0
      by (metis (no_types))
  qed
qed

lemma loop_comp_helper_iter_elim_def_n_helper:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    n_acc_defer_card: "n = card (defer acc A p)" and
    n_ge_x: "n \<ge> x" and
    def_card_gt_one: "card (defer acc A p) > 1" and
    acc_nonelect: "non_electing acc"
  shows "card (defer (loop_comp_helper acc m t) A p) = x"
  using n_ge_x def_card_gt_one acc_nonelect n_acc_defer_card
proof (induct n arbitrary: acc rule: less_induct)
  case (less n)
  have subset:
    "(card (defer acc A p) > 1 \<and> finite_profile A p \<and> electoral_module acc) \<longrightarrow>
        defer (acc \<triangleright> m) A p \<subset> defer acc A p"
    using seq_comp_elim_one_red_def_set single_elimination
    by blast
  hence step_reduces_defer_set:
    "(card (defer acc A p) > 1 \<and> finite_profile A p \<and> non_electing acc) \<longrightarrow>
        defer (acc \<triangleright> m) A p \<subset> defer acc A p"
    using non_electing_def
    by auto
  thus ?case
  proof cases
    assume term_satisfied: "t (acc A p)"
    have "card (defer_r (loop_comp_helper acc m t A p)) = x"
      using loop_comp_helper.simps(1) term_satisfied terminate_if_n_left
      by metis
    thus ?case
      by blast
  next
    assume term_not_satisfied: "\<not>(t (acc A p))"
    hence card_not_eq_x: "card (defer acc A p) \<noteq> x"
      by (simp add: terminate_if_n_left)
    have rec_step:
      "(card (defer acc A p) > 1 \<and> finite_profile A p \<and> non_electing acc) \<longrightarrow>
          loop_comp_helper acc m t A p =
              loop_comp_helper (acc \<triangleright> m) m t A p" (*needed for step*)
      using loop_comp_helper.simps(2) non_electing_def def_presv_fin_prof
            step_reduces_defer_set term_not_satisfied
      by metis
    thus ?case
    proof cases
      assume card_too_small:
        "card (defer acc A p) < x"
      thus ?thesis
        using not_le card_too_small less.prems(1) less.prems(4) not_le
        by (metis (no_types))
    next
      assume old_card_at_least_x: "\<not>(card (defer acc A p) < x)"
      obtain i where i_is_new_card: "i = card (defer (acc \<triangleright> m) A p)"
        by blast
      with card_not_eq_x
      have card_too_big:
        "card (defer acc A p) > x"
        using nat_neq_iff old_card_at_least_x
        by blast
      hence enough_leftover:
        "card (defer acc A p) > 1"
        using x_greater_zero
        by auto
      have "electoral_module acc \<longrightarrow> (defer acc A p) \<subseteq> A"
        by (simp add: defer_in_alts f_prof)
      hence step_profile:
        "electoral_module acc \<longrightarrow>
            finite_profile (defer acc A p)
              (limit_profile (defer acc A p) p)"
        using f_prof limit_profile_sound
        by auto
      hence
        "electoral_module acc \<longrightarrow>
            card (defer m (defer acc A p)
              (limit_profile (defer acc A p) p)) =
                card (defer acc A p) - 1"
        using non_electing_m single_elimination
              single_elim_decr_def_card2 enough_leftover
        by blast
      hence "electoral_module acc \<longrightarrow> i = card (defer acc A p) - 1"
        using sequential_composition.simps snd_conv i_is_new_card
        by metis
      hence "electoral_module acc \<longrightarrow> i \<ge> x"
        using card_too_big
        by linarith
      hence new_card_still_big_enough: "electoral_module acc \<longrightarrow> x \<le> i"
        by blast
      have
        "electoral_module acc \<and> electoral_module m \<longrightarrow>
            defer (acc \<triangleright> m) A p \<subseteq> defer acc A p"
        using enough_leftover f_prof subset
        by blast
      hence
        "electoral_module acc \<and> electoral_module m \<longrightarrow>
            i \<le> card (defer acc A p)"
        using card_mono i_is_new_card step_profile
        by blast
      hence i_geq_x:
        "electoral_module acc \<and> electoral_module m \<longrightarrow> (i = x \<or> i > x)"
        using nat_less_le new_card_still_big_enough
        by blast
      thus ?thesis
      proof cases
        assume new_card_greater_x: "electoral_module acc \<longrightarrow> i > x"
        hence "electoral_module acc \<longrightarrow> 1 < card (defer (acc \<triangleright> m) A p)"
          using x_greater_zero i_is_new_card
          by linarith
        moreover have new_card_still_big_enough2:
          "electoral_module acc \<longrightarrow> x \<le> i" (* Needed for step *)
          using i_is_new_card new_card_still_big_enough
          by blast
        moreover have
          "n = card (defer acc A p) \<longrightarrow>
              (electoral_module acc \<longrightarrow> i < n)" (* Needed for step *)
          using subset step_profile enough_leftover f_prof psubset_card_mono
                i_is_new_card
          by blast
        moreover have
          "electoral_module acc \<longrightarrow>
              electoral_module (acc \<triangleright> m)" (* Needed for step *)
          using non_electing_def non_electing_m seq_comp_sound
          by blast
        moreover have non_electing_new:
          "non_electing acc \<longrightarrow> non_electing (acc \<triangleright> m)"
          by (simp add: non_electing_m)
        ultimately have card_x:
          "(n = card (defer acc A p) \<and> non_electing acc \<and>
              electoral_module acc) \<longrightarrow>
                  card (defer (loop_comp_helper (acc \<triangleright> m) m t) A p) = x"
          using less.hyps i_is_new_card new_card_greater_x
          by blast
        have f1: "loop_comp_helper acc m t A p = loop_comp_helper (acc \<triangleright> m) m t A p"
          using enough_leftover f_prof less.prems(3) rec_step
          by blast
        have "electoral_module acc"
          using less.prems(3) non_electing_def
          by blast
        thus ?thesis
          using f1 card_x less.prems(3) less.prems(4)
          by presburger
      next
        assume i_not_gt_x: "\<not>(electoral_module acc \<longrightarrow> i > x)"
        hence "electoral_module acc \<and> electoral_module m \<longrightarrow> i = x"
          using i_geq_x
          by blast
        hence "electoral_module acc \<and> electoral_module m \<longrightarrow> t ((acc \<triangleright> m) A p)"
          using i_is_new_card terminate_if_n_left
          by blast
        hence
          "electoral_module acc \<and> electoral_module m \<longrightarrow>
              card (defer_r (loop_comp_helper (acc \<triangleright> m) m t A p)) = x"
          using loop_comp_helper.simps(1) terminate_if_n_left
          by metis
        thus ?thesis
          using i_not_gt_x dual_order.strict_iff_order i_is_new_card
                loop_comp_helper.simps(1) new_card_still_big_enough
                f_prof rec_step terminate_if_n_left
                enough_leftover less.prems(3)
          by metis
      qed
    qed
  qed
qed

lemma loop_comp_helper_iter_elim_def_n:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    acc_defers_enough: "card (defer acc A p) \<ge> x" and
    non_electing_acc: "non_electing acc"
  shows "card (defer (loop_comp_helper acc m t) A p) = x"
  using acc_defers_enough gr_implies_not0 le_neq_implies_less
        less_one linorder_neqE_nat loop_comp_helper.simps(1)
        loop_comp_helper_iter_elim_def_n_helper non_electing_acc
        non_electing_m f_prof single_elimination nat_neq_iff
        terminate_if_n_left x_greater_zero less_le
  by (metis (no_types, lifting))

lemma iter_elim_def_n_helper:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = x))" and
    x_greater_zero: "x > 0" and
    f_prof: "finite_profile A p" and
    enough_alternatives: "card A \<ge> x"
  shows "card (defer (m \<circlearrowleft>\<^sub>t) A p) = x"
proof cases
  assume "card A = x"
  thus ?thesis
    by (simp add: terminate_if_n_left)
next
  assume card_not_x: "\<not> card A = x"
  thus ?thesis
  proof cases
    assume "card A < x"
    thus ?thesis
      using enough_alternatives not_le
      by blast
  next
    assume "\<not>card A < x"
    hence card_big_enough_A: "card A > x"
      using card_not_x
      by linarith
    hence card_m: "card (defer m A p) = card A - 1"
      using non_electing_m f_prof single_elimination
            single_elim_decr_def_card2 x_greater_zero
      by fastforce
    hence card_big_enough_m: "card (defer m A p) \<ge> x"
      using card_big_enough_A
      by linarith
    hence "(m \<circlearrowleft>\<^sub>t) A p = (loop_comp_helper m m t) A p"
      by (simp add: card_not_x terminate_if_n_left)
    thus ?thesis
      using card_big_enough_m non_electing_m f_prof single_elimination
            terminate_if_n_left x_greater_zero
            loop_comp_helper_iter_elim_def_n
      by metis
  qed
qed

subsection \<open>Composition Rules\<close>

(*The loop composition preserves defer-lift-invariance.*)
theorem loop_comp_presv_def_lift_inv[simp]:
  assumes monotone_m: "defer_lift_invariance m"
  shows "defer_lift_invariance (m \<circlearrowleft>\<^sub>t)"
  unfolding defer_lift_invariance_def
proof (safe)
  from monotone_m
  have "electoral_module m"
    unfolding defer_lift_invariance_def
    by simp
  thus "electoral_module (m \<circlearrowleft>\<^sub>t)"
    by (simp add: loop_comp_sound)
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume
    a_in_loop_defer: "a \<in> defer (m \<circlearrowleft>\<^sub>t) A p" and
    lifted_a: "Profile.lifted A p q a"
  have defer_lift_loop:
    "\<forall> p q a. (a \<in> (defer (m \<circlearrowleft>\<^sub>t) A p) \<and> lifted A p q a) \<longrightarrow>
        (m \<circlearrowleft>\<^sub>t) A p = (m \<circlearrowleft>\<^sub>t) A q"
    using monotone_m lifted_imp_fin_prof loop_comp_helper_def_lift_inv2
          loop_composition.simps defer_module.simps
    by (metis (full_types))
  show "(m \<circlearrowleft>\<^sub>t) A p = (m \<circlearrowleft>\<^sub>t) A q"
    using a_in_loop_defer lifted_a defer_lift_loop
    by metis
qed

(*The loop composition preserves the property non-electing.*)
theorem loop_comp_presv_non_electing[simp]:
  assumes non_electing_m: "non_electing m"
  shows "non_electing (m \<circlearrowleft>\<^sub>t)"
  unfolding non_electing_def
proof (safe, simp_all)
  show "electoral_module (m \<circlearrowleft>\<^sub>t)"
    using loop_comp_sound non_electing_def non_electing_m
    by metis
next
    fix
      A :: "'a set" and
      p :: "'a Profile" and
      x :: "'a"
    assume
      fin_A: "finite A" and
      prof_A: "profile A p" and
      x_elect: "x \<in> elect (m \<circlearrowleft>\<^sub>t) A p"
    show "False"
  using def_mod_non_electing loop_comp_presv_non_electing_helper
        non_electing_m empty_iff fin_A loop_comp_code
        non_electing_def prof_A x_elect
  by metis
qed

theorem iter_elim_def_n[simp]:
  assumes
    non_electing_m: "non_electing m" and
    single_elimination: "eliminates 1 m" and
    terminate_if_n_left: "\<forall> r. ((t r) \<longleftrightarrow> (card (defer_r r) = n))" and
    x_greater_zero: "n > 0"
  shows "defers n (m \<circlearrowleft>\<^sub>t)"
proof -
  have
    "\<forall> A p. finite_profile A p \<and> card A \<ge> n \<longrightarrow>
        card (defer (m \<circlearrowleft>\<^sub>t) A p) = n"
    using iter_elim_def_n_helper non_electing_m single_elimination
          terminate_if_n_left x_greater_zero
    by blast
  moreover have "electoral_module (m \<circlearrowleft>\<^sub>t)"
    using loop_comp_sound eliminates_def single_elimination
    by blast
  thus ?thesis
    by (simp add: calculation defers_def)
qed

end


(*****************************************************************************
 * HOL-TestGen --- theorem-prover based test case generation
 *                 http://www.brucker.ch/projects/hol-testgen/
 *
 * UPF
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2005-2012 ETH Zurich, Switzerland
 *               2008-2015 Achim D. Brucker, Germany
 *               2009-2017 Université Paris-Sud, France
 *               2015-2017 The University of Sheffield, UK
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

section\<open>The Core of the Unified Policy Framework (UPF)\<close>
theory
  UPFCore
  imports
    Monads
begin

subsection\<open>Foundation\<close>
text\<open>
  The purpose of this theory is to formalize a somewhat non-standard view
  on the fundamental concept of a security policy which is worth outlining.
  This view has arisen from prior experience in the modelling of network
  (firewall) policies. Instead of regarding policies as relations on resources,
  sets of permissions, etc., we emphasise the view that a policy is a policy
  decision function that grants or denies access to resources, permissions, etc.
  In other words, we model the concrete function that implements the policy
  decision point in a system, and which represents a "wrapper" around the
  business logic. An advantage of this view is that it is compatible
  with many different policy models, enabling a uniform modelling framework to be
  defined. Furthermore, this function is typically a large cascade of nested
  conditionals, using conditions referring to an internal state and security
  contexts of the system or a user. This cascade of conditionals can easily be
  decomposed into a set of test cases similar to transformations used for binary
  decision diagrams (BDD), and motivate equivalence class testing for unit test and
  sequence test scenarios. From the modelling perspective, using \HOL as
  its input language, we will consequently use the expressive power of its
  underlying functional  programming language, including the possibility to
  define higher-order combinators.

  In more detail, we model policies as partial functions based on input
  data $\alpha$ (arguments, system state, security context, ...) to output
  data $\beta$:
\<close>

datatype '\<alpha> decision = allow '\<alpha> | deny '\<alpha>

type_synonym ('\<alpha>,'\<beta>) policy = "'\<alpha>  \<rightharpoonup> '\<beta> decision" (infixr "|->" 0)

text\<open>In the following, we introduce a number of shortcuts and alternative notations.
The type of policies is represented as:\<close>

translations (type)        "'\<alpha> |-> '\<beta>" <= (type) "'\<alpha>  \<rightharpoonup> '\<beta> decision"
type_notation "policy" (infixr "\<mapsto>" 0)

text\<open>... allowing the notation @{typ "'\<alpha> \<mapsto> '\<beta>"}  for the policy type and the
alternative notations for @{term None} and @{term Some} of the \HOL library
@{typ "'\<alpha> option"} type:\<close>

notation    "None" ("\<bottom>")
notation    "Some" ("\<lfloor>_\<rfloor>" 80)

text\<open>Thus, the range of a policy may consist of @{term "\<lfloor>accept x\<rfloor>"} data,
  of @{term "\<lfloor>deny x\<rfloor>"} data, as well as @{term "\<bottom>"} modeling the undefinedness
  of a policy, i.e. a policy is considered as a partial function. Partial
  functions are used since we describe elementary policies by partial system
  behaviour, which are glued together by operators such as function override and
  functional composition.
\<close>

text\<open>We define the two fundamental sets, the allow-set $Allow$ and the
  deny-set $Deny$ (written $A$ and $D$ set for short), to characterize these
  two main sets of the range of a policy.
\<close>
definition Allow :: "('\<alpha> decision) set"
where     "Allow = range allow"

definition Deny :: "('\<alpha> decision) set"
where     "Deny = range deny"

subsection\<open>Policy Constructors\<close>
text\<open>
  Most elementary policy constructors are based on the
  update operation @{thm [source] "Fun.fun_upd_def"} @{thm Fun.fun_upd_def}
  and the maplet-notation @{term "a(x \<mapsto> y)"} used for @{term "a(x:=\<lfloor>y\<rfloor>)"}.

  Furthermore, we add notation adopted to our problem domain:\<close>

nonterminal policylets and policylet

syntax
  "_policylet1"  :: "['a, 'a] => policylet"                 ("_ /\<mapsto>\<^sub>+/ _")
  "_policylet2"  :: "['a, 'a] => policylet"                 ("_ /\<mapsto>\<^sub>-/ _")
  ""             :: "policylet => policylets"               ("_")
  "_Maplets"     :: "[policylet, policylets] => policylets" ("_,/ _")
  "_Maplets"     :: "[policylet, policylets] => policylets" ("_,/ _")
   "_MapUpd"      :: "['a |-> 'b, policylets] => 'a |-> 'b"  ("_/'(_')" [900,0]900)
  "_emptypolicy" :: "'a |-> 'b"                             ("\<emptyset>")

translations
  "_MapUpd m (_Maplets xy ms)"   \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_policylet1 x y)"  \<rightleftharpoons> "m(x := CONST Some (CONST allow y))"
  "_MapUpd m (_policylet2 x y)"  \<rightleftharpoons> "m(x := CONST Some (CONST deny y))"
  "\<emptyset>"                            \<rightleftharpoons> "CONST Map.empty"

text\<open>Here are some lemmas essentially showing syntactic equivalences:\<close>
lemma test: "\<emptyset>(x\<mapsto>\<^sub>+a, y\<mapsto>\<^sub>-b) = \<emptyset>(x \<mapsto>\<^sub>+ a, y \<mapsto>\<^sub>- b)"   by simp

lemma test2: "p(x\<mapsto>\<^sub>+a,x\<mapsto>\<^sub>-b) = p(x\<mapsto>\<^sub>-b)"   by simp

text\<open>
  We inherit a fairly rich theory on policy updates from Map here. Some examples are:
\<close>

lemma pol_upd_triv1: "t k =   \<lfloor>allow x\<rfloor> \<Longrightarrow> t(k\<mapsto>\<^sub>+x) = t"
  by (rule ext) simp

lemma pol_upd_triv2: "t k = \<lfloor>deny x\<rfloor> \<Longrightarrow> t(k\<mapsto>\<^sub>-x) = t"
  by (rule ext) simp

lemma pol_upd_allow_nonempty: "t(k\<mapsto>\<^sub>+x) \<noteq> \<emptyset>"
  by simp

lemma pol_upd_deny_nonempty: "t(k\<mapsto>\<^sub>-x) \<noteq> \<emptyset>"
  by simp

lemma pol_upd_eqD1 : "m(a\<mapsto>\<^sub>+x) = n(a\<mapsto>\<^sub>+y) \<Longrightarrow> x = y"
  by(auto dest: map_upd_eqD1)

lemma pol_upd_eqD2 : "m(a\<mapsto>\<^sub>-x) = n(a\<mapsto>\<^sub>-y) \<Longrightarrow> x = y"
  by(auto dest: map_upd_eqD1)

lemma pol_upd_neq1 [simp]: "m(a\<mapsto>\<^sub>+x) \<noteq> n(a\<mapsto>\<^sub>-y)"
  by(auto dest: map_upd_eqD1)

subsection\<open>Override Operators\<close>
text\<open>
  Key operators for constructing policies are the override operators. There are four different
  versions of them, with one of them being the override operator from the Map theory. As it is
  common to compose policy rules in a ``left-to-right-first-fit''-manner, that one is taken as
  default, defined by a syntax translation from the provided override operator from the Map
  theory (which does it in reverse order).
\<close>

syntax
  "_policyoverride"  :: "['a \<mapsto> 'b, 'a \<mapsto> 'b] \<Rightarrow> 'a \<mapsto> 'b" (infixl "\<Oplus>" 100)
translations
  "p \<Oplus> q" \<rightleftharpoons> "q ++ p"

text\<open>
  Some elementary facts inherited from Map are:
\<close>

lemma override_empty: "p \<Oplus> \<emptyset> = p"
  by simp

lemma empty_override: "\<emptyset> \<Oplus> p = p"
  by simp

lemma override_assoc: "p1 \<Oplus> (p2 \<Oplus> p3) = (p1 \<Oplus> p2) \<Oplus> p3"
  by simp

text\<open>
  The following two operators are variants of the standard override.  For override\_A,
  an allow of wins over a deny. For override\_D, the situation is dual.
\<close>

definition override_A :: "['\<alpha>\<mapsto>'\<beta>, '\<alpha>\<mapsto>'\<beta>] \<Rightarrow> '\<alpha>\<mapsto>'\<beta>" (infixl "++'_A" 100)
where  "m2 ++_A m1 =
          (\<lambda>x. (case m1 x of
                 \<lfloor>allow a\<rfloor> \<Rightarrow>  \<lfloor>allow a\<rfloor>
               | \<lfloor>deny a\<rfloor>  \<Rightarrow> (case m2 x of \<lfloor>allow b\<rfloor> \<Rightarrow> \<lfloor>allow b\<rfloor>
                                            | _ \<Rightarrow> \<lfloor>deny a\<rfloor>)
               | \<bottom> \<Rightarrow> m2 x)
           )"

syntax
  "_policyoverride_A"  :: "['a \<mapsto> 'b, 'a \<mapsto> 'b] \<Rightarrow> 'a \<mapsto> 'b" (infixl "\<Oplus>\<^sub>A" 100)
translations
  "p \<Oplus>\<^sub>A q" \<rightleftharpoons> "p ++_A q"

lemma override_A_empty[simp]: "p \<Oplus>\<^sub>A \<emptyset> = p"
  by(simp add:override_A_def)

lemma empty_override_A[simp]: "\<emptyset> \<Oplus>\<^sub>A p = p"
  apply (rule ext)
  apply (simp add:override_A_def)
  subgoal for x
    apply (case_tac "p x")
     apply (simp_all)
    subgoal for a
      apply (case_tac a)
       apply (simp_all)
      done
    done
  done

lemma override_A_assoc: "p1 \<Oplus>\<^sub>A (p2 \<Oplus>\<^sub>A p3) = (p1 \<Oplus>\<^sub>A p2) \<Oplus>\<^sub>A p3"
  by (rule ext, simp add: override_A_def split: decision.splits  option.splits)

definition override_D :: "['\<alpha>\<mapsto>'\<beta>, '\<alpha>\<mapsto>'\<beta>] \<Rightarrow> '\<alpha>\<mapsto>'\<beta>" (infixl "++'_D" 100)
where "m1 ++_D m2 =
          (\<lambda>x. case m2 x of
                \<lfloor>deny a\<rfloor> \<Rightarrow> \<lfloor>deny a\<rfloor>
              | \<lfloor>allow a\<rfloor> \<Rightarrow> (case m1 x of \<lfloor>deny b\<rfloor> \<Rightarrow> \<lfloor>deny b\<rfloor>
                                  | _ \<Rightarrow> \<lfloor>allow a\<rfloor>)
              | \<bottom> \<Rightarrow> m1 x
           )"

syntax
  "_policyoverride_D"  :: "['a \<mapsto> 'b, 'a \<mapsto> 'b] \<Rightarrow> 'a \<mapsto> 'b" (infixl "\<Oplus>\<^sub>D" 100)
translations
  "p \<Oplus>\<^sub>D q" \<rightleftharpoons> "p ++_D q"

lemma override_D_empty[simp]: "p \<Oplus>\<^sub>D \<emptyset> = p"
  by(simp add:override_D_def)

lemma empty_override_D[simp]: "\<emptyset> \<Oplus>\<^sub>D p = p"
  apply (rule ext)
  apply (simp add:override_D_def)
  subgoal for x
    apply (case_tac "p x", simp_all)
    subgoal for a
      apply (case_tac a, simp_all)
      done
    done
  done

lemma override_D_assoc: "p1 \<Oplus>\<^sub>D (p2 \<Oplus>\<^sub>D p3) = (p1 \<Oplus>\<^sub>D p2) \<Oplus>\<^sub>D p3"
  apply (rule ext)
  apply (simp add: override_D_def split: decision.splits  option.splits)
done

subsection\<open>Coercion Operators\<close>
text\<open>
  Often, especially when combining policies of different type, it is necessary to
  adapt the input or output domain of a policy to a more refined context.
\<close>

text\<open>
  An analogous for the range of a policy is defined as follows:
\<close>

definition policy_range_comp :: "['\<beta>\<Rightarrow>'\<gamma>, '\<alpha>\<mapsto>'\<beta>] \<Rightarrow> '\<alpha> \<mapsto>'\<gamma>"   (infixl "o'_f" 55)
where
  "f o_f p = (\<lambda>x. case p x of
                     \<lfloor>allow y\<rfloor> \<Rightarrow> \<lfloor>allow (f y)\<rfloor>
                   | \<lfloor>deny y\<rfloor> \<Rightarrow> \<lfloor>deny (f y)\<rfloor>
                   | \<bottom> \<Rightarrow> \<bottom>)"

syntax
  "_policy_range_comp" :: "['\<beta>\<Rightarrow>'\<gamma>, '\<alpha>\<mapsto>'\<beta>] \<Rightarrow> '\<alpha> \<mapsto>'\<gamma>" (infixl "o\<^sub>f" 55)
translations
  "p o\<^sub>f q" \<rightleftharpoons> "p o_f q"

lemma policy_range_comp_strict : "f o\<^sub>f \<emptyset> = \<emptyset>"
  apply (rule ext)
  apply (simp add: policy_range_comp_def)
  done

text\<open>
  A generalized version is, where separate coercion functions are applied to the result
  depending on the decision of the policy is as follows:
\<close>

definition range_split :: "[('\<beta>\<Rightarrow>'\<gamma>)\<times>('\<beta>\<Rightarrow>'\<gamma>),'\<alpha> \<mapsto> '\<beta>] \<Rightarrow> '\<alpha> \<mapsto> '\<gamma>"
                          (infixr "\<nabla>" 100)
where "(P) \<nabla> p = (\<lambda>x. case p x of
                          \<lfloor>allow y\<rfloor> \<Rightarrow> \<lfloor>allow ((fst P) y)\<rfloor>
                        | \<lfloor>deny y\<rfloor>  \<Rightarrow> \<lfloor>deny ((snd P) y)\<rfloor>
                        | \<bottom>        \<Rightarrow> \<bottom>)"

lemma range_split_strict[simp]: "P \<nabla> \<emptyset> = \<emptyset>"
  apply (rule ext)
  apply (simp add: range_split_def)
  done

lemma range_split_charn:
  "(f,g) \<nabla> p = (\<lambda>x. case p x of
                           \<lfloor>allow x\<rfloor> \<Rightarrow> \<lfloor>allow (f x)\<rfloor>
                         | \<lfloor>deny x\<rfloor>  \<Rightarrow> \<lfloor>deny (g x)\<rfloor>
                         | \<bottom>        \<Rightarrow> \<bottom>)"
  apply (simp add: range_split_def)
  apply (rule ext)
  subgoal for x
    apply (case_tac "p x")
     apply (simp_all)
    subgoal for a
      apply (case_tac "a")
       apply (simp_all)
      done
    done
  done

text\<open>
  The connection between these two becomes apparent if considering the following lemma:
\<close>

lemma range_split_vs_range_compose: "(f,f) \<nabla> p = f o\<^sub>f p"
  by(simp add: range_split_charn policy_range_comp_def)

lemma range_split_id [simp]: "(id,id) \<nabla> p = p"
  apply (rule ext)
  apply (simp add: range_split_charn id_def)
  subgoal for x
    apply (case_tac "p x")
     apply (simp_all)
    subgoal for a
      apply (case_tac "a")
       apply (simp_all)
      done
    done
  done

lemma range_split_bi_compose [simp]: "(f1,f2) \<nabla> (g1,g2) \<nabla> p = (f1 o g1,f2 o g2) \<nabla> p"
  apply (rule ext)
  apply (simp add: range_split_charn comp_def)
  subgoal for x
    apply (case_tac "p x")
     apply (simp_all)
    subgoal for a
      apply (case_tac "a")
       apply (simp_all)
      done
    done
  done

text\<open>
  The next three operators are rather exotic and in most cases not used.
\<close>

text \<open>
  The following is a variant of range\_split, where the change in the decision depends
  on the input instead of the output.
\<close>

definition dom_split2a :: "[('\<alpha> \<rightharpoonup> '\<gamma>) \<times> ('\<alpha> \<rightharpoonup>'\<gamma>),'\<alpha> \<mapsto> '\<beta>] \<Rightarrow> '\<alpha> \<mapsto> '\<gamma>"         (infixr "\<Delta>a" 100)
where "P \<Delta>a p = (\<lambda>x. case p x of
                          \<lfloor>allow y\<rfloor> \<Rightarrow> \<lfloor>allow (the ((fst P) x))\<rfloor>
                        | \<lfloor>deny y\<rfloor>  \<Rightarrow>  \<lfloor>deny (the ((snd P) x))\<rfloor>
                        | \<bottom>        \<Rightarrow> \<bottom>)"

definition dom_split2 :: "[('\<alpha> \<Rightarrow> '\<gamma>) \<times> ('\<alpha> \<Rightarrow>'\<gamma>),'\<alpha> \<mapsto> '\<beta>] \<Rightarrow> '\<alpha> \<mapsto> '\<gamma>"          (infixr "\<Delta>" 100)
where "P \<Delta> p = (\<lambda>x. case p x of
                          \<lfloor>allow y\<rfloor> \<Rightarrow> \<lfloor>allow ((fst P) x)\<rfloor>
                        | \<lfloor>deny y\<rfloor>  \<Rightarrow>  \<lfloor>deny ((snd P) x)\<rfloor>
                        | \<bottom>        \<Rightarrow> \<bottom>)"

definition range_split2 :: "[('\<alpha> \<Rightarrow> '\<gamma>) \<times> ('\<alpha> \<Rightarrow>'\<gamma>),'\<alpha> \<mapsto> '\<beta>] \<Rightarrow> '\<alpha> \<mapsto> ('\<beta> \<times>'\<gamma>)" (infixr "\<nabla>2" 100)
where "P \<nabla>2 p = (\<lambda>x. case p x of
                          \<lfloor>allow y\<rfloor> \<Rightarrow> \<lfloor>allow (y,(fst P) x)\<rfloor>
                        | \<lfloor>deny y\<rfloor>  \<Rightarrow> \<lfloor>deny (y,(snd P) x)\<rfloor>
                        | \<bottom>        \<Rightarrow> \<bottom>)"

text\<open>
  The following operator is used for transition policies only: a transition policy is transformed
  into a state-exception monad. Such a monad can for example be used for test case generation using
  HOL-Testgen~\cite{brucker.ea:theorem-prover:2012}.
\<close>

definition policy2MON :: "('\<iota>\<times>'\<sigma> \<mapsto> 'o\<times>'\<sigma>) \<Rightarrow> ('\<iota> \<Rightarrow>('o decision,'\<sigma>) MON\<^sub>S\<^sub>E)"
where "policy2MON p = (\<lambda> \<iota> \<sigma>. case p (\<iota>,\<sigma>) of
                              \<lfloor>(allow (outs,\<sigma>'))\<rfloor> \<Rightarrow> \<lfloor>(allow outs, \<sigma>')\<rfloor>
                            | \<lfloor>(deny (outs,\<sigma>'))\<rfloor>  \<Rightarrow> \<lfloor>(deny outs, \<sigma>')\<rfloor>
                            | \<bottom>                  \<Rightarrow> \<bottom>)"

lemmas UPFCoreDefs = Allow_def Deny_def override_A_def override_D_def policy_range_comp_def
                     range_split_def dom_split2_def map_add_def restrict_map_def
end


section {* UTP variables *}

theory utp_urel_setup
  imports utp_lift utp_tactics
begin
(*tactics are in utp_tactics*)
consts
  useq   :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 51)
  uskip  :: "'a" ("II")

definition in\<alpha> :: "('\<alpha>, '\<alpha> \<times> '\<beta>) uvar" where
"in\<alpha> = \<lparr> lens_get = fst, lens_put = \<lambda> (A, A') v. (v, A') \<rparr>"

definition out\<alpha> :: "('\<beta>, '\<alpha> \<times> '\<beta>) uvar" where
"out\<alpha> = \<lparr> lens_get = snd, lens_put = \<lambda> (A, A') v. (A, v) \<rparr>"

declare in\<alpha>_def [urel_defs]
declare out\<alpha>_def [urel_defs]

lemma var_in_alpha [simp]: "x ;\<^sub>L in\<alpha> = ivar x"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma var_out_alpha [simp]: "x ;\<^sub>L out\<alpha> = ovar x"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma out_alpha_in_indep [simp]:
  "out\<alpha> \<bowtie> in_var x" "in_var x \<bowtie> out\<alpha>"
  by (simp_all add: in_var_def out\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

lemma in_alpha_out_indep [simp]:
  "in\<alpha> \<bowtie> out_var x" "out_var x \<bowtie> in\<alpha>"
  by (simp_all add: in_var_def in\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

text {* The alphabet of a relation consists of the input and output portions *}

lemma alpha_in_out:
  "\<Sigma> \<approx>\<^sub>L in\<alpha> +\<^sub>L out\<alpha>"
  by (metis fst_lens_def fst_snd_id_lens in\<alpha>_def lens_equiv_refl out\<alpha>_def snd_lens_def)

abbreviation usubst_rel_lift :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<times> '\<beta>) usubst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> \<sigma> \<oplus>\<^sub>s in\<alpha>"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) usubst \<Rightarrow> '\<alpha> usubst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> \<sigma> \<restriction>\<^sub>s in\<alpha>"

end


section \<open>Compositional Reasoning\<close>

(*<*)
theory Compositional_Reasoning
imports BD_Security
begin
(*>*)

context BD_Security begin

subsection\<open>Preliminaries\<close>

definition "disjAll \<Delta>s s vl s1 vl1 \<equiv> (\<exists>\<Delta> \<in> \<Delta>s. \<Delta> s vl s1 vl1)"

lemma disjAll_simps[simp]:
  "disjAll {} \<equiv> \<lambda>_ _ _ _. False"
  "disjAll (insert \<Delta> \<Delta>s) \<equiv> \<lambda>s vl s1 vl1. \<Delta> s vl s1 vl1 \<or> disjAll \<Delta>s s vl s1 vl1"
  unfolding disjAll_def[abs_def] by auto

lemma iaction_mono:
assumes 1: "iaction \<Delta> s vl s1 vl1" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "iaction \<Delta>' s vl s1 vl1"
proof-
  obtain a1 ou1 s1' vl1'
  where "step s1 a1 = (ou1, s1')" and "\<phi> (Trans s1 a1 ou1 s1')"
  and "consume (Trans s1 a1 ou1 s1') vl1 vl1'" and "\<not> \<gamma> (Trans s1 a1 ou1 s1')"
  and "\<Delta> s vl s1' vl1'" using 1 unfolding iaction_def by auto
  thus ?thesis unfolding iaction_def using 2 apply -
  by (rule exI[of _ a1], rule exI[of _ ou1], rule exI[of _ s1'], rule exI[of _ vl1']) auto
qed

lemma match_mono:
assumes 1: "match \<Delta> s s1 vl1 a ou s' vl'" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "match \<Delta>' s s1 vl1 a ou s' vl'"
proof-
  obtain a1 ou1 s1' vl1'
  where "\<Delta> s' vl' s1' vl1'"
  and "step s1 a1 = (ou1, s1')"
  and "consume (Trans s1 a1 ou1 s1') vl1 vl1'"
  and "\<gamma> (Trans s a ou s') = \<gamma> (Trans s1 a1 ou1 s1')"
  and "(\<gamma> (Trans s a ou s') \<longrightarrow> g (Trans s a ou s') = g (Trans s1 a1 ou1 s1'))"
  using 1 unfolding match_def by auto
  thus ?thesis unfolding match_def using 2 apply -
  by (rule exI[of _ a1], rule exI[of _ ou1], rule exI[of _ s1'], rule exI[of _ vl1']) auto
qed

lemma ignore_mono:
assumes 1: "ignore \<Delta> s s1 vl1 a ou s' vl'" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "ignore \<Delta>' s s1 vl1 a ou s' vl'"
using assms unfolding ignore_def by auto

lemma reaction_mono:
assumes 1: "reaction \<Delta> s vl s1 vl1" and 2: "\<And> s vl s1 vl1. \<Delta> s vl s1 vl1 \<Longrightarrow> \<Delta>' s vl s1 vl1"
shows "reaction \<Delta>' s vl s1 vl1"
proof
  fix a ou s' vl'
  assume "step s a = (ou, s')" and "\<not> T (Trans s a ou s')" and "consume (Trans s a ou s') vl vl'"
  hence "match \<Delta> s s1 vl1 a ou s' vl' \<or> ignore \<Delta> s s1 vl1 a ou s' vl'" (is "?m \<or> ?i")
  using 1 unfolding reaction_def by auto
  thus "match \<Delta>' s s1 vl1 a ou s' vl' \<or> ignore \<Delta>' s s1 vl1 a ou s' vl'" (is "?m' \<or> ?i'")
  proof
    assume ?m from match_mono[OF this 2] show ?thesis by simp
  next
    assume ?i from ignore_mono[OF this 2] show ?thesis by simp
  qed
qed

subsection\<open>Decomposition into an arbitrary network of components\<close>

(* Unwind not to itself, but to a disjunction of other relations: *)
definition unwind_to where
"unwind_to \<Delta> \<Delta>s \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1
   \<longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)
   \<or>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   (vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1"

lemma unwind_toI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta> s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)
   \<or>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   (vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1"
shows "unwind_to \<Delta> \<Delta>s"
using assms unfolding unwind_to_def by auto

(* Decomposition: *)
lemma unwind_dec:
assumes ne: "\<And> \<Delta>. \<Delta> \<in> \<Delta>s \<Longrightarrow> next \<Delta> \<subseteq> \<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
shows "unwind (disjAll \<Delta>s)" (is "unwind ?\<Delta>")
proof
  fix s s1 :: 'state and vl vl1 :: "'value list"
  assume r: "reachNT s" "reach s1" and \<Delta>: "?\<Delta> s vl s1 vl1"
  then obtain \<Delta> where \<Delta>: "\<Delta> \<in> \<Delta>s" and 2: "\<Delta> s vl s1 vl1" unfolding disjAll_def by auto
  let ?\<Delta>s' = "next \<Delta>"  let ?\<Delta>' = "disjAll ?\<Delta>s'"
  have "(vl \<noteq> [] \<and> exit s (hd vl)) \<or>
        iaction ?\<Delta>' s vl s1 vl1 \<or>
        ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction ?\<Delta>' s vl s1 vl1)"
  using 2 \<Delta> ne r unfolding unwind_to_def by auto
  moreover have "\<And> s vl s1 vl1. ?\<Delta>' s vl s1 vl1 \<Longrightarrow> ?\<Delta> s vl s1 vl1"
  using ne[OF \<Delta>] unfolding disjAll_def by auto
  ultimately show
       "(vl \<noteq> [] \<and> exit s (hd vl)) \<or>
        iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)"
  using iaction_mono[of ?\<Delta>' _ _ _ _ ?\<Delta>] reaction_mono[of ?\<Delta>' _ _ _ _ ?\<Delta>] by blast
qed

lemma init_dec:
assumes \<Delta>0: "\<Delta>0 \<in> \<Delta>s"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>0 istate vl istate vl1"
shows "\<forall> vl vl1. B vl vl1 \<longrightarrow> disjAll \<Delta>s istate vl istate vl1"
using assms unfolding disjAll_def by auto

theorem unwind_dec_secure:
assumes \<Delta>0: "\<Delta>0 \<in> \<Delta>s"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>0 istate vl istate vl1"
and ne: "\<And> \<Delta>. \<Delta> \<in> \<Delta>s \<Longrightarrow> next \<Delta> \<subseteq> \<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
shows secure
using init_dec[OF \<Delta>0 i] unwind_dec[OF ne] unwind_secure by metis

subsection\<open>A customization for linear modular reasoning\<close>

(* The customization assumes that each component unwinds only into itself,
its successor or an exit component.  *)

definition unwind_cont where
"unwind_cont \<Delta> \<Delta>s \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1
   \<longrightarrow>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1)"

lemma unwind_contI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta> s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   iaction (disjAll \<Delta>s) s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction (disjAll \<Delta>s) s vl s1 vl1)"
shows "unwind_cont \<Delta> \<Delta>s"
using assms unfolding unwind_cont_def by auto

definition unwind_exit where
"unwind_exit \<Delta>e \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta>e s vl s1 vl1
   \<longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)"

lemma unwind_exitI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta>e s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   vl \<noteq> [] \<and> exit s (hd vl)"
shows "unwind_exit \<Delta>e"
using assms unfolding unwind_exit_def by auto

fun allConsec :: "'a list \<Rightarrow> ('a * 'a) set" where
  "allConsec [] = {}"
| "allConsec [a] = {}"
| "allConsec (a # b # as) = insert (a,b) (allConsec (b#as))"

lemma set_allConsec:
assumes "\<Delta> \<in> set \<Delta>s'" and "\<Delta>s = \<Delta>s' ## \<Delta>1"
shows "\<exists> \<Delta>2. (\<Delta>,\<Delta>2) \<in> allConsec \<Delta>s"
using assms proof (induction \<Delta>s' arbitrary: \<Delta>s)
  case Nil thus ?case by auto
next
  case (Cons \<Delta>3 \<Delta>s' \<Delta>s)
  show ?case proof(cases "\<Delta> = \<Delta>3")
    case True
    show ?thesis proof(cases \<Delta>s')
      case Nil
      show ?thesis unfolding \<open>\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1\<close> Nil True by (rule exI[of _ \<Delta>1]) simp
    next
      case (Cons \<Delta>4 \<Delta>s'')
      show ?thesis unfolding \<open>\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1\<close> Cons True by (rule exI[of _ \<Delta>4]) simp
    qed
  next
    case False hence "\<Delta> \<in> set \<Delta>s'" using Cons by auto
    then obtain \<Delta>2 where "(\<Delta>, \<Delta>2) \<in> allConsec (\<Delta>s' ## \<Delta>1)" using Cons by auto
    thus ?thesis unfolding \<open>\<Delta>s = (\<Delta>3 # \<Delta>s') ## \<Delta>1\<close> by (intro exI[of _ \<Delta>2]) (cases \<Delta>s', auto)
  qed
qed

lemma allConsec_set:
assumes "(\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s"
shows "\<Delta>1 \<in> set \<Delta>s \<and> \<Delta>2 \<in> set \<Delta>s"
using assms by (induct \<Delta>s rule: allConsec.induct) auto

(* Liniar decomposition: *)
theorem unwind_decomp_secure:
assumes n: "\<Delta>s \<noteq> []"
and i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> hd \<Delta>s istate vl istate vl1"
and c: "\<And> \<Delta>1 \<Delta>2. (\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s \<Longrightarrow> unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and l: "unwind_cont (last \<Delta>s) {last \<Delta>s, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
proof-
  let ?\<Delta>0 = "hd \<Delta>s"  let ?\<Delta>s = "insert \<Delta>e (set \<Delta>s)"
  define "next" where "next \<Delta>1 =
    (if \<Delta>1 = \<Delta>e then {}
     else if \<Delta>1 = last \<Delta>s then {\<Delta>1,\<Delta>e}
     else {\<Delta>1,SOME \<Delta>2. (\<Delta>1,\<Delta>2) \<in> allConsec \<Delta>s,\<Delta>e})" for \<Delta>1
  show ?thesis
  proof(rule unwind_dec_secure)
    show "?\<Delta>0 \<in> ?\<Delta>s" using n by auto
  next
    fix vl vl1 assume "B vl vl1"
    thus "?\<Delta>0 istate vl istate vl1" by fact
  next
    fix \<Delta>
    assume 1: "\<Delta> \<in> ?\<Delta>s" show "next \<Delta> \<subseteq> ?\<Delta>s \<and> unwind_to \<Delta> (next \<Delta>)"
    proof-
      {assume "\<Delta> = \<Delta>e"
       hence ?thesis using e unfolding next_def unwind_exit_def unwind_to_def by auto
      }
      moreover
      {assume "\<Delta> = last \<Delta>s" and "\<Delta> \<noteq> \<Delta>e"
       hence ?thesis using n l unfolding next_def unwind_cont_def unwind_to_def by simp
      }
      moreover
      {assume 1: "\<Delta> \<in> set \<Delta>s" and 2: "\<Delta> \<noteq> last \<Delta>s" "\<Delta> \<noteq> \<Delta>e"
       then obtain \<Delta>' \<Delta>s' where \<Delta>s: "\<Delta>s = \<Delta>s' ## \<Delta>'" and \<Delta>: "\<Delta> \<in> set \<Delta>s'"
       by (metis (no_types) append_Cons append_assoc in_set_conv_decomp last_snoc rev_exhaust)
       have "\<exists> \<Delta>2. (\<Delta>, \<Delta>2) \<in> allConsec \<Delta>s" using set_allConsec[OF \<Delta> \<Delta>s] .
       hence "(\<Delta>, SOME \<Delta>2. (\<Delta>, \<Delta>2) \<in> allConsec \<Delta>s) \<in> allConsec \<Delta>s" by (metis (lifting) someI_ex)
       hence ?thesis using 1 2 c unfolding next_def unwind_cont_def unwind_to_def
       by simp (metis (no_types) allConsec_set)
      }
      ultimately show ?thesis using 1 by blast
    qed
  qed
qed

subsection\<open>Instances\<close>

corollary unwind_decomp3_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and l: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3]" \<Delta>e])
using assms by auto

corollary unwind_decomp4_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and c3: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>4, \<Delta>e}"
and l: "unwind_cont \<Delta>4 {\<Delta>4, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3, \<Delta>4]" \<Delta>e])
using assms by auto

corollary unwind_decomp5_secure:
assumes
i: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta>1 istate vl istate vl1"
and c1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>2, \<Delta>e}"
and c2: "unwind_cont \<Delta>2 {\<Delta>2, \<Delta>3, \<Delta>e}"
and c3: "unwind_cont \<Delta>3 {\<Delta>3, \<Delta>4, \<Delta>e}"
and c4: "unwind_cont \<Delta>4 {\<Delta>4, \<Delta>5, \<Delta>e}"
and l: "unwind_cont \<Delta>5 {\<Delta>5, \<Delta>e}"
and e: "unwind_exit \<Delta>e"
shows secure
apply(rule unwind_decomp_secure[of "[\<Delta>1, \<Delta>2, \<Delta>3, \<Delta>4, \<Delta>5]" \<Delta>e])
using assms by auto

(*<*)

end (* context BD_Security *)

end

(*>*)


theory Incredible_Propositional_Tasks
imports
  Incredible_Completeness
  Incredible_Propositional
begin

context ND_Rules_Inst begin
lemma eff_NatRuleI:
  "nat_rule rule c ants
    \<Longrightarrow> entail = (\<Gamma> \<turnstile> subst s (freshen a c))
    \<Longrightarrow> hyps = ((\<lambda>ant. ((\<lambda>p. subst s (freshen a p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen a (a_conc ant)))) |`| ants)
    \<Longrightarrow> (\<And> ant f. ant |\<in>| ants \<Longrightarrow> f |\<in>| \<Gamma> \<Longrightarrow> freshenLC a ` (a_fresh ant) \<inter> lconsts f = {})
    \<Longrightarrow> (\<And> ant. ant |\<in>| ants \<Longrightarrow> freshenLC a ` (a_fresh ant) \<inter> subst_lconsts s = {})
    \<Longrightarrow> eff (NatRule rule) entail hyps"
  by (drule eff.intros(2)) simp_all
end

context Abstract_Task begin
lemma  natEff_InstI:
  "rule = (r,c)
  \<Longrightarrow> c \<in> set (consequent r)
  \<Longrightarrow> antec = f_antecedent r
  \<Longrightarrow> natEff_Inst rule c antec"
  by (metis natEff_Inst.intros)
end

context begin

subsubsection \<open>Task 1.1\<close>

text \<open>This is the very first task of the Incredible Proof Machine: @{term "A \<longrightarrow> A"}\<close>

abbreviation A :: "(string,prop_funs) pform"
  where "A \<equiv> Fun (Const ''A'') []"

text \<open>First the task is defined as an @{term Abstract_Task}.\<close>

interpretation task1_1: Abstract_Task
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
  "[A]"
  "[A]"
by unfold_locales simp

text \<open>Then we show, that this task has a proof within our formalization of natural deduction
  by giving a concrete proof tree.\<close>

lemma "task1_1.solved"
  unfolding task1_1.solved_def
apply clarsimp
apply (rule_tac x="{|A|}" in exI)
apply clarsimp
apply (rule_tac x="Node ({|A|} \<turnstile> A, Axiom) {||}" in exI)
apply clarsimp
apply (rule conjI)
 apply (rule task1_1.wf)
   apply (solves clarsimp)
  apply clarsimp
  apply (rule task1_1.eff.intros(1))
  apply (solves simp)
 apply (solves clarsimp)
by (auto intro: tfinite.intros)

print_locale Vertex_Graph
interpretation task1_1: Vertex_Graph task1_1.nodes task1_1.inPorts task1_1.outPorts "{|0::nat,1|}"
  "undefined(0 := Assumption A, 1 := Conclusion A)"
.

print_locale Pre_Port_Graph
interpretation task1_1: Pre_Port_Graph task1_1.nodes task1_1.inPorts task1_1.outPorts "{|0::nat,1|}"
  "undefined(0 := Assumption A, 1 := Conclusion A)"
  "{((0,Reg A),(1,plain_ant A))}"
.

print_locale Instantiation
interpretation task1_1: Instantiation
  task1_1.inPorts
  task1_1.outPorts
  "undefined(0 := Assumption A, 1 := Conclusion A)"
  task1_1.hyps
  task1_1.nodes
  "{((0,Reg A),(1,plain_ant A))}"
  "{|0::nat,1|}"
  task1_1.labelsIn
  task1_1.labelsOut
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  "id"
  "undefined"
by unfold_locales simp

declare One_nat_def [simp del]

lemma path_one_edge[simp]:
  "task1_1.path v1 v2 pth \<longleftrightarrow>
    (v1 = 0 \<and> v2 = 1 \<and> pth = [((0,Reg A),(1,plain_ant A))] \<or>
    pth = [] \<and> v1 = v2)"
  apply (cases pth)
  apply (auto simp add: task1_1.path_cons_simp')
  apply (rename_tac list, case_tac list, auto simp add: task1_1.path_cons_simp')+
  done

text \<open>Finally we can also show that there is a proof graph for this task.\<close>

interpretation Tasked_Proof_Graph
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
  "[A]"
  "[A]"
  "{|0::nat,1|}"
  "undefined(0 := Assumption A, 1 := Conclusion A)"
  "{((0,Reg A),(1,plain_ant A))}"
  "id"
  "undefined"
apply unfold_locales
        apply (solves simp)
       apply (solves clarsimp)
      apply (solves clarsimp)
     apply (solves clarsimp)
    apply (solves fastforce)
   apply (solves fastforce)
  apply (solves \<open>clarsimp simp add: task1_1.labelAtOut_def task1_1.labelAtIn_def\<close>)
 apply (solves clarsimp)
apply (solves clarsimp)
done

subsubsection \<open>Task 2.11\<close>

text \<open>This is a slightly more interesting task as it involves both our connectives: @{term "P \<and> Q \<longrightarrow> R \<Longrightarrow> P \<longrightarrow> (Q \<longrightarrow> R)"}\<close>

abbreviation B :: "(string,prop_funs) pform"
  where "B \<equiv> Fun (Const ''B'') []"
abbreviation C :: "(string,prop_funs) pform"
  where "C \<equiv> Fun (Const ''C'') []"

interpretation task2_11: Abstract_Task
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
  "[Fun imp [Fun and [A,B],C]]"
  "[Fun imp [A,Fun imp [B,C]]]"
by unfold_locales simp_all

abbreviation "n_andI \<equiv> task2_11.n_rules !! 0"
abbreviation "n_andE1 \<equiv> task2_11.n_rules !! 1"
abbreviation "n_andE2 \<equiv> task2_11.n_rules !! 2"
abbreviation "n_impI \<equiv> task2_11.n_rules !! 3"
abbreviation "n_impE \<equiv> task2_11.n_rules !! 4"

lemma n_andI [simp]: "n_andI = (andI, Fun and [X,Y])"
  unfolding task2_11.n_rules_def by (simp add: prop_rules_def)
lemma n_andE1 [simp]: "n_andE1 = (andE, X)"
  unfolding task2_11.n_rules_def One_nat_def by (simp add: prop_rules_def)
lemma n_andE2 [simp]: "n_andE2 = (andE, Y)"
  unfolding task2_11.n_rules_def numeral_2_eq_2 by (simp add: prop_rules_def)
lemma n_impI [simp]: "n_impI = (impI, Fun imp [X,Y])"
  unfolding task2_11.n_rules_def numeral_3_eq_3 by (simp add: prop_rules_def)
lemma n_impE [simp]: "n_impE = (impE, Y)"
proof -
  have "n_impE = task2_11.n_rules !! Suc 3" by simp
  also have "... = (impE, Y)"
  unfolding task2_11.n_rules_def numeral_3_eq_3 by (simp add: prop_rules_def)
  finally show ?thesis .
qed

lemma subst_Var_eq_id [simp]: "subst Var = id"
  by (rule ext) (induct_tac x; auto simp: map_idI)

lemma xy_update: "f = undefined(''X'' := x, ''Y'' := y) \<Longrightarrow> x = f ''X'' \<and> y = f ''Y''" by force
lemma y_update: "f = undefined(''Y'':=y) \<Longrightarrow> y = f ''Y''" by force

declare snth.simps(1) [simp del]

text \<open>By interpreting @{term Solved_Task} we show that there is a proof tree for the task.
  We get the existence of the proof graph for free by using the completeness theorem.\<close>

interpretation task2_11: Solved_Task
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
  "[Fun imp [Fun and [A,B],C]]"
  "[Fun imp [A,Fun imp [B,C]]]"
apply unfold_locales
  unfolding task2_11.solved_def
apply clarsimp
apply (rule_tac x="{|Fun imp [Fun and [A,B],C]|}" in exI)
apply clarsimp
\<comment> \<open>The actual proof tree for this task.\<close>
apply (rule_tac x="Node ({|Fun imp [Fun and [A, B], C]|} \<turnstile> Fun imp [A, Fun imp [B, C]],NatRule n_impI)
  {|Node ({|Fun imp [Fun and [A, B], C], A|} \<turnstile> Fun imp [B,C],NatRule n_impI)
    {|Node ({|Fun imp [Fun and [A, B], C], A, B|} \<turnstile> C,NatRule n_impE)
      {|Node ({|Fun imp [Fun and [A, B], C], A, B|} \<turnstile> Fun imp [Fun and [A,B], C],Axiom) {||},
        Node ({|Fun imp [Fun and [A, B], C], A, B|} \<turnstile> Fun and [A,B],NatRule n_andI)
          {|Node ({|Fun imp [Fun and [A, B], C], A, B|} \<turnstile> A,Axiom) {||},
            Node ({|Fun imp [Fun and [A, B], C], A, B|} \<turnstile> B,Axiom) {||}
          |}
      |}
    |}
  |}" in exI)
apply clarsimp
apply (rule conjI)

 apply (rule task1_1.wf)
   apply (solves \<open>clarsimp; metis n_impI snth_smap snth_sset\<close>)
  apply clarsimp
  apply (rule task1_1.eff_NatRuleI [unfolded propositional.freshen_def, simplified]) apply simp_all[4]
    apply (rule task2_11.natEff_InstI)
      apply (solves simp)
     apply (solves simp)
    apply (solves simp)
   apply (intro conjI; simp; rule xy_update)
   apply (solves simp)
  apply (solves \<open>fastforce simp: propositional.f_antecedent_def\<close>)
 apply clarsimp

 apply (rule task1_1.wf)
   apply (solves \<open>clarsimp; metis n_impI snth_smap snth_sset\<close>)
  apply clarsimp
  apply (rule task1_1.eff_NatRuleI [unfolded propositional.freshen_def, simplified]) apply simp_all[4]
    apply (rule task2_11.natEff_InstI)
      apply (solves simp)
     apply (solves simp)
    apply (solves simp)
   apply (intro conjI; simp; rule xy_update)
   apply (solves simp)
  apply (solves \<open>fastforce simp: propositional.f_antecedent_def\<close>)
 apply clarsimp

 apply (rule task1_1.wf)
   apply (solves \<open>clarsimp; metis n_impE snth_smap snth_sset\<close>)
  apply clarsimp
  apply (rule task1_1.eff_NatRuleI [unfolded propositional.freshen_def, simplified, where s="undefined(''Y'':=C,''X'':=Fun and [A,B])"]) apply simp_all[4]
    apply (rule task2_11.natEff_InstI)
      apply (solves simp)
     apply (solves simp)
    apply (solves simp)
   apply (solves \<open>intro conjI; simp\<close>)
  apply (solves \<open>simp add: propositional.f_antecedent_def\<close>)
 apply (erule disjE)

  apply (auto intro: task1_1.wf intro!: task1_1.eff.intros(1))[1]

 apply (rule task1_1.wf)
   apply (solves \<open>clarsimp; metis n_andI snth_smap snth_sset\<close>)
  apply clarsimp
  apply (rule task1_1.eff_NatRuleI [unfolded propositional.freshen_def, simplified]) apply simp_all[4]
    apply (rule task2_11.natEff_InstI)
      apply (solves simp)
     apply (solves simp)
    apply (solves simp)
   apply (intro conjI; simp; rule xy_update)
   apply (solves simp)
  apply (solves \<open>simp add: propositional.f_antecedent_def\<close>)
 apply clarsimp

 apply (erule disjE)
  apply (solves \<open>rule task1_1.wf; auto intro: task1_1.eff.intros(1)\<close>)
 apply (solves \<open>rule task1_1.wf; auto intro: task1_1.eff.intros(1)\<close>)

by (rule tfinite.intros; auto)+

interpretation Tasked_Proof_Graph
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
  "[Fun imp [Fun and [A,B],C]]"
  "[Fun imp [A,Fun imp [B,C]]]"
  task2_11.vertices
  task2_11.nodeOf
  task2_11.edges
  task2_11.vidx
  task2_11.inst
by unfold_locales

end

end