(*  File:       Elect_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>Elect Composition\<close>

theory Elect_Composition
  imports "Basic_Modules/Elect_Module"
          Sequential_Composition
begin

text
\<open>The elect composition sequences an electoral module and the elect
module. It finalizes the module's decision as it simply elects all their
non-rejected alternatives. Thereby, any such elect-composed module induces
a proper voting rule in the social choice sense, as all alternatives are either
rejected or elected.\<close>

subsection \<open>Definition\<close>

fun elector :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "elector m = (m \<triangleright> elect_module)"

subsection \<open>Soundness\<close>

theorem elector_sound[simp]:
  assumes module_m: "electoral_module m"
  shows "electoral_module (elector m)"
  by (simp add: module_m)

subsection \<open>Electing\<close>

theorem elector_electing[simp]:
  assumes
    module_m: "electoral_module m" and
    non_block_m: "non_blocking m"
  shows "electing (elector m)"
proof -
  obtain
    AA :: "'a Electoral_Module \<Rightarrow> 'a set" and
    rrs :: "'a Electoral_Module \<Rightarrow> 'a Profile" where
    f1:
    "\<forall>f.
      (electing f \<or>
        {} = elect f (AA f) (rrs f) \<and> profile (AA f) (rrs f) \<and>
            finite (AA f) \<and> {} \<noteq> AA f \<or>
        \<not> electoral_module f) \<and>
            ((\<forall>A rs. {} \<noteq> elect f A rs \<or> \<not> profile A rs \<or>
                infinite A \<or> {} = A) \<and>
            electoral_module f \<or>
        \<not> electing f)"
    using electing_def
    by metis
  have non_block:
    "non_blocking
      (elect_module::'a set \<Rightarrow> _ Profile \<Rightarrow> _ Result)"
    by (simp add: electing_imp_non_blocking)
  thus ?thesis
    (* using f1 Diff_empty elect_module.elims elector.simps non_block_m
          non_blocking_def reject_not_elec_or_def seq_comp_defers_def_set
          seq_comp_presv_non_blocking snd_conv elect_mod_sound fst_conv
          elect_module.simps elector_sound module_m disjoint3.cases
          empty_iff ex_in_conv seq_comp_def_set_trans *)
  proof -
    obtain
      AAa :: "'a Electoral_Module \<Rightarrow> 'a set" and
      rrsa :: "'a Electoral_Module \<Rightarrow> 'a Profile" where
      f1:
      "\<forall>f.
        (electing f \<or>
          {} = elect f (AAa f) (rrsa f) \<and> profile (AAa f) (rrsa f) \<and>
              finite (AAa f) \<and> {} \<noteq> AAa f \<or>
        \<not> electoral_module f) \<and> ((\<forall>A rs. {} \<noteq> elect f A rs \<or>
        \<not> profile A rs \<or> infinite A \<or> {} = A) \<and> electoral_module f \<or>
        \<not> electing f)"
      using electing_def
      by metis
    obtain
      AAb :: "'a Result \<Rightarrow> 'a set" and
      AAc :: "'a Result \<Rightarrow> 'a set" and
      AAd :: "'a Result \<Rightarrow> 'a set" where
      f2:
      "\<forall>p. (AAb p, AAc p, AAd p) = p"
      using disjoint3.cases
      by (metis (no_types))
    have f3:
      "electoral_module (elector m)"
      using elector_sound module_m
      by simp
    have f4:
      "\<forall>p. (elect_r p, AAc p, AAd p) = p"
      using f2
      by simp
    have
      "finite (AAa (elector m)) \<and>
        profile (AAa (elector m)) (rrsa (elector m)) \<and>
        {} = elect (elector m) (AAa (elector m)) (rrsa (elector m)) \<and>
        {} = AAd (elector m (AAa (elector m)) (rrsa (elector m))) \<and>
        reject (elector m) (AAa (elector m)) (rrsa (elector m)) =
          AAc (elector m (AAa (elector m)) (rrsa (elector m))) \<longrightarrow>
              electing (elector m)"
      using f2 f1 Diff_empty elector.simps non_block_m snd_conv
            non_blocking_def reject_not_elec_or_def non_block
            seq_comp_presv_non_blocking
      by metis
    moreover
    {
      assume
        "{} \<noteq> AAd (elector m (AAa (elector m)) (rrsa (elector m)))"
      hence
        "\<not> profile (AAa (elector m)) (rrsa (elector m)) \<or>
          infinite (AAa (elector m))"
        using f4
        by simp
    }
    ultimately show ?thesis
      using f4 f3 f1 fst_conv snd_conv
      by metis
  qed
qed

subsection \<open>Composition Rule\<close>

(*If m is defer-Condorcet-consistent, then elector(m) is Condorcet consistent.*)
lemma dcc_imp_cc_elector:
  assumes dcc: "defer_condorcet_consistency m"
  shows "condorcet_consistency (elector m)"
proof (unfold defer_condorcet_consistency_def
              condorcet_consistency_def, auto)
  show "electoral_module (m \<triangleright> elect_module)"
    using dcc defer_condorcet_consistency_def
          elect_mod_sound seq_comp_sound
    by metis
next
  show
    "\<And>A p w x.
       finite A \<Longrightarrow> profile A p \<Longrightarrow> w \<in> A \<Longrightarrow>
         \<forall>x\<in>A - {w}. card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)} \<Longrightarrow>
        x \<in> elect m A p \<Longrightarrow> x \<in> A"
  proof -
    fix
      A :: "'a set" and
      p :: "'a Profile" and
      w :: "'a" and
      x :: "'a"
    assume
      finite: "finite A" and
      prof_A: "profile A p"
    show
      "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)} \<Longrightarrow>
             x \<in> elect m A p \<Longrightarrow> x \<in> A"
      using dcc defer_condorcet_consistency_def
            elect_in_alts subset_eq finite prof_A
      by metis
  qed
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    1: "x \<in> elect m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "xa = x"
    using condorcet_winner.simps dcc fst_conv insert_Diff "1"
          defer_condorcet_consistency_def insert_not_empty
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    0: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    1: "x \<in> defer m A p"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "0"
    by simp
  thus "x \<in> A"
    using "0" "1" condorcet_winner.simps dcc defer_in_alts
          defer_condorcet_consistency_def order_trans
          subset_Compl_singleton
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    1: "x \<in> defer m A p" and
    xa_in_A: "xa \<in> A" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    3: "\<not> card {i. i < length p \<and> (x, xa) \<in> (p!i)} <
            card {i. i < length p \<and> (xa, x) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "xa = x"
    using "1" "2" condorcet_winner.simps dcc empty_iff xa_in_A
          defer_condorcet_consistency_def "3" DiffI
          cond_winner_unique3 insert_iff prod.sel(2)
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    x_in_A: "x \<in> A" and
    1: "x \<notin> defer m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    3: "\<forall>y\<in>A - {x}.
          card {i. i < length p \<and> (x, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, x) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  also have "condorcet_winner A p x"
    using finite prof_A x_in_A "3"
    by simp
  ultimately show "x \<in> elect m A p"
    using "1" condorcet_winner.simps dcc
          defer_condorcet_consistency_def
          cond_winner_unique3 insert_iff eq_snd_iff
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    1: "x \<in> reject m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "x \<in> A"
    using "1" dcc defer_condorcet_consistency_def finite
          prof_A reject_in_alts subsetD
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    0: "x \<in> reject m A p" and
    1: "x \<in> elect m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "False"
    using "0" "1" condorcet_winner.simps dcc IntI empty_iff
          defer_condorcet_consistency_def result_disj
    by (metis (no_types, hide_lams))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    0: "x \<in> reject m A p" and
    1: "x \<in> defer m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "False"
    using "0" "1" dcc defer_condorcet_consistency_def IntI
          Diff_empty Diff_iff finite prof_A result_disj
    by (metis (no_types, hide_lams))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    x_in_A: "x \<in> A" and
    0: "x \<notin> reject m A p" and
    1: "x \<notin> defer m A p" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "x \<in> elect m A p"
    using "0" "1" condorcet_winner.simps dcc x_in_A
          defer_condorcet_consistency_def electoral_mod_defer_elem
    by (metis (no_types, lifting))
qed

end


(*  Title:       Calculi Based on a Redundancy Criterion
 *  Author:      Sophie Tourret <stourret at mpi-inf.mpg.de>, 2018-2020 *)

section \<open>Calculi Based on a Redundancy Criterion\<close>

text \<open>This section introduces the most basic notions upon which the framework is
  built: consequence relations and inference systems. It also defines the notion
  of a family of consequence relations and of redundancy criteria. This
  corresponds to sections 2.1 and 2.2 of the report.\<close>

theory Calculus
  imports
    Ordered_Resolution_Prover.Lazy_List_Liminf
    Ordered_Resolution_Prover.Lazy_List_Chain
begin

subsection \<open>Consequence Relations\<close>

locale consequence_relation =
  fixes
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50)
  assumes
    bot_not_empty: "Bot \<noteq> {}" and
    bot_entails_all: "B \<in> Bot \<Longrightarrow> {B} \<Turnstile> N1" and
    subset_entailed: "N2 \<subseteq> N1 \<Longrightarrow> N1 \<Turnstile> N2" and
    all_formulas_entailed: "(\<forall>C \<in> N2. N1 \<Turnstile> {C}) \<Longrightarrow> N1 \<Turnstile> N2" and
    entails_trans[trans]: "N1 \<Turnstile> N2 \<Longrightarrow> N2 \<Turnstile> N3 \<Longrightarrow> N1 \<Turnstile> N3"
begin

lemma entail_set_all_formulas: "N1 \<Turnstile> N2 \<longleftrightarrow> (\<forall>C \<in> N2. N1 \<Turnstile> {C})"
  by (meson all_formulas_entailed empty_subsetI insert_subset subset_entailed entails_trans)

lemma entail_union: "N \<Turnstile> N1 \<and> N \<Turnstile> N2 \<longleftrightarrow> N \<Turnstile> N1 \<union> N2"
  using entail_set_all_formulas[of N N1] entail_set_all_formulas[of N N2]
    entail_set_all_formulas[of N "N1 \<union> N2"] by blast

lemma entail_unions: "(\<forall>i \<in> I. N \<Turnstile> Ni i) \<longleftrightarrow> N \<Turnstile> \<Union> (Ni ` I)"
  using entail_set_all_formulas[of N "\<Union> (Ni ` I)"] entail_set_all_formulas[of N]
    Complete_Lattices.UN_ball_bex_simps(2)[of Ni I "\<lambda>C. N \<Turnstile> {C}", symmetric]
  by meson

lemma entail_all_bot: "(\<exists>B \<in> Bot. N \<Turnstile> {B}) \<Longrightarrow> \<forall>B' \<in> Bot. N \<Turnstile> {B'}"
  using bot_entails_all entails_trans by blast

lemma entails_trans_strong: "N1 \<Turnstile> N2 \<Longrightarrow> N1 \<union> N2 \<Turnstile> N3 \<Longrightarrow> N1 \<Turnstile> N3"
  by (meson entail_union entails_trans order_refl subset_entailed)

end

subsection \<open>Families of Consequence Relations\<close>

locale consequence_relation_family =
  fixes
    Bot :: "'f set" and
    Q :: "'q set" and
    entails_q :: "'q \<Rightarrow> 'f set \<Rightarrow> 'f set \<Rightarrow> bool"
  assumes
    Q_nonempty: "Q \<noteq> {}" and
    q_cons_rel: "\<forall>q \<in> Q. consequence_relation Bot (entails_q q)"
begin

lemma bot_not_empty: "Bot \<noteq> {}"
  using Q_nonempty consequence_relation.bot_not_empty consequence_relation_family.q_cons_rel
    consequence_relation_family_axioms by blast

definition entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>Q" 50) where
  "N1 \<Turnstile>Q N2 \<longleftrightarrow> (\<forall>q \<in> Q. entails_q q N1 N2)"

(* lem:intersection-of-conseq-rel *)
lemma intersect_cons_rel_family: "consequence_relation Bot entails"
  unfolding consequence_relation_def entails_def
  by (intro conjI bot_not_empty) (metis consequence_relation_def q_cons_rel)+

end

subsection \<open>Inference Systems\<close>

datatype 'f inference =
  Infer (prems_of: "'f list") (concl_of: "'f")

locale inference_system =
  fixes
    Inf :: \<open>'f inference set\<close>
begin

definition Inf_from :: "'f set \<Rightarrow> 'f inference set" where
  "Inf_from N = {\<iota> \<in> Inf. set (prems_of \<iota>) \<subseteq> N}"

definition Inf_between :: "'f set \<Rightarrow> 'f set \<Rightarrow> 'f inference set" where
  "Inf_between N M = Inf_from (N \<union> M) - Inf_from (N - M)"

lemma Inf_if_Inf_from: "\<iota> \<in> Inf_from N \<Longrightarrow> \<iota> \<in> Inf"
  unfolding Inf_from_def by simp

lemma Inf_if_Inf_between: "\<iota> \<in> Inf_between N M \<Longrightarrow> \<iota> \<in> Inf"
  unfolding Inf_between_def Inf_from_def by simp

lemma Inf_between_alt:
  "Inf_between N M = {\<iota> \<in> Inf. \<iota> \<in> Inf_from (N \<union> M) \<and> set (prems_of \<iota>) \<inter> M \<noteq> {}}"
  unfolding Inf_from_def Inf_between_def by auto

lemma Inf_from_mono: "N \<subseteq> N' \<Longrightarrow> Inf_from N \<subseteq> Inf_from N'"
  unfolding Inf_from_def by auto

lemma Inf_between_mono: "N \<subseteq> N' \<Longrightarrow> M \<subseteq> M' \<Longrightarrow> Inf_between N M \<subseteq> Inf_between N' M'"
  unfolding Inf_between_alt using Inf_from_mono[of "N \<union> M" "N' \<union> M'"] by auto

end

subsection \<open>Families of Inference Systems\<close>

locale inference_system_family =
  fixes
    Q :: "'q set" and
    Inf_q :: "'q \<Rightarrow> 'f inference set"
  assumes
    Q_nonempty: "Q \<noteq> {}"
begin

definition Inf_from_q :: "'q \<Rightarrow> 'f set \<Rightarrow> 'f inference set" where
  "Inf_from_q q = inference_system.Inf_from (Inf_q q)"

definition Inf_between_q :: "'q \<Rightarrow> 'f set \<Rightarrow> 'f set \<Rightarrow> 'f inference set" where
  "Inf_between_q q = inference_system.Inf_between (Inf_q q)"

lemma Inf_between_q_alt:
  "Inf_between_q q N M = {\<iota> \<in> Inf_q q. \<iota> \<in> Inf_from_q q (N \<union> M) \<and> set (prems_of \<iota>) \<inter> M \<noteq> {}}"
  unfolding Inf_from_q_def Inf_between_q_def inference_system.Inf_between_alt by auto

end

subsection \<open>Calculi Based on a Single Redundancy Criterion\<close>

locale calculus = inference_system Inf + consequence_relation Bot entails
  for
    Bot :: "'f set" and
    Inf :: \<open>'f inference set\<close> and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50)
  + fixes
    Red_I :: "'f set \<Rightarrow> 'f inference set" and
    Red_F :: "'f set \<Rightarrow> 'f set"
  assumes
    Red_I_to_Inf: "Red_I N \<subseteq> Inf" and
    Red_F_Bot: "B \<in> Bot \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> N - Red_F N \<Turnstile> {B}" and
    Red_F_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_F N \<subseteq> Red_F N'" and
    Red_I_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_I N \<subseteq> Red_I N'" and
    Red_F_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_F N \<subseteq> Red_F (N - N')" and
    Red_I_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_I N \<subseteq> Red_I (N - N')" and
    Red_I_of_Inf_to_N: "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> \<in> N \<Longrightarrow> \<iota> \<in> Red_I N"
begin

lemma Red_I_of_Inf_to_N_subset: "{\<iota> \<in> Inf. concl_of \<iota> \<in> N} \<subseteq> Red_I N"
  using Red_I_of_Inf_to_N by blast

(* lem:red-concl-implies-red-inf *)
lemma red_concl_to_red_inf:
  assumes
    i_in: "\<iota> \<in> Inf" and
    concl: "concl_of \<iota> \<in> Red_F N"
  shows "\<iota> \<in> Red_I N"
proof -
  have "\<iota> \<in> Red_I (Red_F N)" by (simp add: Red_I_of_Inf_to_N i_in concl)
  then have i_in_Red: "\<iota> \<in> Red_I (N \<union> Red_F N)" by (simp add: Red_I_of_Inf_to_N concl i_in)
  have red_n_subs: "Red_F N \<subseteq> Red_F (N \<union> Red_F N)" by (simp add: Red_F_of_subset)
  then have "\<iota> \<in> Red_I ((N \<union> Red_F N) - (Red_F N - N))" using Red_I_of_Red_F_subset i_in_Red
    by (meson Diff_subset subsetCE subset_trans)
  then show ?thesis by (metis Diff_cancel Diff_subset Un_Diff Un_Diff_cancel contra_subsetD
    calculus.Red_I_of_subset calculus_axioms sup_bot.right_neutral)
qed

definition saturated :: "'f set \<Rightarrow> bool" where
  "saturated N \<longleftrightarrow> Inf_from N \<subseteq> Red_I N"

definition reduc_saturated :: "'f set \<Rightarrow> bool" where
  "reduc_saturated N \<longleftrightarrow> Inf_from (N - Red_F N) \<subseteq> Red_I N"

lemma Red_I_without_red_F:
  "Red_I (N - Red_F N) = Red_I N"
  using Red_I_of_subset [of "N - Red_F N" N]
    and Red_I_of_Red_F_subset [of "Red_F N" N] by blast

lemma saturated_without_red_F:
  assumes saturated: "saturated N"
  shows "saturated (N - Red_F N)"
proof -
  have "Inf_from (N - Red_F N) \<subseteq> Inf_from N" unfolding Inf_from_def by auto
  also have "Inf_from N \<subseteq> Red_I N" using saturated unfolding saturated_def by auto
  also have "Red_I N \<subseteq> Red_I (N - Red_F N)" using Red_I_of_Red_F_subset by auto
  finally have "Inf_from (N - Red_F N) \<subseteq> Red_I (N - Red_F N)" by auto
  then show ?thesis unfolding saturated_def by auto
qed

definition fair :: "'f set llist \<Rightarrow> bool" where
  "fair Ns \<longleftrightarrow> Inf_from (Liminf_llist Ns) \<subseteq> Sup_llist (lmap Red_I Ns)"

inductive "derive" :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<rhd>" 50) where
  derive: "M - N \<subseteq> Red_F N \<Longrightarrow> M \<rhd> N"

lemma gt_Max_notin: \<open>finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> x > Max A \<Longrightarrow> x \<notin> A\<close> by auto

lemma equiv_Sup_Liminf:
  assumes
    in_Sup: "C \<in> Sup_llist Ns" and
    not_in_Liminf: "C \<notin> Liminf_llist Ns"
  shows
    "\<exists>i \<in> {i. enat (Suc i) < llength Ns}. C \<in> lnth Ns i - lnth Ns (Suc i)"
proof -
  obtain i where C_D_i: "C \<in> Sup_upto_llist Ns (enat i)" and "enat i < llength Ns"
    using elem_Sup_llist_imp_Sup_upto_llist in_Sup by fast
  then obtain j where j: "j \<ge> i \<and> enat j < llength Ns \<and> C \<notin> lnth Ns j"
    using not_in_Liminf unfolding Sup_upto_llist_def chain_def Liminf_llist_def by auto
  obtain k where k: "C \<in> lnth Ns k" "enat k < llength Ns" "k \<le> i" using C_D_i
    unfolding Sup_upto_llist_def by auto
  let ?S = "{i. i < j \<and> i \<ge> k \<and> C \<in> lnth Ns i}"
  define l where "l = Max ?S"
  have \<open>k \<in> {i. i < j \<and> k \<le> i \<and> C \<in> lnth Ns i}\<close> using k j by (auto simp: order.order_iff_strict)
  then have nempty: "{i. i < j \<and> k \<le> i \<and> C \<in> lnth Ns i} \<noteq> {}" by auto
  then have l_prop: "l < j \<and> l \<ge> k \<and> C \<in> lnth Ns l" using Max_in[of ?S, OF _ nempty]
    unfolding l_def by auto
  then have "C \<in> lnth Ns l - lnth Ns (Suc l)" using j gt_Max_notin[OF _ nempty, of "Suc l"]
    unfolding l_def[symmetric] by (auto intro: Suc_lessI)
  then show ?thesis
  proof (rule bexI[of _ l])
    show "l \<in> {i. enat (Suc i) < llength Ns}"
      using l_prop j
      by (clarify, metis Suc_leI dual_order.order_iff_strict enat_ord_simps(2) less_trans)
  qed
qed

(* lem:nonpersistent-is-redundant *)
lemma Red_in_Sup:
  assumes deriv: "chain (\<rhd>) Ns"
  shows "Sup_llist Ns - Liminf_llist Ns \<subseteq> Red_F (Sup_llist Ns)"
proof
  fix C
  assume C_in_subset: "C \<in> Sup_llist Ns - Liminf_llist Ns"
  {
    fix C i
    assume
      in_ith_elem: "C \<in> lnth Ns i - lnth Ns (Suc i)" and
      i: "enat (Suc i) < llength Ns"
    have "lnth Ns i \<rhd> lnth Ns (Suc i)" using i deriv in_ith_elem chain_lnth_rel by auto
    then have "C \<in> Red_F (lnth Ns (Suc i))" using in_ith_elem derive.cases by blast
    then have "C \<in> Red_F (Sup_llist Ns)" using Red_F_of_subset
      by (meson contra_subsetD i lnth_subset_Sup_llist)
  }
  then show "C \<in> Red_F (Sup_llist Ns)" using equiv_Sup_Liminf[of C] C_in_subset by fast
qed

(* lem:redundant-remains-redundant-during-run 1/2 *)
lemma Red_I_subset_Liminf:
  assumes deriv: \<open>chain (\<rhd>) Ns\<close> and
    i: \<open>enat i < llength Ns\<close>
  shows \<open>Red_I (lnth Ns i) \<subseteq> Red_I (Liminf_llist Ns)\<close>
proof -
  have Sup_in_diff: \<open>Red_I (Sup_llist Ns) \<subseteq> Red_I (Sup_llist Ns - (Sup_llist Ns - Liminf_llist Ns))\<close>
    using Red_I_of_Red_F_subset[OF Red_in_Sup] deriv by auto
  also have \<open>Sup_llist Ns - (Sup_llist Ns - Liminf_llist Ns) = Liminf_llist Ns\<close>
    by (simp add: Liminf_llist_subset_Sup_llist double_diff)
  then have Red_I_Sup_in_Liminf: \<open>Red_I (Sup_llist Ns) \<subseteq> Red_I (Liminf_llist Ns)\<close>
    using Sup_in_diff by auto
  have \<open>lnth Ns i \<subseteq> Sup_llist Ns\<close> unfolding Sup_llist_def using i by blast
  then have "Red_I (lnth Ns i) \<subseteq> Red_I (Sup_llist Ns)" using Red_I_of_subset
    unfolding Sup_llist_def by auto
  then show ?thesis using Red_I_Sup_in_Liminf by auto
qed

(* lem:redundant-remains-redundant-during-run 2/2 *)
lemma Red_F_subset_Liminf:
  assumes deriv: \<open>chain (\<rhd>) Ns\<close> and
    i: \<open>enat i < llength Ns\<close>
  shows \<open>Red_F (lnth Ns i) \<subseteq> Red_F (Liminf_llist Ns)\<close>
proof -
  have Sup_in_diff: \<open>Red_F (Sup_llist Ns) \<subseteq> Red_F (Sup_llist Ns - (Sup_llist Ns - Liminf_llist Ns))\<close>
    using Red_F_of_Red_F_subset[OF Red_in_Sup] deriv by auto
  also have \<open>Sup_llist Ns - (Sup_llist Ns - Liminf_llist Ns) = Liminf_llist Ns\<close>
    by (simp add: Liminf_llist_subset_Sup_llist double_diff)
  then have Red_F_Sup_in_Liminf: \<open>Red_F (Sup_llist Ns) \<subseteq> Red_F (Liminf_llist Ns)\<close>
    using Sup_in_diff by auto
  have \<open>lnth Ns i \<subseteq> Sup_llist Ns\<close> unfolding Sup_llist_def using i by blast
  then have "Red_F (lnth Ns i) \<subseteq> Red_F (Sup_llist Ns)" using Red_F_of_subset
    unfolding Sup_llist_def by auto
  then show ?thesis using Red_F_Sup_in_Liminf by auto
qed

(* lem:N-i-is-persistent-or-redundant *)
lemma i_in_Liminf_or_Red_F:
  assumes
    deriv: \<open>chain (\<rhd>) Ns\<close> and
    i: \<open>enat i < llength Ns\<close>
  shows \<open>lnth Ns i \<subseteq> Red_F (Liminf_llist Ns) \<union> Liminf_llist Ns\<close>
proof (rule,rule)
  fix C
  assume C: \<open>C \<in> lnth Ns i\<close>
  and C_not_Liminf: \<open>C \<notin> Liminf_llist Ns\<close>
  have \<open>C \<in> Sup_llist Ns\<close> unfolding Sup_llist_def using C i by auto
  then obtain j where j: \<open>C \<in> lnth Ns j - lnth Ns (Suc j)\<close> \<open>enat (Suc j) < llength Ns\<close>
    using equiv_Sup_Liminf[of C Ns] C_not_Liminf by auto
  then have \<open>C \<in> Red_F (lnth Ns (Suc j))\<close>
    using deriv by (meson chain_lnth_rel contra_subsetD derive.cases)
  then show \<open>C \<in> Red_F (Liminf_llist Ns)\<close> using Red_F_subset_Liminf[of Ns "Suc j"] deriv j(2) by blast
qed

(* lem:fairness-implies-saturation *)
lemma fair_implies_Liminf_saturated:
  assumes
    deriv: \<open>chain (\<rhd>) Ns\<close> and
    fair: \<open>fair Ns\<close>
  shows \<open>saturated (Liminf_llist Ns)\<close>
  unfolding saturated_def
proof
  fix \<iota>
  assume \<iota>: \<open>\<iota> \<in> Inf_from (Liminf_llist Ns)\<close>
  have \<open>\<iota> \<in> Sup_llist (lmap Red_I Ns)\<close> using fair \<iota> unfolding fair_def by auto
  then obtain i where i: \<open>enat i < llength Ns\<close> \<open>\<iota> \<in> Red_I (lnth Ns i)\<close>
    unfolding Sup_llist_def by auto
  then show \<open>\<iota> \<in> Red_I (Liminf_llist Ns)\<close>
    using deriv i_in_Liminf_or_Red_F[of Ns i] Red_I_subset_Liminf by blast
qed

end

locale statically_complete_calculus = calculus +
  assumes statically_complete: "B \<in> Bot \<Longrightarrow> saturated N \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> \<exists>B'\<in>Bot. B' \<in> N"
begin

lemma dynamically_complete_Liminf:
  fixes B Ns
  assumes
    bot_elem: \<open>B \<in> Bot\<close> and
    deriv: \<open>chain (\<rhd>) Ns\<close> and
    fair: \<open>fair Ns\<close> and
    unsat: \<open>lhd Ns \<Turnstile> {B}\<close>
  shows \<open>\<exists>B'\<in>Bot. B' \<in> Liminf_llist Ns\<close>
proof -
  note lhd_is = lhd_conv_lnth[OF chain_not_lnull[OF deriv]]
  have non_empty: \<open>\<not> lnull Ns\<close> using chain_not_lnull[OF deriv] .
  have subs: \<open>lhd Ns \<subseteq> Sup_llist Ns\<close>
    using lhd_subset_Sup_llist[of Ns] non_empty by (simp add: lhd_conv_lnth)
  have \<open>Sup_llist Ns \<Turnstile> {B}\<close>
    using unsat subset_entailed[OF subs] entails_trans[of "Sup_llist Ns" "lhd Ns"] by auto
  then have Sup_no_Red: \<open>Sup_llist Ns - Red_F (Sup_llist Ns) \<Turnstile> {B}\<close>
    using bot_elem Red_F_Bot by auto
  have Sup_no_Red_in_Liminf: \<open>Sup_llist Ns - Red_F (Sup_llist Ns) \<subseteq> Liminf_llist Ns\<close>
    using deriv Red_in_Sup by auto
  have Liminf_entails_Bot: \<open>Liminf_llist Ns \<Turnstile> {B}\<close>
    using Sup_no_Red subset_entailed[OF Sup_no_Red_in_Liminf] entails_trans by blast
  have \<open>saturated (Liminf_llist Ns)\<close>
    using deriv fair fair_implies_Liminf_saturated unfolding saturated_def by auto
  then show ?thesis
    using bot_elem statically_complete Liminf_entails_Bot by auto
qed

end

locale dynamically_complete_calculus = calculus +
  assumes
    dynamically_complete: "B \<in> Bot \<Longrightarrow> chain (\<rhd>) Ns \<Longrightarrow> fair Ns \<Longrightarrow> lhd Ns \<Turnstile> {B} \<Longrightarrow>
      \<exists>i \<in> {i. enat i < llength Ns}. \<exists>B'\<in>Bot. B' \<in> lnth Ns i"
begin

(* lem:dynamic-ref-compl-implies-static *)
sublocale statically_complete_calculus
proof
  fix B N
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    saturated_N: "saturated N" and
    refut_N: "N \<Turnstile> {B}"
  define Ns where "Ns = LCons N LNil"
  have[simp]: \<open>\<not> lnull Ns\<close> by (auto simp: Ns_def)
  have deriv_Ns: \<open>chain (\<rhd>) Ns\<close> by (simp add: chain.chain_singleton Ns_def)
  have liminf_is_N: "Liminf_llist Ns = N" by (simp add: Ns_def Liminf_llist_LCons)
  have head_Ns: "N = lhd Ns" by (simp add: Ns_def)
  have "Sup_llist (lmap Red_I Ns) = Red_I N" by (simp add: Ns_def)
  then have fair_Ns: "fair Ns" using saturated_N by (simp add: fair_def saturated_def liminf_is_N)
  obtain i B' where B'_is_bot: \<open>B' \<in> Bot\<close> and B'_in: "B' \<in> lnth Ns i" and \<open>i < llength Ns\<close>
    using dynamically_complete[of B Ns] bot_elem fair_Ns head_Ns saturated_N deriv_Ns refut_N
    by auto
  then have "i = 0"
    by (auto simp: Ns_def enat_0_iff)
  show \<open>\<exists>B'\<in>Bot. B' \<in> N\<close>
    using B'_is_bot B'_in unfolding \<open>i = 0\<close> head_Ns[symmetric] Ns_def by auto
qed

end

(* lem:static-ref-compl-implies-dynamic *)
sublocale statically_complete_calculus \<subseteq> dynamically_complete_calculus
proof
  fix B Ns
  assume
    \<open>B \<in> Bot\<close> and
    \<open>chain (\<rhd>) Ns\<close> and
    \<open>fair Ns\<close> and
    \<open>lhd Ns \<Turnstile> {B}\<close>
  then have \<open>\<exists>B'\<in>Bot. B' \<in> Liminf_llist Ns\<close>
    by (rule dynamically_complete_Liminf)
  then show \<open>\<exists>i\<in>{i. enat i < llength Ns}. \<exists>B'\<in>Bot. B' \<in> lnth Ns i\<close>
    unfolding Liminf_llist_def by auto
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
Hoare reasoning and WP (weakest-precondition) generator rules for the option monad.

This list is almost certainly incomplete; add rules here as they are needed.
*)

theory OptionMonadWP
imports
  OptionMonadND
  "wp/WP"
begin

declare K_def [simp]

(* Hoare triples.
   TODO: design a sensible syntax for them. *)

(* Partial correctness. *)
definition ovalid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalid P f Q \<equiv> \<forall>s r. P s \<and> f s = Some r \<longrightarrow> Q r s"
(* Total correctness. *)
definition ovalidNF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" where
  "ovalidNF P f Q \<equiv> \<forall>s. P s \<longrightarrow> (f s \<noteq> None \<and> (\<forall>r. f s = Some r \<longrightarrow> Q r s))"
(* Termination. *)
definition no_ofail where "no_ofail P f \<equiv> \<forall>s. P s \<longrightarrow> f s \<noteq> None"

(*
This rule lets us apply ovalidNF machinery for proving no_ofail.
However, we ought to eventually write working wp rules for no_ofail (see below).
*)
lemma no_ofail_is_ovalidNF: "no_ofail P f \<equiv> ovalidNF P f (\<lambda>_ _. True)"
  by (simp add: no_ofail_def ovalidNF_def)
lemma ovalidNF_combine: "\<lbrakk> ovalid P f Q; no_ofail P f \<rbrakk> \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def ovalid_def no_ofail_def)

(* Annotating programs with loop invariant and measure. *)
definition owhile_inv ::
  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'a option) \<Rightarrow> 'a
   \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> 's \<Rightarrow> 'a option"
  where "owhile_inv C B x I M = owhile C B x"

lemmas owhile_add_inv = owhile_inv_def[symmetric]

(* WP rules for ovalid. *)
lemma obind_wp [wp]:
  "\<lbrakk> \<And>r. ovalid (R r) (g r) Q; ovalid P f R \<rbrakk> \<Longrightarrow> ovalid P (obind f g) Q"
  by (simp add: ovalid_def obind_def split: option.splits, fast)

lemma oreturn_wp [wp]:
  "ovalid (P x) (oreturn x) P"
  by (simp add: ovalid_def)

lemma ocondition_wp [wp]:
  "\<lbrakk> ovalid L l Q; ovalid R r Q \<rbrakk>
   \<Longrightarrow> ovalid (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (auto simp: ovalid_def ocondition_def)

lemma ofail_wp [wp]:
  "ovalid (\<lambda>_. True) ofail Q"
  by (simp add: ovalid_def ofail_def)

lemma ovalid_K_bind_wp [wp]:
  "ovalid P f Q \<Longrightarrow> ovalid P (K_bind f x) Q"
  by simp

lemma ogets_wp [wp]: "ovalid (\<lambda>s. P (f s) s) (ogets f) P"
  by (simp add: ovalid_def ogets_def)

lemma oguard_wp [wp]: "ovalid (\<lambda>s. f s \<longrightarrow> P () s) (oguard f) P"
  by (simp add: ovalid_def oguard_def)

lemma oskip_wp [wp]:
  "ovalid (\<lambda>s. P () s) oskip P"
  by (simp add: ovalid_def oskip_def)

lemma ovalid_case_prod [wp]:
  assumes "(\<And>x y. ovalid (P x y) (B x y) Q)"
  shows "ovalid (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalid_def by auto

lemma owhile_ovalid [wp]:
"\<lbrakk>\<And>a. ovalid (\<lambda>s. I a s \<and> C a s) (B a) I;
   \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
  \<Longrightarrow> ovalid (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def owhile_def ovalid_def
  apply clarify
  apply (frule_tac I = "\<lambda>a. I a s" in option_while_rule)
  apply auto
  done

definition ovalid_property where "ovalid_property P x = (\<lambda>s f. (\<forall>r. Some r = x s f \<longrightarrow> P r s))"
lemma ovalid_is_triple [wp_trip]:
  "ovalid P f Q = triple_judgement P f (ovalid_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalid_def ovalid_property_def)

lemma ovalid_wp_comb1 [wp_comb]:
  "\<lbrakk> ovalid P' f Q; ovalid P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalid P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalid_def)

lemma ovalid_wp_comb2 [wp_comb]:
  "\<lbrakk> ovalid P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (auto simp: ovalid_def)

lemma ovalid_wp_comb3 [wp_comb]:
  "\<lbrakk> ovalid P f Q; ovalid P' f Q' \<rbrakk> \<Longrightarrow> ovalid (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (auto simp: ovalid_def)

(* WP rules for ovalidNF. *)
lemma obind_NF_wp [wp]:
  "\<lbrakk> \<And>r. ovalidNF (R r) (g r) Q; ovalidNF P f R \<rbrakk> \<Longrightarrow> ovalidNF P (obind f g) Q"
  by (auto simp: ovalidNF_def obind_def split: option.splits)

lemma oreturn_NF_wp [wp]:
  "ovalidNF (P x) (oreturn x) P"
  by (simp add: ovalidNF_def oreturn_def)

lemma ocondition_NF_wp [wp]:
  "\<lbrakk> ovalidNF L l Q; ovalidNF R r Q \<rbrakk>
   \<Longrightarrow> ovalidNF (\<lambda>s. if C s then L s else R s) (ocondition C l r) Q"
  by (simp add: ovalidNF_def ocondition_def)

lemma ofail_NF_wp [wp]:
  "ovalidNF (\<lambda>_. False) ofail Q"
  by (simp add: ovalidNF_def ofail_def)

lemma ovalidNF_K_bind_wp [wp]:
  "ovalidNF P f Q \<Longrightarrow> ovalidNF P (K_bind f x) Q"
  by simp

lemma ogets_NF_wp [wp]:
  "ovalidNF (\<lambda>s. P (f s) s) (ogets f) P"
  by (simp add: ovalidNF_def ogets_def)

lemma oguard_NF_wp [wp]:
  "ovalidNF (\<lambda>s. f s \<and> P () s) (oguard f) P"
  by (simp add: ovalidNF_def oguard_def)

lemma oskip_NF_wp [wp]:
  "ovalidNF (\<lambda>s. P () s) oskip P"
  by (simp add: ovalidNF_def oskip_def)

lemma ovalid_NF_case_prod [wp]:
  assumes "(\<And>x y. ovalidNF (P x y) (B x y) Q)"
  shows "ovalidNF (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q"
  using assms unfolding ovalidNF_def by auto

lemma owhile_NF [wp]:
"\<lbrakk>\<And>a. ovalidNF (\<lambda>s. I a s \<and> C a s) (B a) I;
   \<And>a m. ovalid (\<lambda>s. I a s \<and> C a s \<and> M a s = m) (B a) (\<lambda>r s. M r s < m);
   \<And>a s. \<lbrakk>I a s; \<not> C a s\<rbrakk> \<Longrightarrow> Q a s\<rbrakk>
  \<Longrightarrow> ovalidNF (I a) (owhile_inv C B a I M) Q"
  unfolding owhile_inv_def ovalidNF_def ovalid_def
  apply clarify
  apply (rule_tac I = I and M = "measure (\<lambda>r. M r s)" in owhile_rule)
       apply fastforce
      apply fastforce
     apply fastforce
    apply blast+
  done

definition ovalidNF_property where "ovalidNF_property P x = (\<lambda>s f. (x s f \<noteq> None \<and> (\<forall>r. Some r = x s f \<longrightarrow> P r s)))"
lemma ovalidNF_is_triple [wp_trip]:
  "ovalidNF P f Q = triple_judgement P f (ovalidNF_property Q (\<lambda>s f. f s))"
  by (auto simp: triple_judgement_def ovalidNF_def ovalidNF_property_def)

lemma ovalidNF_wp_comb1 [wp_comb]:
  "\<lbrakk> ovalidNF P' f Q; ovalidNF P f Q'; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> ovalidNF P f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb2 [wp_comb]:
  "\<lbrakk> ovalidNF P f Q; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)

lemma ovalidNF_wp_comb3 [wp_comb]:
  "\<lbrakk> ovalidNF P f Q; ovalidNF P' f Q' \<rbrakk> \<Longrightarrow> ovalidNF (\<lambda>s. P s \<and> P' s) f (\<lambda>r s. Q r s \<and> Q' r s)"
  by (simp add: ovalidNF_def)

(* FIXME: WP rules for no_ofail, which might not be correct. *)
lemma no_ofail_ofail [wp]: "no_ofail (\<lambda>_. False) ofail"
  by (simp add: no_ofail_def ofail_def)

lemma no_ofail_ogets [wp]: "no_ofail (\<lambda>_. True) (ogets f)"
  by (simp add: no_ofail_def ogets_def)

lemma no_ofail_obind [wp]:
  "\<lbrakk> \<And>r. no_ofail (P r) (g r); no_ofail Q f; ovalid Q f P \<rbrakk> \<Longrightarrow> no_ofail Q (obind f g)"
  by (auto simp: no_ofail_def obind_def ovalid_def)

lemma no_ofail_K_bind [wp]:
  "no_ofail P f \<Longrightarrow> no_ofail P (K_bind f x)"
  by simp

lemma no_ofail_oguard [wp]:
  "no_ofail (\<lambda>s. f s) (oguard f)"
  by (auto simp: no_ofail_def oguard_def)

lemma no_ofail_ocondition [wp]:
  "\<lbrakk> no_ofail L l; no_ofail R r \<rbrakk>
     \<Longrightarrow> no_ofail (\<lambda>s. if C s then L s else R s) (ocondition C l r)"
  by (simp add: no_ofail_def ocondition_def)

lemma no_ofail_oreturn [wp]:
  "no_ofail (\<lambda>_. True) (oreturn x)"
  by (simp add: no_ofail_def oreturn_def)

lemma no_ofail_oskip [wp]:
  "no_ofail (\<lambda>_. True) oskip"
  by (simp add: no_ofail_def oskip_def)

lemma no_ofail_is_triple [wp_trip]:
  "no_ofail P f = triple_judgement P f (\<lambda>s f. f s \<noteq> None)"
  by (auto simp: triple_judgement_def no_ofail_def)

lemma no_ofail_wp_comb1 [wp_comb]:
  "\<lbrakk> no_ofail P f; \<And>s. P' s \<Longrightarrow> P s \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma no_ofail_wp_comb2 [wp_comb]:
  "\<lbrakk> no_ofail P f; no_ofail P' f \<rbrakk> \<Longrightarrow> no_ofail (\<lambda>s. P s \<and> P' s) f"
  by (simp add: no_ofail_def)

(* Some extra lemmas for our predicates. *)
lemma ovalid_grab_asm:
  "(G \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalid_def)
lemma ovalidNF_grab_asm:
  "(G \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_grab_asm:
  "(G \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail (\<lambda>s. G \<and> P s) f"
  by (simp add: no_ofail_def)

lemma ovalid_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalid P f Q) \<Longrightarrow> ovalid P f Q"
  by (auto simp: ovalid_def)
lemma ovalidNF_assume_pre:
  "(\<And>s. P s \<Longrightarrow> ovalidNF P f Q) \<Longrightarrow> ovalidNF P f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_assume_pre:
  "(\<And>s. P s \<Longrightarrow> no_ofail P f) \<Longrightarrow> no_ofail P f"
  by (simp add: no_ofail_def)

lemma ovalid_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P' f Q"
  by (simp add: ovalid_def)
lemma ovalidNF_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P' f Q"
  by (simp add: ovalidNF_def)
lemma no_ofail_pre_imp:
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; no_ofail P f \<rbrakk> \<Longrightarrow> no_ofail P' f"
  by (simp add: no_ofail_def)

lemma ovalid_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)
lemma ovalidNF_post_imp:
  "\<lbrakk> \<And>r s. Q r s \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

lemma ovalid_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalid P f Q \<rbrakk> \<Longrightarrow> ovalid P f Q'"
  by (simp add: ovalid_def)
lemma ovalidNF_post_imp_assuming_pre:
  "\<lbrakk> \<And>r s. \<lbrakk> P s; Q r s \<rbrakk> \<Longrightarrow> Q' r s; ovalidNF P f Q \<rbrakk> \<Longrightarrow> ovalidNF P f Q'"
  by (simp add: ovalidNF_def)

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Option\<close>

theory Applicative_Option imports
  Applicative
  "HOL-Library.Adhoc_Overloading"
begin

fun ap_option :: "('a \<Rightarrow> 'b) option \<Rightarrow> 'a option \<Rightarrow> 'b option"
where
    "ap_option (Some f) (Some x) = Some (f x)"
  | "ap_option _ _ = None"

abbreviation (input) pure_option :: "'a \<Rightarrow> 'a option"
where "pure_option \<equiv> Some"

adhoc_overloading Applicative.pure pure_option
adhoc_overloading Applicative.ap ap_option

lemma some_ap_option: "ap_option (Some f) x = map_option f x"
by (cases x) simp_all

lemma ap_some_option: "ap_option f (Some x) = map_option (\<lambda>g. g x) f"
by (cases f) simp_all

lemma ap_option_transfer[transfer_rule]:
  "rel_fun (rel_option (rel_fun A B)) (rel_fun (rel_option A) (rel_option B)) ap_option ap_option"
by(auto elim!: option.rel_cases simp add: rel_fun_def)

applicative option (C, W)
for
  pure: Some
  ap: ap_option
  rel: rel_option
  set: set_option
proof -
  include applicative_syntax
  { fix x :: "'a option"
    show "pure (\<lambda>x. x) \<diamondop> x = x" by (cases x) simp_all
  next
    fix g :: "('b \<Rightarrow> 'c) option" and f :: "('a \<Rightarrow> 'b) option" and x
    show "pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
      by (cases g f x rule: option.exhaust[case_product option.exhaust, case_product option.exhaust]) simp_all
  next
    fix f :: "('b \<Rightarrow> 'a \<Rightarrow> 'c) option" and x y
    show "pure (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
      by (cases f x y rule: option.exhaust[case_product option.exhaust, case_product option.exhaust]) simp_all
  next
    fix f :: "('a \<Rightarrow> 'a \<Rightarrow> 'b) option" and x
    show "pure (\<lambda>f x. f x x) \<diamondop> f \<diamondop> x = f \<diamondop> x \<diamondop> x"
      by (cases f x rule: option.exhaust[case_product option.exhaust]) simp_all
  next
    fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
    show "rel_fun R (rel_option R) pure pure" by transfer_prover
  next
    fix R and f :: "('a \<Rightarrow> 'b) option" and g :: "('a \<Rightarrow> 'c) option" and x
    assume [transfer_rule]: "rel_option (rel_fun (eq_on (set_option x)) R) f g"
    have [transfer_rule]: "rel_option (eq_on (set_option x)) x x" by (auto intro: option.rel_refl_strong)
    show "rel_option R (f \<diamondop> x) (g \<diamondop> x)" by transfer_prover
  }
qed (simp add: some_ap_option ap_some_option)

lemma map_option_ap_conv[applicative_unfold]: "map_option f x = ap_option (pure f) x"
by (cases x rule: option.exhaust) simp_all

no_adhoc_overloading Applicative.pure pure_option \<comment> \<open>We do not want to print all occurrences of @{const "Some"} as @{const "pure"}\<close>

end


header {* Preliminaries *}

(* author: Andrei Popescu *)

theory Preliminaries imports Main

begin

text {* Thus section discusses preliminaries on families of items (technically,
partial functions from a type of {\em indexes})
that we call {\em inputs} because they will be inputs to the binding operations.
For inputs, we define some monad-like lifting operators.
We also define simple infinitely branching trees (with no info attached
to the nodes and with branching given by partial functions from
indexes) -- these will be used as ``skeletons" for terms, giving a size on which we can induct.
 *}

subsection {* Trivia  *}

type_synonym 'a pair = "'a * 'a"

type_synonym 'a triple = "'a * 'a *'a"

type_synonym 'a rel = "'a pair set"

(* Selectors for triples *)

definition fst3 where "fst3 == fst"
definition snd3 where "snd3 == fst o snd"
definition trd3 where "trd3 == snd o snd"

lemma fst3_simp[simp]: "fst3 (a,b,c) = a"
unfolding fst3_def by simp

lemma snd3_simp[simp]: "snd3 (a,b,c) = b"
unfolding snd3_def by simp

lemma trd3_simp[simp]: "trd3 (a,b,c) = c"
unfolding trd3_def by simp

lemma fst3_snd3_trd3: "abc = (fst3 abc, snd3 abc, trd3 abc)"
unfolding fst3_def snd3_def trd3_def by auto

lemma fst3_snd3_trd3_rev[simp]:
"(fst3 abc, snd3 abc, trd3 abc) = abc"
using fst3_snd3_trd3[of abc] by simp

lemma map_id[simp]: "map id l = l"
unfolding id_def by simp

abbreviation max3 where
"max3 x y z == max (max x y) z"

lemma map_id_cong:
assumes "!! x. x : set L \<Longrightarrow> f x = x"
shows "map f L = L"
proof-
  have "map f L = map id L"
  apply(rule map_cong)
  using assms by auto
  thus ?thesis by simp
qed

lemma ext2:
"(f \<noteq> g) = (\<exists> x. f x \<noteq> g x)"
proof-
  have "(f = g) = (\<forall> x. f x = g x)"
  by(auto simp add: ext)
  thus ?thesis by blast
qed

lemma not_equals_and_not_equals_not_in:
"(y \<noteq> x \<and> y \<noteq> x' \<and> phi) =
 (y \<notin> {x,x'} \<and> phi)"
by simp

lemma mp2:
assumes "!! x y. phi x y \<Longrightarrow> chi x y" and "phi x y"
shows "chi x y"
using assms by simp

lemma mp3:
assumes "!! x y z. phi x y z \<Longrightarrow> chi x y z" and "phi x y z"
shows "chi x y z"
using assms by simp

lemma all_lt_Suc:
"(\<forall> i < Suc n. phi i) =
 ((\<forall> i < n. phi i) \<and> phi n)"
apply auto
by (case_tac "i = n", auto)

lemma hd_map[simp]:
assumes "L \<noteq> []"
shows "hd (map f L) = f (hd L)"
using assms apply - by(induct L, auto)

lemma tl_map[simp]:
assumes "L \<noteq> []"
shows "tl (map f L) = map f (tl L)"
using assms apply - by(induct L, auto)

lemma last_map[simp]:
assumes "L \<noteq> []"
shows "last (map f L) = f (last L)"
using assms apply - by(induct L, auto)

lemma tl_last_hd:
assumes "L \<noteq> []" and "tl L = []"
shows "last L = hd L"
using assms apply - by(induct L, auto)

subsection {* Lexicographic induction *}

definition lt2 where
"lt2 == less_than <*lex*> less_than"

definition lt3 where
"lt3 == less_than <*lex*> lt2"

lemma wf_lt2:
"wf lt2"
unfolding lt2_def by auto

lemma wf_lt3:
"wf lt3"
unfolding lt3_def by (auto simp add: wf_lt2)

lemma lt2[intro]:
"!! k1 k2 j1 j2. k1 < j1 \<Longrightarrow> ((k1,k2),(j1,j2)) \<in> lt2"
"!! k1 k2 j1 j2. \<lbrakk>k1 \<le> j1; k2 < j2\<rbrakk> \<Longrightarrow> ((k1,k2),(j1,j2)) \<in> lt2"
unfolding lt2_def by auto

lemma measure_lex2_induct:
fixes h1 :: "'a1 \<Rightarrow> nat" and h2 :: "'a2 \<Rightarrow> nat"
assumes
"!! x1 x2.
  \<lbrakk>(!! y1 y2. h1 y1 < h1 x1 \<Longrightarrow> phi y1 y2);
   (!! y1 y2. \<lbrakk>h1 y1 \<le> h1 x1; h2 y2 < h2 x2\<rbrakk> \<Longrightarrow> phi y1 y2)\<rbrakk>
  \<Longrightarrow> phi x1 x2"
shows "phi x1 x2"
proof-
  let ?chi = "%(n1,n2). ALL x1 x2. h1 x1 = n1 \<and> h2 x2 = n2 \<longrightarrow> phi x1 x2"
  {fix n1 n2
   have "?chi (n1,n2)"
   apply(rule wf_induct[of lt2 ?chi]) using wf_lt2 assms by blast+
  }
  thus ?thesis by blast
qed

lemma measure_lex3_induct:
fixes h1 :: "'a1 \<Rightarrow> nat" and h2 :: "'a2 \<Rightarrow> nat" and h3 :: "'a3 \<Rightarrow> nat"
assumes
"!! x1 x2 x3.
  \<lbrakk>(!! y1 y2 y3. h1 y1 < h1 x1 \<Longrightarrow> phi y1 y2 y3);
   (!! y1 y2 y3. \<lbrakk>h1 y1 \<le> h1 x1; h2 y2 < h2 x2\<rbrakk> \<Longrightarrow> phi y1 y2 y3);
   (!! y1 y2 y3. \<lbrakk>h1 y1 \<le> h1 x1; h2 y2 \<le> h2 x2; h3 y3 < h3 x3\<rbrakk> \<Longrightarrow> phi y1 y2 y3)\<rbrakk>
  \<Longrightarrow> phi x1 x2 x3"
shows "phi x1 x2 x3"
proof-
  let ?chi = "%(n1,n2,n3). ALL x1 x2 x3. h1 x1 = n1 \<and> h2 x2 = n2 \<and> h3 x3 = n3 \<longrightarrow> phi x1 x2 x3"
  {fix n1 n2 n3
   have "?chi (n1,n2,n3)"
   apply(rule wf_induct[of lt3 ?chi]) using wf_lt3 assms by blast+
  }
  thus ?thesis by blast
qed

subsection {* Inputs and lifting operators  *}

type_synonym ('index,'val)input = "'index \<Rightarrow> 'val option"

definition
lift :: "('val1 \<Rightarrow> 'val2) \<Rightarrow> ('index,'val1)input \<Rightarrow> ('index,'val2)input"
where
"lift h inp == \<lambda>i. case inp i of None \<Rightarrow> None
                                |Some v \<Rightarrow> Some (h v)"

definition
liftAll :: "('val \<Rightarrow> bool) \<Rightarrow> ('index,'val)input \<Rightarrow> bool"
where
"liftAll phi inp == \<forall> i v. inp i = Some v \<longrightarrow> phi v"

definition
lift2 ::
"('val1' \<Rightarrow> 'val1 \<Rightarrow> 'val2) \<Rightarrow> ('index,'val1')input \<Rightarrow> ('index,'val1)input \<Rightarrow> ('index,'val2)input"
where
"lift2 h inp' inp ==
 \<lambda>i. case (inp' i, inp i) of
   (Some v',Some v) \<Rightarrow> Some (h v' v)
  |_ \<Rightarrow> None"

definition
sameDom ::  "('index,'val1)input \<Rightarrow> ('index,'val2)input \<Rightarrow> bool"
where "sameDom inp1 inp2 == \<forall> i. (inp1 i = None) = (inp2 i = None)"

definition
liftAll2 :: "('val1 \<Rightarrow> 'val2 \<Rightarrow> bool) \<Rightarrow> ('index,'val1)input \<Rightarrow> ('index,'val2)input \<Rightarrow> bool"
where
"liftAll2 phi inp1 inp2 == (\<forall> i v1 v2. inp1 i = Some v1 \<and> inp2 i = Some v2 \<longrightarrow> phi v1 v2)"

lemma lift_None: "(lift h inp i = None) = (inp i = None)"
unfolding lift_def by (cases "inp i", auto)

lemma lift_Some:
"(\<exists> v. lift h inp i = Some v) = (\<exists> v'. inp i = Some v')"
using lift_None[of h inp i] by force

lemma lift_cong[fundef_cong]:
assumes "\<And> i v. inp i = Some v \<Longrightarrow>  h v = h' v"
shows "lift h inp = lift h' inp"
unfolding lift_def apply(rule ext)+
using assms by (case_tac "inp i", auto)

lemma lift_preserves_inj:
assumes "inj f"
shows "inj (lift f)"
unfolding inj_on_def apply auto proof(rule ext)
  fix inp inp' i assume *: "lift f inp = lift f inp'"
  show "inp i = inp' i"
  proof(cases "inp i")
    assume inp: "inp i = None"
    hence "lift f inp i = None" unfolding lift_def by simp
    hence "lift f inp' i = None" using * by simp
    hence "inp' i = None" by(auto simp add: lift_None)
    thus ?thesis using inp by simp
  next
    fix v assume inp: "inp i = Some v"
    hence "lift f inp i = Some (f v)" unfolding lift_def by simp
    hence "lift f inp' i = Some (f v)" using * by simp
    then obtain v' where inp': "inp' i = Some v'" and "f v' = f v"
    unfolding lift_def by(case_tac "inp' i", auto)
    hence "v = v'" using assms unfolding inj_on_def by simp
    thus ?thesis using inp inp' by simp
  qed
qed

lemma liftAll_cong[fundef_cong]:
assumes "\<And> i v. inp i = Some v \<Longrightarrow> phi v = phi' v"
shows "liftAll phi inp = liftAll phi' inp"
unfolding liftAll_def apply((rule iff_allI)+) using assms by simp

lemma sameDom_cong[fundef_cong]:
assumes "\<And> i. (inp1 i = None) = (inp2 i = None)"
shows "sameDom inp1 inp2 = sameDom inp1 inp2"
unfolding sameDom_def apply((rule iff_allI)+) using assms by blast

lemma liftAll2_cong[fundef_cong]:
assumes "\<And> i v1 v2. \<lbrakk>inp1 i = Some v1; inp2 i = Some v2\<rbrakk> \<Longrightarrow> phi v1 v2 = phi' v1 v2"
shows "liftAll2 phi inp1 inp2 = liftAll2 phi' inp1 inp2"
unfolding liftAll2_def apply((rule iff_allI)+) using assms by blast

lemma lift_ident: "lift (\<lambda>v. v) inp = inp"
by(unfold lift_def, rule ext, case_tac "inp i", auto)

lemma lift_id[simp]:
"lift id inp = inp"
unfolding lift_def apply (rule ext) by(case_tac "inp i", auto)

lemma lift_comp: "lift g (lift f inp) = lift (g o f) inp"
by(unfold lift_def o_def, rule ext, case_tac "inp i", auto)

lemma liftAll_mono:
assumes "\<And> v. phi v \<Longrightarrow> chi v" and "liftAll phi inp"
shows "liftAll chi inp"
using assms unfolding liftAll_def by blast

lemma liftAll_True: "liftAll (\<lambda>v. True) inp"
unfolding liftAll_def by auto

lemma liftAll_lift_comp:  "liftAll phi (lift f inp) = liftAll (phi o f) inp"
unfolding liftAll_def o_def
apply (rule iff_allI)
proof(auto)
  fix i v
  assume 1: "\<forall>w. lift f inp i = Some w \<longrightarrow> phi w" and 2: "inp i = Some v"
  thus "phi (f v)" unfolding lift_def by force
next
  fix i w
  assume 1: "\<forall>v. inp i = Some v \<longrightarrow> phi (f v)" and "lift f inp i = Some w"
  then obtain v where "inp i = Some v" and 2: "w = f v"
  unfolding lift_def by (cases "inp i", auto)
  thus "phi w" unfolding 2 using 1 by simp
qed

lemma liftAll_lift_ext:
"liftAll (\<lambda> x. f x = g x) inp = (lift f inp = lift g inp)"
unfolding lift_def liftAll_def
apply auto
apply(rule ext)  apply (case_tac "inp i", auto)
by(drule_tac x = i in fun_cong, auto)

lemma liftAll_and:
"liftAll (\<lambda> x. phi x \<and> chi x) inp = (liftAll phi inp \<and> liftAll chi inp)"
using assms unfolding liftAll_def by blast

lemma liftAll_mp:
assumes "liftAll (\<lambda> v. phi v \<longrightarrow> chi v) inp" and "liftAll phi inp"
shows "liftAll chi inp"
using assms unfolding liftAll_def by auto

lemma sameDom_refl: "sameDom inp inp"
unfolding sameDom_def by auto

lemma sameDom_sym:
"sameDom inp inp' = sameDom inp' inp"
unfolding sameDom_def by auto

lemma sameDom_trans:
"\<lbrakk>sameDom inp inp'; sameDom inp' inp''\<rbrakk> \<Longrightarrow> sameDom inp inp''"
unfolding sameDom_def by auto

lemma sameDom_lift1:
"sameDom inp (lift f inp)"
unfolding sameDom_def lift_def
apply clarify by(case_tac "inp i", auto)

lemma sameDom_lift2:
"sameDom (lift f inp) inp"
unfolding sameDom_def lift_def
apply clarify by(case_tac "inp i", auto)

lemma sameDom_lift_simp1[simp]:
"sameDom inp (lift f inp') = sameDom inp inp'"
proof
  assume "sameDom inp (lift f inp')"
  hence "sameDom (lift f inp') inp" using sameDom_sym by auto
  moreover have "sameDom inp' (lift f inp')" using sameDom_lift1 by auto
  ultimately have "sameDom inp' inp" using sameDom_trans by blast
  thus "sameDom inp inp'" using sameDom_sym by auto
next
  assume "sameDom inp inp'"
  moreover have "sameDom inp' (lift f inp')" using sameDom_lift1 by auto
  ultimately show "sameDom inp (lift f inp')" using sameDom_trans by blast
qed

lemma sameDom_lift_simp2[simp]:
"sameDom (lift f inp) inp' = sameDom inp inp'"
proof-
  have "sameDom (lift f inp) inp' = sameDom inp' (lift f inp)"
  using sameDom_sym by blast
  also have "\<dots> = sameDom inp' inp" by simp
  also have "\<dots> = sameDom inp inp'" using sameDom_sym by auto
  finally show ?thesis .
qed

lemma lift_preserves_sameDom:
assumes "sameDom inp inp'"
shows "sameDom (lift f inp) (lift g inp')"
proof-
  have "sameDom (lift f inp) inp" using sameDom_lift2 by auto
  moreover have "sameDom inp' (lift g inp')" using sameDom_lift1 by auto
  ultimately show ?thesis
  using assms sameDom_trans[of "lift f inp" inp]
              sameDom_trans[of "lift f inp" inp'] by blast
qed

definition comp2 ::
"('b1 \<Rightarrow> 'b2 \<Rightarrow> 'c) \<Rightarrow> ('a1 \<Rightarrow> 'b1) \<Rightarrow> ('a2 \<Rightarrow> 'b2) \<Rightarrow> ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'c)"
("_ o2 '(_,_')" 55)
where "h o2 (f,g) == \<lambda> x y. h (f x) (g y)"

term "comp2 h f g"

lemma comp2_simp[simp]:
"(h o2 (f,g)) x y = h (f x) (g y)"
unfolding comp2_def by simp

lemma comp2_comp:
"((h o2 (f,g)) o2 (f',g')) = (h o2 (f o f', g o g'))"
unfolding comp_def[abs_def] comp2_def[abs_def] by(rule ext, auto)

lemma liftAll_imp_liftAll2:
assumes "liftAll (\<lambda>v. \<forall> v'. phi v v') inp"
shows "liftAll2 phi inp inp'"
using assms unfolding liftAll_def liftAll2_def by auto

lemma liftAll2_mono:
assumes "\<And> v v'. phi v v' \<Longrightarrow> chi v v'" and "liftAll2 phi inp inp'"
shows "liftAll2 chi inp inp'"
using assms unfolding liftAll2_def by blast

lemma liftAll2_True: "liftAll2 (\<lambda> v v'. True) inp inp'"
unfolding liftAll2_def by auto

lemma liftAll2_lift_comp2:
"liftAll2 phi (lift f1 inp1) (lift f2 inp2) =
 liftAll2 (phi o2 (f1,f2)) inp1 inp2"
unfolding liftAll2_def comp2_def[abs_def]
proof(rule iff_allI,auto)
  fix i v1 v2 assume "inp1 i = Some v1" and "inp2 i = Some v2" and
  "\<forall>w1 w2. lift f1 inp1 i = Some w1 \<and> lift f2 inp2 i = Some w2 \<longrightarrow> phi w1 w2"
  thus "phi (f1 v1) (f2 v2)" unfolding lift_def by auto
next
  fix i w1 w2
  assume 1: "\<forall>v1 v2. inp1 i = Some v1 \<and> inp2 i = Some v2 \<longrightarrow> phi (f1 v1) (f2 v2)" and
  "lift f1 inp1 i = Some w1" and 2: "lift f2 inp2 i = Some w2"
  then obtain v1 where inp1: "inp1 i = Some v1" and w1: "w1 = f1 v1"
  unfolding lift_def by (cases "inp1 i", auto)
  obtain v2 where inp2: "inp2 i = Some v2" and w2: "w2 = f2 v2"
  using 1 2 unfolding lift_def by (cases "inp2 i", auto)
  show "phi w1 w2" using 1 unfolding inp1 inp2 w1 w2 by simp
qed

lemma lift_imp_sameDom:
"lift f inp = lift f inp' \<Longrightarrow> sameDom inp inp'"
unfolding lift_def sameDom_def
apply clarify
apply(drule_tac x = i in fun_cong)
by(case_tac "inp i", (case_tac "inp' i", auto)+)

lemma lift_lift2:
"lift f (lift2 g inp' inp) =
 lift2 (\<lambda> v' v. f (g v' v)) inp' inp"
unfolding lift_def lift2_def
apply(rule ext) apply simp
apply(case_tac "inp' i", auto)
by(case_tac "inp i", auto)

lemma lift2_left[simp]:
assumes "sameDom inp' inp"
shows "lift2 (\<lambda> v' v. v') inp' inp = inp'"
unfolding lift2_def apply(rule ext)
apply(case_tac "inp' i", auto)
apply(case_tac "inp i", auto)
using assms unfolding sameDom_sym[of inp' inp]
unfolding sameDom_def by simp

lemma lift2_right[simp]:
assumes "sameDom inp' inp"
shows "lift2 (\<lambda> v' v. v) inp' inp = inp"
unfolding lift2_def apply(rule ext)
apply(case_tac "inp i", auto)
apply(case_tac "inp' i", auto) apply(case_tac "inp' i", auto)
using assms
unfolding sameDom_def by simp

lemma sameDom_lift2_1:
assumes "sameDom inp' inp"
shows
"sameDom inp' (lift2 f inp' inp) \<and>
 sameDom inp (lift2 f inp' inp)"
proof-
  let ?finp = "lift2 f inp' inp"
  have 1: "sameDom inp' (lift2 f inp' inp)"
  unfolding sameDom_def lift2_def apply clarsimp
  apply(case_tac "inp' i", auto)  apply(case_tac "inp i", auto)
  using assms unfolding sameDom_sym[of inp' inp]
  unfolding sameDom_def by simp
  hence "sameDom inp (lift2 f inp' inp)"
  using assms sameDom_sym sameDom_trans by blast
  thus ?thesis using 1 by simp
qed

lemma sameDom_lift2_2:
assumes "sameDom inp' inp"
shows
"sameDom (lift2 f inp' inp) inp' \<and>
 sameDom (lift2 f inp' inp) inp"
using assms
apply - apply(drule sameDom_lift2_1[of _ _ f])
apply auto using sameDom_sym by blast+

lemma sameDom_lift2_simp2[simp]:
assumes "sameDom inp' inp"
shows "sameDom (lift2 f inp' inp) inp1 = sameDom inp' inp1"
proof-
  have "sameDom (lift2 f inp' inp) inp1 = sameDom inp1 (lift2 f inp' inp)"
  using sameDom_sym by blast
  also have "\<dots> = sameDom inp1 inp'" using assms by simp
  also have "\<dots> = sameDom inp' inp1" using sameDom_sym by auto
  finally show ?thesis .
qed

lemma liftAll2_lift_ext:
"(sameDom inp inp' \<and> liftAll2 (\<lambda> v v'. f v = f v') inp inp') =
 (lift f inp = lift f inp')"
apply (auto simp add: lift_imp_sameDom)
unfolding lift_def liftAll2_def
apply auto
  apply(rule ext)+
  apply(case_tac "inp i")
    apply(case_tac "inp' i")
      apply simp
      apply(simp add: sameDom_def)
    apply(case_tac "inp' i")
      apply (auto simp add: sameDom_def)
      apply force
by(drule_tac x = i in fun_cong, auto)

lemma liftAll2_and:
"liftAll2 (\<lambda> v v'. phi v v' \<and> chi v v') inp inp' =
(liftAll2 phi inp inp' \<and> liftAll2 chi inp inp')"
using assms unfolding liftAll2_def by force

lemma liftAll2_mp:
assumes "liftAll2 (\<lambda> v v'. phi v v' \<longrightarrow> chi v v') inp inp'" and "liftAll2 phi inp inp'"
shows "liftAll2 chi inp inp'"
using assms unfolding liftAll2_def by auto

lemma sameDom_and_liftAll2_iff:
"(sameDom inp inp' \<and> liftAll2 phi inp inp') =
 (\<forall> i. (inp i = None \<and> inp' i = None) \<or>
         (\<exists> v v'. inp i = Some v \<and> inp' i = Some v' \<and> phi v v'))"
proof-
  let ?Left = "sameDom inp inp' \<and> liftAll2 phi inp inp'"
  let ?None = "\<lambda>i. (inp i = None \<and> inp' i = None)"
  let ?Some = "\<lambda>i. (\<exists> v v'. inp i = Some v \<and> inp' i = Some v' \<and> phi v v')"
  {fix i
   assume ?Left and "\<not> ?None i"
   then obtain v v' where "inp i = Some v \<and> inp' i = Some v'"
   unfolding sameDom_def by fastforce
   hence "?Some i" using `?Left` unfolding liftAll2_def by blast
  }
  moreover
  {
   have "\<forall> i. ?None i \<or> ?Some i \<Longrightarrow> sameDom inp inp'"
   unfolding sameDom_def by auto
   moreover
   {fix i A A' assume "inp i = Some A" and "inp' i = Some A'"
    and "?None i \<or> ?Some i"
    hence "phi A A'" by auto
   }
   ultimately have "\<forall> i. ?None i \<or> ?Some i \<Longrightarrow> ?Left" unfolding liftAll2_def by blast
  }
  ultimately show ?thesis by blast
qed

subsection {* Doubly infinitely-branching trees *}

(* These simple infinitary trees shall be used for measuring the sizes
  of possibly infinitary terms. *)

datatype ('index,'bindex)tree =
  Branch "('index,('index,'bindex)tree) input" "('bindex,('index,'bindex)tree) input"

(* The natural induction principle for (infinitary) trees:  *)

lemma tree_induct:
fixes phi::"('index,'bindex)tree \<Rightarrow> bool" and T::"('index,'bindex)tree"
assumes
  "\<And> inp binp. \<lbrakk>liftAll phi inp; liftAll phi binp\<rbrakk> \<Longrightarrow> phi (Branch inp binp)"
shows "phi T"
proof-
  let ?phio =
  "\<lambda> To::('index,'bindex)tree option. case To of None \<Rightarrow> True |Some T \<Rightarrow> phi T"
  {fix To
   have "phi T \<and> ?phio To \<and> ?phio To"
   proof(rule tree.induct, simp_all)
     fix inp::"('index,('index,'bindex)tree)input"
     and binp::"('bindex,('index,'bindex)tree)input"
     assume *: "\<And>i. ?phio (inp i)" and **:  "\<And>i. ?phio (binp i)"
     have "liftAll phi inp"
     unfolding liftAll_def proof clarify
       fix i T
       assume "inp i = Some T"
       with *[of i] show "phi T" by simp
     qed
     moreover have "liftAll phi binp"
     unfolding liftAll_def proof clarify
       fix i T
       assume "binp i = Some T"
       with **[of i] show "phi T" by simp
     qed
     ultimately show "phi (Branch inp binp)" using assms by simp
  qed
  }
  thus ?thesis by simp
qed

definition treeLess :: "('index,'bindex)tree rel"
where
"treeLess ==
 {(T,T'). \<exists> inp binp i j. T' = Branch inp binp \<and> (inp i = Some T \<or> binp j = Some T)}"

lemma treeLess_induct:
fixes phi::"('index,'bindex)tree \<Rightarrow> bool" and
      T::"('index,'bindex)tree"
assumes "\<And> T'. (\<And> T. (T,T') \<in> treeLess \<Longrightarrow> phi T) \<Longrightarrow> phi T'"
shows "phi T"
proof(rule tree_induct)
  fix inp::"('index,('index,'bindex) tree)input"
  and binp::"('bindex,('index,'bindex)tree)input"
  assume *: "liftAll phi inp" and **: "liftAll phi binp"
  have "\<And> T. (T, Branch inp binp) \<in> treeLess \<Longrightarrow> phi T"
  proof-
    fix T assume "(T, Branch inp binp) \<in> treeLess"
    then obtain i j where "inp i = Some T \<or> binp j = Some T"
    unfolding treeLess_def by auto
    with * ** show "phi T" unfolding liftAll_def by auto
  qed
  thus "phi (Branch inp binp)" using assms by blast
qed

lemma treeLess_wf: "wf treeLess"
(* this is a mere rephrazing of treeLess_induct  *)
proof(simp only: wf_def, clarify)
  fix phi T
  assume As: "\<forall>T'. (\<forall>T. (T, T') \<in> treeLess \<longrightarrow> phi T) \<longrightarrow> phi T'"
  thus "phi T" using treeLess_induct[of phi T] by blast
qed

subsection {* Facts about order relations *}

lemma Least_Max:
assumes phi: "phi (n::nat)" and fin: "finite {n. phi n}"
shows "(LEAST m. ALL n. phi n \<longrightarrow> n <= m) =
       Max {n. phi n}"
proof-
  let ?chi = "%m. ALL n. phi n \<longrightarrow> n <= m"
  let ?L = "LEAST m. ?chi m"
  let ?M = "Max {n. phi n}"
  show "?L = ?M"
  proof(rule Least_equality, auto)
    fix n assume "phi n"
    thus "n \<le> Max {n. phi n}"
    using fin Max_ge[of "{n. phi n}"] by simp
  next
    fix y assume "\<forall>n. phi n \<longrightarrow> n \<le> y"
    thus "Max {n. phi n} \<le> y"
    using assms Max_le_iff[of "{n. phi n}" y] by fastforce
  qed
qed

end


section \<open>Single Invocation Semantics\<close>
theory repliss_sem_single_invocation
  imports repliss_sem execution_invariants consistency
begin

text \<open>This theory describes the single-invocation semantics used for our proof approach.\<close>

definition
"state_monotonicGrowth_txStable callOrigin_S callOrigin_S' txStatus_S' \<equiv> (\<forall>c tx. callOrigin_S c \<triangleq> tx \<and> txStatus_S' tx \<triangleq> Committed \<longrightarrow> callOrigin_S' c \<triangleq> tx)"

definition state_monotonicGrowth :: "invocId \<Rightarrow> ('proc::valueType, 'ls, 'op, 'any::valueType) state \<Rightarrow> ('proc, 'ls, 'op, 'any) state \<Rightarrow> bool" where
"state_monotonicGrowth i S S' \<equiv>
  state_wellFormed S
  \<and> (\<exists>tr. (S ~~ tr \<leadsto>* S')
  \<and> (\<forall>(i',a)\<in>set tr. i' \<noteq> i)
  \<and> (\<forall>i'. (i', ACrash) \<notin> set tr))"

text \<open>Invariant holds for state\<close>
abbreviation invariant_all :: "('proc, 'ls, 'op, 'any) state \<Rightarrow> bool" where
"invariant_all state \<equiv>  invariant (prog state) (invContext state)"

lemma show_invariant_all_changes:
assumes "invContext S'  = invContext S "
    and "prog S' = prog S"
shows "invariant_all S' = invariant_all S"
using assms by (auto simp add: )

text \<open>
The single invocId semantics only work on a single session.
All other sessions are simulated by nondeterministic state changes, with respect to the invariant.
\<close>

definition chooseSnapshot' where
"chooseSnapshot' snapshot vis S \<equiv>
\<exists> newTxns newCalls.
     newTxns \<subseteq> dom (txStatus S)
   \<and> newCalls = callsInTransaction S newTxns \<down> happensBefore S
   \<and> snapshot = vis \<union> newCalls"

lemma chooseSnapshot_same_if_everything_committed:
  assumes "\<And>tx. txStatus S tx \<noteq> Some Uncommitted"
  shows "chooseSnapshot' snapshot vis S \<longleftrightarrow> chooseSnapshot snapshot vis S"
  unfolding chooseSnapshot'_def chooseSnapshot_def proof (intro iff_exI, auto)
  show "\<And>newTxns x.
       \<lbrakk>newTxns \<subseteq> dom (txStatus S);
        snapshot = vis \<union> callsInTransaction S newTxns \<down> happensBefore S; x \<in> newTxns\<rbrakk>
       \<Longrightarrow> txStatus S x \<triangleq> Committed"
    using assms not_uncommitted_cases by auto
qed

inductive step_s :: "('proc::valueType, 'ls, 'op, 'any::valueType) state \<Rightarrow> (invocId \<times> ('proc, 'op, 'any) action \<times> bool) \<Rightarrow> ('proc, 'ls, 'op, 'any) state \<Rightarrow> bool" (infixr "~~ _ \<leadsto>\<^sub>S" 60) where
  local:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = LocalStep ok ls'
   \<rbrakk> \<Longrightarrow> S ~~ (i, ALocal ok, ok)  \<leadsto>\<^sub>S (S\<lparr>localState := (localState S)(i \<mapsto> ls') \<rparr>)"
| newId:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = NewId ls';
   generatedIds S uid = None;
   uniqueIds uidv = {uid}; \<comment> \<open> there is exactly one unique id \<close>
   ls' uidv \<triangleq> ls'';
   uid = to_nat uidv
   \<rbrakk> \<Longrightarrow> S ~~ (i, ANewId uidv, True) \<leadsto>\<^sub>S (S\<lparr>localState := (localState S)(i \<mapsto> ls''),
                                   generatedIds := (generatedIds S)( uid \<mapsto> i) \<rparr>)"
| beginAtomic:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = BeginAtomic ls';
   currentTx S i = None;
   txStatus S t = None;
   \<comment> \<open> we assume a nondeterministic state change to C' here \<close>
   prog S' = prog S;
   state_monotonicGrowth i S S';
   \<comment> \<open> new transaction has no calls yet \<close>
   \<comment> \<open> invariant maintained \<close>
   invariant_all S';
   \<And>tx. txStatus S' tx \<noteq> Some Uncommitted;
   \<comment> \<open>  well formed history  \<close>
   state_wellFormed S';
   state_wellFormed S'';
   \<comment> \<open>  local changes:  \<close>
   localState S' i \<triangleq> ls;
   currentProc S' i \<triangleq> f;
   currentTx S' i = None;
   visibleCalls S i \<triangleq> vis;
   visibleCalls S' i \<triangleq> vis;
   chooseSnapshot vis' vis S';
   consistentSnapshot S' vis';
   txStatus S' t = None;
   \<And>c. callOrigin S' c \<noteq> Some t;
   txOrigin S' t = None;
   (S'' = S'\<lparr>txStatus := (txStatus S')(t \<mapsto> Uncommitted),
              txOrigin := (txOrigin S')(t \<mapsto> i),
              currentTx := (currentTx S')(i \<mapsto> t),
              localState := (localState S')(i \<mapsto> ls'),
              visibleCalls := (visibleCalls S')(i \<mapsto> vis')
    \<rparr>)
   \<rbrakk> \<Longrightarrow> S ~~ (i, ABeginAtomic t vis', True) \<leadsto>\<^sub>S S''"
| endAtomic:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = EndAtomic ls';
   currentTx S i \<triangleq> t;
   S' = (S\<lparr>localState := (localState S)(i \<mapsto> ls'),
                currentTx := (currentTx S)(i := None),
                txStatus := (txStatus S)(t \<mapsto> Committed) \<rparr>);
   state_wellFormed S';
   valid = invariant_all S'
   \<rbrakk> \<Longrightarrow> S ~~ (i, AEndAtomic, valid) \<leadsto>\<^sub>S S'"
| dbop:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = DbOperation Op ls';
   currentTx S i \<triangleq> t;
   calls S c = None;
   querySpec (prog S) Op (getContext S i)  res;
   visibleCalls S i \<triangleq> vis
   \<rbrakk> \<Longrightarrow>  S ~~ (i, ADbOp c Op res, True) \<leadsto>\<^sub>S (S\<lparr>localState := (localState S)(i \<mapsto> ls' res),
                calls := (calls S)(c \<mapsto> Call Op res ),
                callOrigin := (callOrigin S)(c \<mapsto> t),
                visibleCalls := (visibleCalls S)(i \<mapsto> vis \<union> {c}),
                happensBefore := happensBefore S \<union> vis \<times> {c}  \<rparr>)"
| invocation:
  "\<lbrakk>\<comment> \<open> localState C s = None; \<close>
   invocOp S i = None;
   procedure (prog S) proc = (initState, impl);
   uniqueIds proc \<subseteq> knownIds S';
   state_wellFormed S';
   \<And>tx. txStatus S' tx \<noteq> Some Uncommitted;
   invariant_all S';
   invocOp S' i = None;
   prog S' = prog S;
   S'' = (S'\<lparr>localState := (localState S')(i \<mapsto> initState),
                 currentProc := (currentProc S')(i \<mapsto> impl),
                 visibleCalls := (visibleCalls S')(i \<mapsto> {}),
                 invocOp := (invocOp S')(i \<mapsto> proc) \<rparr>);
   valid = invariant_all S'';
   \<And>tx. txOrigin S'' tx \<noteq> Some i
   \<rbrakk> \<Longrightarrow>  S ~~ (i, AInvoc proc, valid) \<leadsto>\<^sub>S S''"
| return:
  "\<lbrakk>localState S i \<triangleq> ls;
   currentProc S i \<triangleq> f;
   f ls = Return res;
   currentTx S i = None;
   S' = (S\<lparr>localState := (localState S)(i := None),
                 currentProc := (currentProc S)(i := None),
                 visibleCalls := (visibleCalls S)(i := None),
                 invocRes := (invocRes S)(i \<mapsto> res),
                 knownIds := knownIds S \<union> uniqueIds res\<rparr>);
   valid = invariant_all S'
   \<rbrakk> \<Longrightarrow>  S ~~ (i, AReturn res, valid) \<leadsto>\<^sub>S S'"

inductive steps_s :: "('proc::valueType, 'ls, 'op, 'any::valueType) state \<Rightarrow> invocId \<times> (('proc, 'op, 'any) action \<times> bool) list \<Rightarrow> ('proc, 'ls, 'op, 'any) state \<Rightarrow> bool" (infixr "~~ _ \<leadsto>\<^sub>S*" 60) where
  steps_s_refl:
  "S ~~ (i, []) \<leadsto>\<^sub>S* S"
| steps_s_step:
  "\<lbrakk>S ~~ (i, tr) \<leadsto>\<^sub>S* S'; S' ~~ (i,a) \<leadsto>\<^sub>S S''\<rbrakk> \<Longrightarrow> S ~~ (i, tr@[a]) \<leadsto>\<^sub>S* S''"

\<comment> \<open>Add some nicer syntax for Latex output:\<close>

notation (latex output)
  step_s ("(_) \<^latex>\<open>\\sstep{\<close> (\<open>unbreakable\<close> _) \<^latex>\<open>}\<close> (1 _)" [5,5,5]65)
notation (latex output)
  steps_s ("(_) \<^latex>\<open>\\ssteps{\<close> (\<open>unbreakable\<close> _) \<^latex>\<open>}\<close> (1 _)" [5,5,5]65)

definition traceCorrect_s where
"traceCorrect_s trace \<equiv> (\<forall>a. (a, False) \<notin> set trace)"

lemma traceCorrect_s_split:
  assumes "snd a"
and "traceCorrect_s trace"
shows "traceCorrect_s (a#trace)"
  by (metis assms set_ConsD sndI traceCorrect_s_def)

definition programCorrect_s where
"programCorrect_s program \<equiv> (\<forall>trace i S.
   (initialState program ~~ (i, trace) \<leadsto>\<^sub>S* S)
    \<longrightarrow> traceCorrect_s trace)"

lemma steps_s_append:
assumes a1: "S ~~ (s, tra) \<leadsto>\<^sub>S* S'"
    and a2: "S' ~~ (s, trb) \<leadsto>\<^sub>S* S''"
shows "S ~~ (s, tra@trb) \<leadsto>\<^sub>S* S''"
using a1 a2 proof (induct trb arbitrary: S'' rule: rev_induct)
  case Nil
  then show ?case
    by (metis append_Nil2 snd_conv snoc_eq_iff_butlast steps_s.simps)
next
  case (snoc x xs)

  obtain S_mid
   where  steps_xs: "S' ~~ (s, xs) \<leadsto>\<^sub>S* S_mid"
   and step_x: "S_mid ~~ (s,x) \<leadsto>\<^sub>S S''"
    apply (atomize_elim)
    apply (rule steps_s.cases[OF \<open>S' ~~ (s, xs @ [x]) \<leadsto>\<^sub>S* S''\<close>])
    by auto

  have "S ~~ (s, (tra @ xs) @ [x]) \<leadsto>\<^sub>S* S''"
  proof (rule steps_s_step)
    show "S_mid ~~ (s, x) \<leadsto>\<^sub>S S''" using step_x .
    show "S ~~ (s, tra @ xs) \<leadsto>\<^sub>S* S_mid"
      using steps_xs
      by (simp add: a1 snoc.hyps)
  qed
  then show "S ~~ (s, tra @ xs @ [x]) \<leadsto>\<^sub>S* S''"
    by simp
qed

lemma steps_s_append_simp:
"(S ~~ (s, tra@trb) \<leadsto>\<^sub>S* S'') \<longleftrightarrow> (\<exists>S'. (S ~~ (s, tra) \<leadsto>\<^sub>S* S') \<and> (S' ~~ (s, trb) \<leadsto>\<^sub>S* S''))"
proof
  show "\<exists>S'. (S ~~ (s, tra) \<leadsto>\<^sub>S* S') \<and> (S' ~~ (s, trb) \<leadsto>\<^sub>S* S'') \<Longrightarrow> S ~~ (s, tra @ trb) \<leadsto>\<^sub>S* S''"
    using steps_s_append by blast

  show "S ~~ (s, tra @ trb) \<leadsto>\<^sub>S* S'' \<Longrightarrow> \<exists>S'. (S ~~ (s, tra) \<leadsto>\<^sub>S* S') \<and> (S' ~~ (s, trb) \<leadsto>\<^sub>S* S'')"
  proof (induct trb arbitrary: S'' rule: rev_induct)
    case Nil
    then show ?case by (auto simp add: steps_s_refl)
  next
    case (snoc a trb')

    from \<open>S ~~ (s, tra @ trb' @ [a]) \<leadsto>\<^sub>S* S''\<close>
    obtain S1 where "S ~~ (s, tra @ trb') \<leadsto>\<^sub>S* S1" and "S1 ~~ (s, a) \<leadsto>\<^sub>S S''"
      using Pair_inject steps_s.cases by force

    moreover from \<open>S ~~ (s, tra @ trb') \<leadsto>\<^sub>S* S1\<close>
    obtain S2 where "S ~~ (s, tra) \<leadsto>\<^sub>S* S2" and "S2 ~~ (s, trb') \<leadsto>\<^sub>S* S1"
      using snoc.hyps by blast

    ultimately show ?case
      using steps_s_step by blast
  qed
qed

lemma steps_s_empty:
"(S ~~ (s, []) \<leadsto>\<^sub>S* S') \<longleftrightarrow> (S' = S)"
apply (auto simp add: step_s.simps steps_s_refl)
  using steps_s.cases by fastforce

lemma steps_s_single:
"(S ~~ (s, [a]) \<leadsto>\<^sub>S* S') \<longleftrightarrow> (S ~~ (s, a) \<leadsto>\<^sub>S S')"
apply (subst steps_s.simps)
by (auto simp add:  steps_s_empty)

lemma steps_s_cons_simp:
"(S ~~ (s, a#tr) \<leadsto>\<^sub>S* S'') \<longleftrightarrow> (\<exists>S'. (S ~~ (s, a) \<leadsto>\<^sub>S S') \<and> (S' ~~ (s, tr) \<leadsto>\<^sub>S* S''))"
proof -
  have "(S ~~ (s, a#tr) \<leadsto>\<^sub>S* S'') \<longleftrightarrow> (S ~~ (s, [a]@tr) \<leadsto>\<^sub>S* S'')"
    by simp
  moreover have "... \<longleftrightarrow>  (\<exists>S'. (S ~~ (s, [a]) \<leadsto>\<^sub>S* S') \<and> (S' ~~ (s, tr) \<leadsto>\<^sub>S* S''))"
    using steps_s_append_simp by blast
  moreover have "... \<longleftrightarrow>  (\<exists>S'. (S ~~ (s, a) \<leadsto>\<^sub>S S') \<and> (S' ~~ (s, tr) \<leadsto>\<^sub>S* S''))"
    using steps_s_single by blast
  ultimately show ?thesis by blast
qed

lemma step_s_induct[consumes 1, case_names initial step[IH step]]:
assumes steps: "S_init ~~ (i, tr) \<leadsto>\<^sub>S* S"
    and initial: "P [] S_init"
    and step: "\<And>tr S a S'. \<lbrakk>P tr S; S_init ~~ (i,tr) \<leadsto>\<^sub>S* S;  S ~~ (i, a) \<leadsto>\<^sub>S S'\<rbrakk> \<Longrightarrow> P (tr@[a]) S'"
shows "P tr S"
proof -
  (*have "(S_init ~~ (i, tr) \<leadsto>\<^sub>S* S) \<and> P S_init \<longrightarrow> P S"*)

  from steps initial have "P tr S \<and> S_init ~~ (i, tr) \<leadsto>\<^sub>S* S"
  proof (induct tr arbitrary:  S rule: rev_induct)
    case Nil
    then have "S = S_init"
      using steps_s.cases by fastforce
    with \<open>P [] S_init\<close> \<open>S_init ~~ (i, []) \<leadsto>\<^sub>S* S\<close>
    show ?case by auto

  next
    case (snoc a tr)
    from \<open>S_init ~~ (i, tr@[a]) \<leadsto>\<^sub>S* S\<close>
    obtain S1
      where S1a: "S_init ~~ (i, tr) \<leadsto>\<^sub>S* S1"
        and S1b: "S1 ~~ (i, a) \<leadsto>\<^sub>S S"
      using steps_s_cons_simp
      by (meson steps_s_append_simp steps_s_single)

    from \<open>S_init ~~ (i, tr) \<leadsto>\<^sub>S* S1\<close> and \<open>P [] S_init\<close>
    have "P tr S1 \<and> S_init ~~ (i, tr) \<leadsto>\<^sub>S* S1"
      by (rule snoc.hyps)

    with S1b have "P (tr@[a]) S"
      using local.step by blast

    with \<open>S_init ~~ (i, tr @ [a]) \<leadsto>\<^sub>S* S\<close>
    show ?case by auto

  qed

  then show "P tr S" by simp
qed

lemma step_s_no_Fail:
  assumes "S ~~ (i, a) \<leadsto>\<^sub>S S'"
  shows "a \<noteq> (ACrash, t)"
  using assms  by (auto simp add: step_s.simps)

lemma steps_s_no_Fail:
  assumes "S ~~ (i, tr) \<leadsto>\<^sub>S* S'"
  shows "(ACrash, t) \<notin> set tr"
  using assms apply (induct rule: step_s_induct)
  using step_s_no_Fail by (auto, blast)

end


header {* \isaheader{Observable Sets of Nodes} *}

theory Observable imports ReturnAndCallNodes begin

context CFG begin

subsection {* Intraprocedural observable sets *}

inductive_set obs_intra :: "'node \<Rightarrow> 'node set \<Rightarrow> 'node set"
for n::"'node" and S::"'node set"
where obs_intra_elem:
  "\<lbrakk>n -as\<rightarrow>\<^sub>\<iota>* n'; \<forall>nx \<in> set(sourcenodes as). nx \<notin> S; n' \<in> S\<rbrakk> \<Longrightarrow> n' \<in> obs_intra n S"

lemma obs_intraE:
  assumes "n' \<in> obs_intra n S"
  obtains as where "n -as\<rightarrow>\<^sub>\<iota>* n'" and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S" and "n' \<in> S"
  using `n' \<in> obs_intra n S`
  by(fastforce elim:obs_intra.cases)

lemma n_in_obs_intra:
  assumes "valid_node n" and "n \<in> S" shows "obs_intra n S = {n}"
proof -
  from `valid_node n` have "n -[]\<rightarrow>* n" by(rule empty_path)
  hence "n -[]\<rightarrow>\<^sub>\<iota>* n" by(simp add:intra_path_def)
  with `n \<in> S` have "n \<in> obs_intra n S"
    by(fastforce elim:obs_intra_elem simp:sourcenodes_def)
  { fix n' assume "n' \<in> obs_intra n S"
    have "n' = n"
    proof(rule ccontr)
      assume "n' \<noteq> n"
      from `n' \<in> obs_intra n S` obtain as where "n -as\<rightarrow>\<^sub>\<iota>* n'"
        and "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S"
        and "n' \<in> S" by(fastforce elim:obs_intra.cases)
      from `n -as\<rightarrow>\<^sub>\<iota>* n'` have "n -as\<rightarrow>* n'" by(simp add:intra_path_def)
      from this `\<forall>nx \<in> set(sourcenodes as). nx \<notin> S` `n' \<noteq> n` `n \<in> S`
      show False
      proof(induct rule:path.induct)
        case (Cons_path n'' as n' a n)
        from `\<forall>nx\<in>set (sourcenodes (a#as)). nx \<notin> S` `sourcenode a = n`
        have "n \<notin> S" by(simp add:sourcenodes_def)
        with `n \<in> S` show False by simp
      qed simp
    qed }
  with `n \<in> obs_intra n S` show ?thesis by fastforce
qed

lemma in_obs_intra_valid:
  assumes "n' \<in> obs_intra n S" shows "valid_node n" and "valid_node n'"
  using `n' \<in> obs_intra n S`
  by(auto elim!:obs_intraE intro:path_valid_node simp:intra_path_def)

lemma edge_obs_intra_subset:
  assumes "valid_edge a" and "intra_kind (kind a)" and "sourcenode a \<notin> S"
  shows "obs_intra (targetnode a) S \<subseteq> obs_intra (sourcenode a) S"
proof
  fix n assume "n \<in> obs_intra (targetnode a) S"
  then obtain as where "targetnode a -as\<rightarrow>\<^sub>\<iota>* n"
    and all:"\<forall>nx \<in> set(sourcenodes as). nx \<notin> S" and "n \<in> S" by(erule obs_intraE)
  from `valid_edge a` `intra_kind (kind a)` `targetnode a -as\<rightarrow>\<^sub>\<iota>* n`
  have "sourcenode a -[a]@as\<rightarrow>\<^sub>\<iota>* n" by(fastforce intro:Cons_path simp:intra_path_def)
  moreover
  from all `sourcenode a \<notin> S` have "\<forall>nx \<in> set(sourcenodes (a#as)). nx \<notin> S"
    by(simp add:sourcenodes_def)
  ultimately show "n \<in> obs_intra (sourcenode a) S" using `n \<in> S`
    by(fastforce intro:obs_intra_elem)
qed

lemma path_obs_intra_subset:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'" and "\<forall>n' \<in> set(sourcenodes as). n' \<notin> S"
  shows "obs_intra n' S \<subseteq> obs_intra n S"
proof -
  from `n -as\<rightarrow>\<^sub>\<iota>* n'` have "n -as\<rightarrow>* n'" and "\<forall>a \<in> set as. intra_kind (kind a)"
    by(simp_all add:intra_path_def)
  from this `\<forall>n' \<in> set(sourcenodes as). n' \<notin> S` show ?thesis
  proof(induct rule:path.induct)
    case (Cons_path n'' as n' a n)
    note IH = `\<lbrakk>\<forall>a\<in>set as. intra_kind (kind a); \<forall>n'\<in>set (sourcenodes as). n' \<notin> S\<rbrakk>
      \<Longrightarrow> obs_intra n' S \<subseteq> obs_intra n'' S`
    from `\<forall>n'\<in>set (sourcenodes (a#as)). n' \<notin> S`
    have all:"\<forall>n'\<in>set (sourcenodes as). n' \<notin> S" and "sourcenode a \<notin> S"
      by(simp_all add:sourcenodes_def)
    from `\<forall>a \<in> set (a#as). intra_kind (kind a)`
    have "intra_kind (kind a)" and "\<forall>a \<in> set as. intra_kind (kind a)"
      by(simp_all add:intra_path_def)
    from IH[OF `\<forall>a \<in> set as. intra_kind (kind a)` all]
    have "obs_intra n' S \<subseteq> obs_intra n'' S" .
    from `valid_edge a` `intra_kind (kind a)` `targetnode a = n''`
      `sourcenode a = n` `sourcenode a \<notin> S`
    have "obs_intra n'' S \<subseteq> obs_intra n S" by(fastforce dest:edge_obs_intra_subset)
    with `obs_intra n' S \<subseteq> obs_intra n'' S` show ?case by fastforce
  qed simp
qed

lemma path_ex_obs_intra:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'" and "n' \<in> S"
  obtains m where "m \<in> obs_intra n S"
proof(atomize_elim)
  show "\<exists>m. m \<in> obs_intra n S"
  proof(cases "\<forall>nx \<in> set(sourcenodes as). nx \<notin> S")
    case True
    with `n -as\<rightarrow>\<^sub>\<iota>* n'` `n' \<in> S` have "n' \<in> obs_intra n S" by -(rule obs_intra_elem)
    thus ?thesis by fastforce
  next
    case False
    hence "\<exists>nx \<in> set(sourcenodes as). nx \<in> S" by fastforce
    then obtain nx ns ns' where "sourcenodes as = ns@nx#ns'"
      and "nx \<in> S" and "\<forall>n' \<in> set ns. n' \<notin> S"
      by(fastforce elim!:split_list_first_propE)
    from `sourcenodes as = ns@nx#ns'` obtain as' a as''
      where "ns = sourcenodes as'"
      and "as = as'@a#as''" and "sourcenode a = nx"
      by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
    with `n -as\<rightarrow>\<^sub>\<iota>* n'` have "n -as'\<rightarrow>\<^sub>\<iota>* nx"
      by(fastforce dest:path_split simp:intra_path_def)
    with `nx \<in> S` `\<forall>n' \<in> set ns. n' \<notin> S` `ns = sourcenodes as'`
    have "nx \<in> obs_intra n S" by(fastforce intro:obs_intra_elem)
    thus ?thesis by fastforce
  qed
qed

subsection {* Interprocedural observable sets restricted to the slice *}

fun obs :: "'node list \<Rightarrow> 'node set \<Rightarrow> 'node list set"
  where "obs [] S = {}"
  | "obs (n#ns) S = (let S' = obs_intra n S in
  (if (S' = {} \<or> (\<exists>n' \<in> set ns. \<exists>nx. call_of_return_node n' nx \<and> nx \<notin> S))
   then obs ns S else (\<lambda>nx. nx#ns) ` S'))"

lemma obsI:
  assumes "n' \<in> obs_intra n S"
  and "\<forall>nx \<in> set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
  shows "\<lbrakk>ns = nsx@n#nsx'; \<forall>xs x xs'. nsx = xs@x#xs' \<and> obs_intra x S \<noteq> {}
     \<longrightarrow> (\<exists>x'' \<in> set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)\<rbrakk>
  \<Longrightarrow> n'#nsx' \<in> obs ns S"
proof(induct ns arbitrary:nsx)
case (Cons x xs)
  note IH = `\<And>nsx. \<lbrakk>xs = nsx@n#nsx';
    \<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)\<rbrakk>
    \<Longrightarrow> n'#nsx' \<in> obs xs S`
  note nsx = `\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)`
  show ?case
  proof(cases nsx)
    case Nil
    with `x#xs = nsx@n#nsx'` have "n = x" and "xs = nsx'" by simp_all
    with `n' \<in> obs_intra n S`
      `\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S`
    show ?thesis by(fastforce simp:Let_def)
  next
    case (Cons z zs)
    with `x#xs = nsx@n#nsx'` have [simp]:"x = z" "xs = zs@n#nsx'" by simp_all
    from nsx Cons
    have "\<forall>xs x xs'. zs = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
      (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
      by clarsimp(erule_tac x="z#xs" in allE,auto)
    from IH[OF `xs = zs@n#nsx'` this] have "n'#nsx' \<in> obs xs S" by simp
    show ?thesis
    proof(cases "obs_intra z S = {}")
      case True
      with Cons `n'#nsx' \<in> obs xs S` show ?thesis by(simp add:Let_def)
    next
      case False
      from nsx Cons
      have "obs_intra z S \<noteq> {} \<longrightarrow>
        (\<exists>x''\<in>set (zs @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
        by clarsimp
      with False have "\<exists>x''\<in>set (zs @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S"
        by simp
      with `xs = zs@n#nsx'`
      have "\<exists>n' \<in> set xs. \<exists>nx. call_of_return_node n' nx \<and> nx \<notin> S" by fastforce
      with Cons `n'#nsx' \<in> obs xs S` show ?thesis by(simp add:Let_def)
    qed
  qed
qed simp

lemma obsE [consumes 2]:
  assumes "ns' \<in> obs ns S" and "\<forall>n \<in> set (tl ns). return_node n"
  obtains nsx n nsx' n' where "ns = nsx@n#nsx'" and "ns' = n'#nsx'"
  and "n' \<in> obs_intra n S"
  and "\<forall>nx \<in> set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
  and "\<forall>xs x xs'. nsx = xs@x#xs' \<and> obs_intra x S \<noteq> {}
  \<longrightarrow> (\<exists>x'' \<in> set (xs'@[n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
proof(atomize_elim)
  from `ns' \<in> obs ns S` `\<forall>n \<in> set (tl ns). return_node n`
  show "\<exists>nsx n nsx' n'. ns = nsx @ n # nsx' \<and> ns' = n' # nsx' \<and>
    n' \<in> obs_intra n S \<and> (\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S) \<and>
    (\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
    (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S))"
  proof(induct ns)
    case Nil thus ?case by simp
  next
    case (Cons nx ns'')
    note IH = `\<lbrakk>ns' \<in> obs ns'' S; \<forall>a\<in>set (tl ns''). return_node a\<rbrakk>
      \<Longrightarrow> \<exists>nsx n nsx' n'. ns'' = nsx @ n # nsx' \<and> ns' = n' # nsx' \<and>
      n' \<in> obs_intra n S \<and>
      (\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S) \<and>
      (\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
         (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S))`
    from `\<forall>a\<in>set (tl (nx # ns'')). return_node a` have "\<forall>n \<in> set ns''. return_node n"
      by simp
    show ?case
    proof(cases ns'')
      case Nil
      with `ns' \<in> obs (nx#ns'') S` obtain x where "ns' = [x]" and "x \<in> obs_intra nx S"
        by(auto simp:Let_def split:split_if_asm)
      with Nil show ?thesis by fastforce
    next
      case Cons
      with `\<forall>n \<in> set ns''. return_node n` have "\<forall>a\<in>set (tl ns''). return_node a"
        by simp
      show ?thesis
      proof(cases "\<exists>n' \<in> set ns''. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S")
        case True
        with `ns' \<in> obs (nx#ns'') S` have "ns' \<in> obs ns'' S" by simp
        from IH[OF this `\<forall>a\<in>set (tl ns''). return_node a`]
        obtain nsx n nsx' n' where split:"ns'' = nsx @ n # nsx'"
          "ns' = n' # nsx'" "n' \<in> obs_intra n S"
          "\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
          and imp:"\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
          (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
          by blast
        from True `ns'' = nsx @ n # nsx'`
          `\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S`
        have "(\<exists>nx'. call_of_return_node n nx' \<and> nx' \<notin> S) \<or>
          (\<exists>n'\<in>set nsx. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S)" by fastforce
        thus ?thesis
        proof
          assume "\<exists>nx'. call_of_return_node n nx' \<and> nx' \<notin> S"
          with split show ?thesis by clarsimp
        next
          assume "\<exists>n'\<in>set nsx. \<exists>nx'. call_of_return_node n' nx' \<and> nx' \<notin> S"
          with imp have "\<forall>xs x xs'. nx#nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
          (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            apply clarsimp apply(case_tac xs) apply auto
            by(erule_tac x="list" in allE,auto)+
          with split Cons show ?thesis by auto
        qed
      next
        case False
        hence "\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S" by simp
        show ?thesis
        proof(cases "obs_intra nx S = {}")
          case True
          with `ns' \<in> obs (nx#ns'') S` have "ns' \<in> obs ns'' S" by simp
          from IH[OF this `\<forall>a\<in>set (tl ns''). return_node a`]
          obtain nsx n nsx' n' where split:"ns'' = nsx @ n # nsx'"
            "ns' = n' # nsx'" "n' \<in> obs_intra n S"
            "\<forall>nx\<in>set nsx'. \<exists>nx'. call_of_return_node nx nx' \<and> nx' \<in> S"
            and imp:"\<forall>xs x xs'. nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
            (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            by blast
          from True imp Cons
          have "\<forall>xs x xs'. nx#nsx = xs @ x # xs' \<and> obs_intra x S \<noteq> {} \<longrightarrow>
            (\<exists>x''\<in>set (xs' @ [n]). \<exists>nx. call_of_return_node x'' nx \<and> nx \<notin> S)"
            by clarsimp (hypsubst_thin,case_tac xs,clarsimp+,erule_tac x="list" in allE,auto)
          with split Cons show ?thesis by auto
        next
          case False
          with `\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S`
            `ns' \<in> obs (nx # ns'') S`
          obtain nx'' where "ns' = nx''#ns''" and "nx'' \<in> obs_intra nx S"
          by(fastforce simp:Let_def split:split_if_asm)
          { fix n' assume "n'\<in>set ns''"
            with `\<forall>n \<in> set ns''. return_node n` have "return_node n'" by simp
            hence "\<exists>!n''. call_of_return_node n' n''"
              by(rule return_node_call_of_return_node)
            from `n'\<in>set ns''`
              `\<forall>n'\<in>set ns''. \<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S`
            have "\<forall>nx'. call_of_return_node n' nx' \<longrightarrow> nx' \<in> S" by simp
            with `\<exists>!n''. call_of_return_node n' n''`
            have "\<exists>n''. call_of_return_node n' n'' \<and> n'' \<in> S" by fastforce }
          with `ns' = nx''#ns''` `nx'' \<in> obs_intra nx S` show ?thesis by fastforce
        qed
      qed
    qed
  qed
qed

lemma obs_split_det:
  assumes "xs@x#xs' = ys@y#ys'"
  and "obs_intra x S \<noteq> {}"
  and "\<forall>x' \<in> set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S"
  and "\<forall>zs z zs'. xs = zs@z#zs' \<and> obs_intra z S \<noteq> {}
  \<longrightarrow> (\<exists>z'' \<in> set (zs'@[x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)"
  and "obs_intra y S \<noteq> {}"
  and "\<forall>y' \<in> set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S"
  and "\<forall>zs z zs'. ys = zs@z#zs' \<and> obs_intra z S \<noteq> {}
  \<longrightarrow> (\<exists>z'' \<in> set (zs'@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)"
  shows "xs = ys \<and> x = y \<and> xs' = ys'"
using assms
proof(induct xs arbitrary:ys)
  case Nil
  note impy = `\<forall>zs z zs'. ys = zs@z#zs' \<and> obs_intra z S \<noteq> {}
    \<longrightarrow> (\<exists>z'' \<in> set (zs'@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)`
  show ?case
  proof(cases "ys = []")
    case True
    with Nil `[]@x#xs' = ys@y#ys'` show ?thesis by simp
  next
    case False
    with `[] @ x # xs' = ys @ y # ys'`
    obtain zs where "x#zs = ys" and "xs' = zs@y#ys'" by(auto simp:Cons_eq_append_conv)
    from `x#zs = ys` `obs_intra x S \<noteq> {}` impy
    have "\<exists>z'' \<in> set (zs@[y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S"
      by blast
    with `xs' = zs@y#ys'` `\<forall>x' \<in> set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S`
    have False by fastforce
    thus ?thesis by simp
  qed
next
  case (Cons w ws)
  note IH = `\<And>ys. \<lbrakk>ws @ x # xs' = ys @ y # ys'; obs_intra x S \<noteq> {};
    \<forall>x'\<in>set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S;
    \<forall>zs z zs'. ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S);
    obs_intra y S \<noteq> {}; \<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S;
    \<forall>zs z zs'. ys = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)\<rbrakk>
    \<Longrightarrow> ws = ys \<and> x = y \<and> xs' = ys'`
  note impw = `\<forall>zs z zs'. w # ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
    (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)`
  note impy = `\<forall>zs z zs'. ys = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
    (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)`
  show ?case
  proof(cases ys)
    case Nil
    with `(w#ws) @ x # xs' = ys @ y # ys'` have "y = w" and "ys' = ws @ x # xs'"
      by simp_all
    from `y = w` `obs_intra y S \<noteq> {}` impw
    have "\<exists>z''\<in>set (ws @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S" by blast
    with `ys' = ws @ x # xs'`
      `\<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S`
    have False by fastforce
    thus ?thesis by simp
  next
    case (Cons w' ws')
    with `(w # ws) @ x # xs' = ys @ y # ys'` have "w = w'"
      and "ws @ x # xs' = ws' @ y # ys'" by simp_all
    from impw have imp1:"\<forall>zs z zs'. ws = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [x]). \<exists>nx. call_of_return_node z'' nx \<and> nx \<notin> S)"
      by clarsimp(erule_tac x="w#zs" in allE,clarsimp)
    from Cons impy have imp2:"\<forall>zs z zs'. ws' = zs @ z # zs' \<and> obs_intra z S \<noteq> {} \<longrightarrow>
      (\<exists>z''\<in>set (zs' @ [y]). \<exists>ny. call_of_return_node z'' ny \<and> ny \<notin> S)"
      by clarsimp(erule_tac x="w'#zs" in allE,clarsimp)
    from IH[OF `ws @ x # xs' = ws' @ y # ys'` `obs_intra x S \<noteq> {}`
      `\<forall>x'\<in>set xs'. \<exists>x''. call_of_return_node x' x'' \<and> x'' \<in> S` imp1
      `obs_intra y S \<noteq> {}` `\<forall>y'\<in>set ys'. \<exists>y''. call_of_return_node y' y'' \<and> y'' \<in> S`
      imp2]
    have "ws = ws' \<and> x = y \<and> xs' = ys'" .
    with `w = w'` Cons show ?thesis by simp
  qed
qed

lemma in_obs_valid:
  assumes "ns' \<in> obs ns S" and "\<forall>n \<in> set ns. valid_node n"
  shows "\<forall>n \<in> set ns'. valid_node n"
  using `ns' \<in> obs ns S` `\<forall>n \<in> set ns. valid_node n`
  by(induct ns)(auto intro:in_obs_intra_valid simp:Let_def split:split_if_asm)

end

end