section \<open>Implementations of the Partial-S-Method\<close>

theory Partial_S_Method_Implementations
imports Intermediate_Frameworks
begin

subsection \<open>Using the H-Framework\<close>

(* check whether q2 can be reached from q1 in up to a given number steps *)
fun distance_at_most :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> bool" where
  "distance_at_most M q1 q2 0 = (q1 = q2)" |
  "distance_at_most M q1 q2 (Suc k) = ((q1 = q2) \<or> (\<exists> x \<in> inputs M . \<exists> (y,q1') \<in> h M (q1,x) . distance_at_most M q1' q2 k))"

(* check whether X (unverified transitions) contains some t' such that the source of t' is reachable from the target of t in at most l steps *)
definition do_establish_convergence :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> ('a,'b,'c) state_cover_assignment \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) transition list \<Rightarrow> nat \<Rightarrow> bool" where
  "do_establish_convergence M V t X l = (find (\<lambda> t' . distance_at_most M (t_target t) (t_source t') l) X \<noteq> None)"

definition partial_s_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "partial_s_method_via_h_framework = h_framework_dynamic do_establish_convergence"

definition partial_s_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "partial_s_method_via_h_framework_lists M m completeInputTraces useInputHeuristic = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (partial_s_method_via_h_framework M m completeInputTraces useInputHeuristic))"

lemma partial_s_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (partial_s_method_via_h_framework M1 m completeInputTraces useInputHeuristic)) = (L M2 \<inter> set (partial_s_method_via_h_framework M1 m completeInputTraces useInputHeuristic)))"
and "finite_tree (partial_s_method_via_h_framework M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_completeness_and_finiteness[OF assms]
  unfolding partial_s_method_via_h_framework_def
  by blast+

lemma partial_s_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (partial_s_method_via_h_framework_lists M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_lists_completeness[OF assms]
  unfolding partial_s_method_via_h_framework_lists_def h_framework_dynamic_lists_def partial_s_method_via_h_framework_def
  by blast

end


(*  Title:       POSIX Lexing with Derivatives of Regular Expressions
    Authors:     Fahad Ausaf <fahad.ausaf at icloud.com>, 2016
                 Roy Dyckhoff <roy.dyckhoff at st-andrews.ac.uk>, 2016
                 Christian Urban <christian.urban at kcl.ac.uk>, 2016
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*)

theory Simplifying
  imports Lexer
begin

section \<open>Lexer including simplifications\<close>

fun F_RIGHT where
  "F_RIGHT f v = Right (f v)"

fun F_LEFT where
  "F_LEFT f v = Left (f v)"

fun F_Plus where
  "F_Plus f\<^sub>1 f\<^sub>2 (Right v) = Right (f\<^sub>2 v)"
| "F_Plus f\<^sub>1 f\<^sub>2 (Left v) = Left (f\<^sub>1 v)"
| "F_Plus f1 f2 v = v"

fun F_Times1 where
  "F_Times1 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 Void) (f\<^sub>2 v)"

fun F_Times2 where
  "F_Times2 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 v) (f\<^sub>2 Void)"

fun F_Times where
  "F_Times f\<^sub>1 f\<^sub>2 (Seq v\<^sub>1 v\<^sub>2) = Seq (f\<^sub>1 v\<^sub>1) (f\<^sub>2 v\<^sub>2)"
| "F_Times f1 f2 v = v"

fun simp_Plus where
  "simp_Plus (Zero, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_RIGHT f\<^sub>2)"
| "simp_Plus (r\<^sub>1, f\<^sub>1) (Zero, f\<^sub>2) = (r\<^sub>1, F_LEFT f\<^sub>1)"
| "simp_Plus (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (Plus r\<^sub>1 r\<^sub>2, F_Plus f\<^sub>1 f\<^sub>2)"

fun simp_Times where
  "simp_Times (One, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_Times1 f\<^sub>1 f\<^sub>2)"
| "simp_Times (r\<^sub>1, f\<^sub>1) (One, f\<^sub>2) = (r\<^sub>1, F_Times2 f\<^sub>1 f\<^sub>2)"
| "simp_Times (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (Times r\<^sub>1 r\<^sub>2, F_Times f\<^sub>1 f\<^sub>2)"

lemma simp_Times_simps[simp]:
  "simp_Times p1 p2 = (if (fst p1 = One) then (fst p2, F_Times1 (snd p1) (snd p2))
                    else (if (fst p2 = One) then (fst p1, F_Times2 (snd p1) (snd p2))
                    else (Times (fst p1) (fst p2), F_Times (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_Times.induct) (auto)

lemma simp_Plus_simps[simp]:
  "simp_Plus p1 p2 = (if (fst p1 = Zero) then (fst p2, F_RIGHT (snd p2))
                    else (if (fst p2 = Zero) then (fst p1, F_LEFT (snd p1))
                    else (Plus (fst p1) (fst p2), F_Plus (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_Plus.induct) (auto)

fun
  simp :: "'a rexp \<Rightarrow> 'a rexp * ('a val \<Rightarrow> 'a val)"
where
  "simp (Plus r1 r2) = simp_Plus (simp r1) (simp r2)"
| "simp (Times r1 r2) = simp_Times (simp r1) (simp r2)"
| "simp r = (r, id)"

fun
  slexer :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) option"
where
  "slexer r [] = (if nullable r then Some(mkeps r) else None)"
| "slexer r (c#s) = (let (rs, fr) = simp (deriv c r) in
                         (case (slexer rs s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c (fr v))))"

lemma slexer_better_simp:
  "slexer r (c#s) = (case (slexer (fst (simp (deriv c r))) s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c ((snd (simp (deriv c r))) v)))"
by (auto split: prod.split option.split)

lemma L_fst_simp:
  shows "lang r = lang (fst (simp r))"
by (induct r) (auto)

lemma Posix_simp:
  assumes "s \<in> (fst (simp r)) \<rightarrow> v"
  shows "s \<in> r \<rightarrow> ((snd (simp r)) v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case (Plus r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (Plus r1 r2)) \<rightarrow> v" by fact
  consider (Zero_Zero) "fst (simp r1) = Zero" "fst (simp r2) = Zero"
         | (Zero_NZero) "fst (simp r1) = Zero" "fst (simp r2) \<noteq> Zero"
         | (NZero_Zero) "fst (simp r1) \<noteq> Zero" "fst (simp r2) = Zero"
         | (NZero_NZero) "fst (simp r1) \<noteq> Zero" "fst (simp r2) \<noteq> Zero" by auto
  then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
    proof(cases)
      case (Zero_Zero)
      with as have "s \<in> Zero \<rightarrow> v" by simp
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" by (rule Posix_elims(1))
    next
      case (Zero_NZero)
      with as have "s \<in> fst (simp r2) \<rightarrow> v" by simp
      with IH2 have "s \<in> r2 \<rightarrow> snd (simp r2) v" by simp
      moreover
      from Zero_NZero have "fst (simp r1) = Zero" by simp
      then have "lang (fst (simp r1)) = {}" by simp
      then have "lang r1 = {}" using L_fst_simp by auto
      then have "s \<notin> lang r1" by simp
      ultimately have "s \<in> Plus r1 r2 \<rightarrow> Right (snd (simp r2) v)" by (rule Posix_Plus2)
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
      using Zero_NZero by simp
    next
      case (NZero_Zero)
      with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
      with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      then have "s \<in> Plus r1 r2 \<rightarrow> Left (snd (simp r1) v)" by (rule Posix_Plus1)
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_Zero by simp
    next
      case (NZero_NZero)
      with as have "s \<in> Plus (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then consider (Left) v1 where "v = Left v1" "s \<in> (fst (simp r1)) \<rightarrow> v1"
                  | (Right) v2 where "v = Right v2" "s \<in> (fst (simp r2)) \<rightarrow> v2" "s \<notin> lang (fst (simp r1))"
                  by (erule_tac Posix_elims(4))
      then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v"
      proof(cases)
        case (Left)
        then have "v = Left v1" "s \<in> r1 \<rightarrow> (snd (simp r1) v1)" using IH1 by simp_all
        then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_NZero
          by (simp_all add: Posix_Plus1)
      next
        case (Right)
        then have "v = Right v2" "s \<in> r2 \<rightarrow> (snd (simp r2) v2)" "s \<notin> lang r1" using IH2 L_fst_simp by auto
        then show "s \<in> Plus r1 r2 \<rightarrow> snd (simp (Plus r1 r2)) v" using NZero_NZero
          by (simp_all add: Posix_Plus2)
      qed
    qed
next
  case (Times r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (Times r1 r2)) \<rightarrow> v" by fact
  consider (One_One) "fst (simp r1) = One" "fst (simp r2) = One"
         | (One_NOne) "fst (simp r1) = One" "fst (simp r2) \<noteq> One"
         | (NOne_One) "fst (simp r1) \<noteq> One" "fst (simp r2) = One"
         | (NOne_NOne) "fst (simp r1) \<noteq> One" "fst (simp r2) \<noteq> One" by auto
  then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v"
  proof(cases)
      case (One_One)
      with as have b: "s \<in> One \<rightarrow> v" by simp
      from b have "s \<in> r1 \<rightarrow> snd (simp r1) v" using IH1 One_One by simp
      moreover
      from b have c: "s = []" "v = Void" using Posix_elims(2) by auto
      moreover
      have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
      then have "[] \<in> fst (simp r2) \<rightarrow> Void" using One_One by simp
      then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "([] @ []) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) Void)"
        using Posix_Times by blast
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using c One_One by simp
    next
      case (One_NOne)
      with as have b: "s \<in> fst (simp r2) \<rightarrow> v" by simp
      from b have "s \<in> r2 \<rightarrow> snd (simp r2) v" using IH2 One_NOne by simp
      moreover
      have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
      then have "[] \<in> fst (simp r1) \<rightarrow> Void" using One_NOne by simp
      then have "[] \<in> r1 \<rightarrow> snd (simp r1) Void" using IH1 by simp
      moreover
      from One_NOne(1) have "lang (fst (simp r1)) = {[]}" by simp
      then have "lang r1 = {[]}" by (simp add: L_fst_simp[symmetric])
      ultimately have "([] @ s) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) v)"
        by(rule_tac Posix_Times) auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using One_NOne by simp
    next
      case (NOne_One)
        with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
        with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      moreover
        have "[] \<in> One \<rightarrow> Void" by (simp add: Posix_One)
        then have "[] \<in> fst (simp r2) \<rightarrow> Void" using NOne_One by simp
        then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "(s @ []) \<in> Times r1 r2 \<rightarrow> Seq (snd (simp r1) v) (snd (simp r2) Void)"
        by(rule_tac Posix_Times) auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using NOne_One by simp
    next
      case (NOne_NOne)
      with as have "s \<in> Times (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then obtain s1 s2 v1 v2 where eqs: "s = s1 @ s2" "v = Seq v1 v2"
                     "s1 \<in> (fst (simp r1)) \<rightarrow> v1" "s2 \<in> (fst (simp r2)) \<rightarrow> v2"
                     "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
                     by (erule_tac Posix_elims(5)) (auto simp add: L_fst_simp[symmetric])
      then have "s1 \<in> r1 \<rightarrow> (snd (simp r1) v1)" "s2 \<in> r2 \<rightarrow> (snd (simp r2) v2)"
        using IH1 IH2 by auto
      then show "s \<in> Times r1 r2 \<rightarrow> snd (simp (Times r1 r2)) v" using eqs NOne_NOne
        by(auto intro: Posix_Times)
    qed
qed (simp_all)

lemma slexer_correctness:
  shows "slexer r s = lexer r s"
proof(induct s arbitrary: r)
  case Nil
  show "slexer r [] = lexer r []" by simp
next
  case (Cons c s r)
  have IH: "\<And>r. slexer r s = lexer r s" by fact
  show "slexer r (c # s) = lexer r (c # s)"
   proof (cases "s \<in> lang (deriv c r)")
     case True
       assume a1: "s \<in> lang (deriv c r)"
       then obtain v1 where a2: "lexer (deriv c r) s = Some v1" "s \<in> deriv c r \<rightarrow> v1"
         using lexer_correct_Some by auto
       from a1 have "s \<in> lang (fst (simp (deriv c r)))" using L_fst_simp[symmetric] by auto
       then obtain v2 where a3: "lexer (fst (simp (deriv c r))) s = Some v2" "s \<in> (fst (simp (deriv c r))) \<rightarrow> v2"
          using lexer_correct_Some by auto
       then have a4: "slexer (fst (simp (deriv c r))) s = Some v2" using IH by simp
       from a3(2) have "s \<in> deriv c r \<rightarrow> (snd (simp (deriv c r))) v2" using Posix_simp by auto
       with a2(2) have "v1 = (snd (simp (deriv c r))) v2" using Posix_determ by auto
       with a2(1) a4 show "slexer r (c # s) = lexer r (c # s)" by (auto split: prod.split)
     next
     case False
       assume b1: "s \<notin> lang (deriv c r)"
       then have "lexer (deriv c r) s = None" using lexer_correct_None by auto
       moreover
       from b1 have "s \<notin> lang (fst (simp (deriv c r)))" using L_fst_simp[symmetric] by auto
       then have "lexer (fst (simp (deriv c r))) s = None" using lexer_correct_None by auto
       then have "slexer (fst (simp (deriv c r))) s = None" using IH by simp
       ultimately show "slexer r (c # s) = lexer r (c # s)"
         by (simp del: slexer.simps add: slexer_better_simp)
   qed
qed

end


theory Sep_Generic_Wp
imports
  "../lib/Sep_Algebra_Add"
  "../lib/Frame_Infer"
  "../lib/Monad"
begin

section \<open>General VCG Setup for Separation Logic\<close>

(* TODO: Move to Library *)

locale generic_wp_defs =
  fixes wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
begin
  definition "htripleF \<alpha> F P c Q \<equiv> (\<forall>s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  definition "htriple \<alpha> P c Q \<equiv> (\<forall>F s. (P**F) (\<alpha> s) \<longrightarrow>
      wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s)"

  lemma htriple_as_F_eq: "htriple \<alpha> P c Q = (\<forall>F. htripleF \<alpha> F P c Q)"
    unfolding htriple_def htripleF_def by blast

end

locale generic_wp = generic_wp_defs wp
  for wp :: "'c \<Rightarrow> ('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" +
  assumes wp_comm_inf: "inf (wp c Q) (wp c Q') = wp c (inf Q Q')"
begin

  lemma wp_comm_conj: "wp c (\<lambda>r. Q r and Q' r) s \<longleftrightarrow> wp c Q s \<and> wp c Q' s"
    using wp_comm_inf[of c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_comm_conjI: "\<lbrakk> wp c Q s; wp c Q' s \<rbrakk> \<Longrightarrow> wp c (\<lambda>r s. Q r s \<and> Q' r s) s"
    using wp_comm_inf[of c Q Q']
    unfolding inf_fun_def inf_bool_def by metis

  lemma wp_mono: "Q\<le>Q' \<Longrightarrow> wp c Q \<le> wp c Q'"
    by (metis (mono_tags) antisym_conv le_inf_iff order_refl wp_comm_inf)

  lemma wp_monoI:
    assumes "wp c Q s"
    assumes "\<And>r x. Q r x \<Longrightarrow> Q' r x"
    shows "wp c Q' s"
    using assms wp_mono[of Q Q' c] by auto

  lemma htripleI:
    assumes "\<And>F s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_def)

  lemma htripleFI:
    assumes "\<And>s. (P**F) (\<alpha> s) \<Longrightarrow> wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    shows "htripleF \<alpha> F P c Q"
    using assms by (auto simp: htripleF_def)

  lemma htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    shows "wp c (\<lambda>r s'. (Q r ** F) (\<alpha> s')) s"
    using assms by (auto simp: htriple_def)

  lemma htriple_triv[simp, intro!]: "htriple \<alpha> sep_false c Q"
    by (auto simp: htriple_def)

  lemma frame_rule: "htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> (P ** F) c (\<lambda>r. Q r ** F)"
    unfolding htriple_def
    by (fastforce)

  lemma cons_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>s. P' s \<Longrightarrow> P s"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P' c Q'"
    unfolding htriple_def
  proof clarsimp
    fix F s
    assume "(P' \<and>* F) (\<alpha> s)"
    with assms(2) have "(P \<and>* F) (\<alpha> s)"
      using sep_conj_impl1 by blast
    with assms(1) have "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
      unfolding htriple_def by auto
    thus "wp c (\<lambda>r s'. (Q' r \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using assms(3)
      using sep_conj_impl1 by blast
  qed

  lemma cons_post_rule:
    assumes "htriple \<alpha> P c Q"
    assumes "\<And>r s. Q r s \<Longrightarrow> Q' r s"
    shows "htriple \<alpha> P c Q'"
    using cons_rule assms by blast

  lemma htriple_alt:
    "htriple \<alpha> P c Q
      = (\<forall>p s f. p##f \<and> \<alpha> s = p + f \<and> P p \<longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s)"
  proof (rule iffI, goal_cases)
    case 1
    show ?case
      using htripleD[OF 1, where F="EXACT x" for x]
        by (auto simp: sep_conj_def)

  next
    case 2
    show ?case proof (rule htripleI)
      fix F s
      assume "(P \<and>* F) (\<alpha> s)"
      then obtain p f where "p##f" "P p" "F f" "\<alpha> s = p+f"
        by (blast elim: sep_conjE)
      with 2 have "wp c (\<lambda>r s'. \<exists>p'. p' ## f \<and> \<alpha> s' = p' + f \<and> Q r p') s" by blast
      then show "wp c (\<lambda>r s'. (Q r \<and>* F) (\<alpha> s')) s"
        apply (rule wp_monoI)
        using \<open>F f\<close> by (auto intro: sep_conjI)
    qed
  qed

  lemma htripleI':
    assumes "\<And>p s f. \<lbrakk> p##f; \<alpha> s = p + f; P p\<rbrakk> \<Longrightarrow> wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    shows "htriple \<alpha> P c Q"
    using assms by (auto simp: htriple_alt)

  lemma htripleD':
    assumes "htriple \<alpha> P c Q"
    assumes "p##f" "\<alpha> s = p + f" "P p"
    shows "wp c (\<lambda>r s'. \<exists>p'. p'##f \<and> \<alpha> s'=p'+f \<and> Q r p') s"
    using assms by (auto simp: htriple_alt)

  lemma htriple_extract_pre_pure:
    "htriple \<alpha> (\<up>\<Phi>**P) c Q \<longleftrightarrow> \<Phi> \<longrightarrow> htriple \<alpha> P c Q"
    by (cases \<Phi>) (auto simp: sep_algebra_simps)

  (*
  lemma htriple_extract_pre_EXS:
    assumes "\<And>x s. \<Phi> x \<Longrightarrow> P s \<Longrightarrow> f x ## s"
    shows "htriple \<alpha> (EXS x. \<up>\<Phi> x ** EXACT (f x) ** P) c Q \<longleftrightarrow> (\<exists>x. \<Phi> x \<and> htriple \<alpha> (EXACT (f x) ** P) c Q)"
    apply rule
  *)

  thm htripleD

  thm option.simps

  lemma sv_htripleD:
    assumes "htriple \<alpha> P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htriple_def intro: wp_monoI)

  lemma sv_htripleFD:
    assumes "htripleF \<alpha> F P c Q"
    assumes "(P**F) (\<alpha> s)"
    assumes "\<And>r s. (Q r ** F) (\<alpha> s) \<Longrightarrow> Q' r s"
    shows "wp c Q' s"
    using assms
    by (force simp: htripleF_def intro: wp_monoI)

  lemma htriple_conj_pure:
    fixes \<alpha>
    assumes "htriple \<alpha> P c Q"
    assumes "htriple \<alpha> P c (\<lambda>r. \<up>\<Phi> r ** sep_true)"
    shows "htriple \<alpha> P c (\<lambda>r. \<up>\<Phi> r ** Q r)"
  proof (rule htripleI)
    fix F s
    assume "(P**F) (\<alpha> s)"
    from wp_comm_conjI[OF assms[THEN htripleD,OF this]]
    show "wp c (\<lambda>r s'. ((\<up>\<Phi> r \<and>* Q r) \<and>* F) (\<alpha> s')) s"
      apply (rule wp_monoI)
      using and_pure_true unfolding entails_def by blast

  qed

end

experiment begin
  text \<open>Precondition defined by semantics relation:
    \<^item> \<open>T c s\<close> command terminates in state \<open>s\<close>
    \<^item> \<open>R c s r s'\<close> command yields result \<open>r\<close> and new state \<open>s'\<close>
  \<close>

  definition "my_wp T (R::_ \<Rightarrow> 's\<Rightarrow>_\<Rightarrow>'s\<Rightarrow>bool) c Q s \<equiv> T c s \<and> (\<forall>r s'. R c s r s' \<longrightarrow> Q r s')"

  interpretation generic_wp "my_wp T R"
    apply unfold_locales
    unfolding my_wp_def
    by auto

end

definition STATE :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where "STATE \<alpha> P s \<equiv> P (\<alpha> s)"

lemma STATE_assn_cong[fri_extract_congs]: "P\<equiv>P' \<Longrightarrow> STATE \<alpha> P s \<equiv> STATE \<alpha> P' s" by simp

lemma STATE_extract[vcg_normalize_simps]:
  "STATE \<alpha> (\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> \<box> h"
  "STATE \<alpha> (\<up>\<Phi> ** P) h \<longleftrightarrow> \<Phi> \<and> STATE \<alpha> P h"
  "STATE \<alpha> (EXS x. Q x) h \<longleftrightarrow> (\<exists>x. STATE \<alpha> (Q x) h)"
  "STATE \<alpha> (\<lambda>_. False) h \<longleftrightarrow> False"
  "STATE \<alpha> ((\<lambda>_. False) ** P) h \<longleftrightarrow> False"
  by (auto simp: STATE_def sep_algebra_simps pred_lift_extract_simps)

definition POSTCOND :: "('s \<Rightarrow> 'a::sep_algebra) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where [vcg_tag_defs]: "POSTCOND \<alpha> \<equiv> STATE \<alpha>"

lemma POSTCONDI:
  "STATE \<alpha> A h \<Longrightarrow> POSTCOND \<alpha> A h"
  by (auto simp add: POSTCOND_def)
lemma POSTCOND_cong[vcg_normalize_congs]: "POSTCOND \<alpha> A = POSTCOND \<alpha> A" ..

lemma POSTCOND_triv_simps[vcg_normalize_simps]:
  "POSTCOND \<alpha> sep_true h"
  "\<not>POSTCOND \<alpha> sep_false h"
  unfolding POSTCOND_def STATE_def by auto

lemma start_entailsE:
  assumes "STATE \<alpha> P h"
  assumes "ENTAILS P P'"
  shows "STATE \<alpha> P' h"
  using assms unfolding STATE_def ENTAILS_def entails_def
  by auto

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms POSTCONDI},@{binding postcond_xformer},
    fn ctxt => eresolve_tac ctxt @{thms start_entailsE}
  ))
\<close>

named_theorems htriple_vcg_intros
named_theorems htriple_vcg_intro_congs
definition [vcg_tag_defs]: "DECOMP_HTRIPLE \<phi> \<equiv> \<phi>"
lemma DECOMP_HTRIPLEI: "\<phi> \<Longrightarrow> DECOMP_HTRIPLE \<phi>" unfolding vcg_tag_defs by simp

context generic_wp begin
  thm frame_rule
  thm cons_rule

  lemma htriple_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htriple \<alpha> P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleD[OF HT])

  qed

  lemma htripleF_vcg_frame_erule[vcg_frame_erules]:
    assumes S: "STATE \<alpha> P' s"
    assumes F: "PRECOND (FRAME P' P F)"
    assumes HT: "htripleF \<alpha> F P c Q"
    assumes P: "\<And>r s. STATE \<alpha> (Q r ** F) s \<Longrightarrow> PRECOND (EXTRACT (Q' r s))"
    shows "wp c Q' s"
  proof -
    from S F have "(P \<and>* F) (\<alpha> s)"
      unfolding vcg_tag_defs
      by (metis (no_types) FRAME_def entails_def STATE_def)
    with P show ?thesis
      unfolding vcg_tag_defs
      by (metis (no_types) STATE_def sv_htripleFD[OF HT])

  qed

  lemma htriple_vcgI':
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_vcgI[htriple_vcg_intros]:
    assumes "\<And>F s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htriple \<alpha> P c Q"
    apply (rule htripleI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htripleF_vcgI[htriple_vcg_intros]:
    assumes "\<And>s. STATE \<alpha> (P**F) s \<Longrightarrow> EXTRACT (wp c (\<lambda>r. POSTCOND \<alpha> (Q r ** F)) s)"
    shows "htripleF \<alpha> F P c Q"
    apply (rule htripleFI)
    using assms unfolding vcg_tag_defs STATE_def .

  lemma htriple_decompI[vcg_decomp_rules]:
    "DECOMP_HTRIPLE (htriple \<alpha> P c Q) \<Longrightarrow> htriple \<alpha> P c Q"
    "DECOMP_HTRIPLE (htripleF \<alpha> F P c Q) \<Longrightarrow> htripleF \<alpha> F P c Q"
    unfolding vcg_tag_defs by auto

  lemma htriple_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htriple \<alpha> P c Q \<equiv> htriple \<alpha> P' c Q'" by simp

  lemma htripleF_assn_cong[htriple_vcg_intro_congs]:
    "P\<equiv>P' \<Longrightarrow> Q\<equiv>Q' \<Longrightarrow>  htripleF \<alpha> F P c Q \<equiv> htripleF \<alpha> F P' c Q'" by simp

  lemma htriple_ent_pre:
    "P\<turnstile>P' \<Longrightarrow> htriple \<alpha> P' c Q \<Longrightarrow> htriple \<alpha> P c Q"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_ent_post:
    "\<lbrakk>\<And>r. Q r \<turnstile> Q' r\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q \<Longrightarrow> htriple \<alpha> P c Q'"
    unfolding entails_def
    apply (erule cons_rule) by blast+

  lemma htriple_pure_preI: "\<lbrakk>pure_part P \<Longrightarrow> htriple \<alpha> P c Q\<rbrakk> \<Longrightarrow> htriple \<alpha> P c Q"
    by (meson htriple_def pure_partI sep_conjE)

end

declaration \<open>
  K (Basic_VCG.add_xformer (@{thms DECOMP_HTRIPLEI},@{binding decomp_htriple_xformer},
    fn ctxt =>
      (full_simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps (Named_Theorems.get ctxt @{named_theorems vcg_tag_defs})
        |> fold Simplifier.add_cong (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intro_congs})
      ))
      THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems htriple_vcg_intros})
  ))
\<close>

section \<open>Setup for mres-Monad\<close>

  definition "wp c Q s \<equiv> mwp (run c s) bot bot bot Q"
  definition "wlp c Q s \<equiv> mwp (run c s) top top top Q"

  (* Definition for presentation in paper *)
  lemma "wp c Q s = (\<exists>r s'. run c s = SUCC r s' \<and> Q r s')"
    unfolding wp_def mwp_def by (auto split: mres.splits)

  lemma wlp_true[simp, intro!]:
    "wlp c (\<lambda>_ _. True) s"
    "wlp c top s"
    by (auto simp: wlp_def mwp_def split: mres.splits)

  interpretation generic_wp wp
    apply unfold_locales
    unfolding wp_def fun_eq_iff inf_fun_def inf_bool_def mwp_def
    by (auto split: mres.split)

  lemma wp_return[vcg_normalize_simps]: "wp (return x) Q s \<longleftrightarrow> Q x s"
    by (auto simp: wp_def run_simps)

  lemma wp_fail[vcg_normalize_simps]: "\<not> wp (fail x) Q s"
    by (auto simp: wp_def run_simps)

  lemma wp_fcheck[vcg_normalize_simps]: "wp (fcheck e \<Phi>) Q s \<longleftrightarrow> \<Phi> \<and> Q () s"
    by (auto simp: wp_def run_simps)

  lemma wp_bind[vcg_normalize_simps]: "wp (m\<bind>f) Q s = wp m (\<lambda>x. wp (f x) Q) s"
    by (auto simp: wp_def run_simps)

  thm vcg_normalize_simps

end


theory MkIfex
  imports BDT
begin

(* bf_vars can be rather useless, it's not a good definition *)
lemma "bf_vars (\<lambda>assmt. finite {x. assmt x}) = {}"
proof -
  have ceq: "Collect (x(y:= True)) = insert y (Collect x)" "Collect (x(y:= False)) = Set.remove y (Collect x)" for x y
    by (auto ; metis)+
  show ?thesis
    unfolding bf_vars_def Collect_empty_eq bf_restrict_def not_ex not_not ceq  remove_def
    by simp
qed

fun mk_ifex :: "'a boolfunc \<Rightarrow> 'a list \<Rightarrow> 'a ifex" where
"mk_ifex f [] = (if f undefined then Trueif else Falseif)" |
"mk_ifex f (v#vs) = IF v (mk_ifex (bf_restrict v True f) vs) (mk_ifex (bf_restrict v False f) vs)"

definition "reads_inside_set f x \<equiv> (\<forall>assmt1 assmt2. (\<forall>p. p \<in> x \<longrightarrow> assmt1 p = assmt2 p) \<longrightarrow> f assmt1 = f assmt2)"

lemma reads_inside_set_subset: "reads_inside_set f a \<Longrightarrow> a \<subseteq> b \<Longrightarrow> reads_inside_set f b"
  unfolding reads_inside_set_def by blast

lemma reads_inside_set_bf_vars: "reads_inside_set f x \<Longrightarrow> bf_vars f \<subseteq> x"
  unfolding bf_vars_def reads_inside_set_def bf_restrict_def
  apply(rule subsetI)
  apply(unfold mem_Collect_eq)
  apply(erule exE)
  apply(metis fun_upd_apply) (* meh *)
  done

lemma const_funcs_finite: "reads_inside_set bf_True {}" "reads_inside_set bf_False {}" unfolding reads_inside_set_def by blast+
lemma lit_finite: "reads_inside_set (bf_lit x) {x}" unfolding bf_lit_def reads_inside_set_def by blast
lemma combine_funcs_finite:
  assumes "reads_inside_set f1 r1" "reads_inside_set f2 r2" "reads_inside_set f3 r3"
  shows "reads_inside_set ((bf_ite f1 f2 f3) :: 'a boolfunc) (r1 \<union> r2 \<union> r3)"
proof -
  define run where "run \<equiv> \<lambda>f :: 'a boolfunc. reads_inside_set f (r1 \<union> r2 \<union> r3)"
  have "run f1" "run f2" "run f3"
    by(unfold run_def; fastforce intro: assms reads_inside_set_subset)+
  thus ?thesis unfolding bf_ite_def run_def reads_inside_set_def by metis
qed

lemma reads_inside_set_restrict: "reads_inside_set f s \<Longrightarrow> reads_inside_set (bf_restrict i v f) (Set.remove i s)"
  unfolding reads_inside_set_def bf_restrict_def by force
text\<open>The opposite direction does not hold - restricting a function on one variable may cause it to stop reading many more variables.\<close>

lemma reads_none: "reads_inside_set f {} \<Longrightarrow> f = bf_True \<or> f = bf_False"
  unfolding reads_inside_set_def by fast (* wow *)

theorem mk_ifex_correct: "reads_inside_set f (set vs) \<Longrightarrow> val_ifex (mk_ifex f vs) assmt \<longleftrightarrow> f assmt"
proof(induction vs arbitrary: f assmt)
  case Nil
  then show ?case using reads_none by auto
next
  case (Cons v vs)
  have "reads_inside_set (bf_restrict v x f) (set vs)" for x
    using reads_inside_set_restrict[OF Cons.prems] reads_inside_set_subset by fastforce
  from Cons.IH[OF this] show ?case
    unfolding mk_ifex.simps val_ifex.simps bf_restrict_def
    by (simp add: fun_upd_idem)
qed

fun clean_ifex :: "('a :: linorder) ifex \<Rightarrow> 'a ifex" where
"clean_ifex Trueif = Trueif" |
"clean_ifex Falseif = Falseif" |
"clean_ifex (IF i t e) = ifex_ite (IF i Trueif Falseif) (clean_ifex t) (clean_ifex e)"

lemma clean_ifex: "ro_ifex (clean_ifex e) \<and> val_ifex (clean_ifex e) = val_ifex e"
proof(induction e)
  case (IF i t e)
  have m: "ifex_ordered (IF i Trueif Falseif)" "ifex_minimal (IF i Trueif Falseif)" by simp_all
  have "ro_ifex (clean_ifex (IF i t e))" by
    (unfold clean_ifex.simps; intro conjI order_ifex_ite_invar minimal_ifex_ite_invar)
    (simp_all add: IF m)
  moreover have "val_ifex (clean_ifex (IF i t e)) = val_ifex (IF i t e)"
    by(subst clean_ifex.simps; subst val_ifex_ite_subst) (auto intro: val_ifex_ite_subst simp add: IF m bf_ite_def)
  ultimately show ?case ..
qed simp_all

end


theory example_sl
  imports HHL_sl
begin

typedef vars = "{''x'', ''y'', ''z''}"
  by auto

print_theorems

lemma vars_mem: "v \<in> {Abs_vars ''x'', Abs_vars ''y'', Abs_vars ''z''}"
proof -
  have "Rep_vars v \<in> {''x'', ''y'', ''z''}"
    using Rep_vars by auto
  then have "Abs_vars (Rep_vars v) \<in> {Abs_vars ''x'', Abs_vars ''y'', Abs_vars ''z''}"
    by auto
  then show ?thesis
    by (auto simp add: Rep_vars_inverse)
qed

lemma vars_UNIV: "(UNIV::vars set) = {Abs_vars ''x'', Abs_vars ''y'', Abs_vars ''z''}"
  using vars_mem by auto

instance vars :: finite
  apply standard
  by (simp add: vars_UNIV)

abbreviation "VAR \<equiv> Abs_vars"

definition test :: "vars state" where
  "test = (\<chi> x. if x = VAR ''x'' then 1 else
                if x = VAR ''y'' then 2 else 0)"

lemma vars_neq[simp]:
  "VAR ''x'' \<noteq> VAR ''y''"
  "VAR ''y'' \<noteq> VAR ''z''"
  "VAR ''x'' \<noteq> VAR ''z''"
  by (auto simp add: Abs_vars_inject)

lemma test1:"test $ VAR ''x'' = 1"
  unfolding test_def by auto

definition sumsq :: "vars state \<Rightarrow> real" where
"sumsq s = (s $ VAR ''x'')^2 + (s $ VAR ''y'')^2"

definition sumsq' :: "vars state \<Rightarrow> vars state \<Rightarrow>real" where
"sumsq' x s = 2 * s $ VAR ''x'' * x $ VAR ''x'' + 2 * s $ VAR ''y'' * x $ VAR ''y'' "

lemma sumsqderiv:"(sumsq has_derivative sumsq' x) (at x) "
  unfolding sumsq_def sumsq'_def
  apply(rule has_derivative_add [of "\<lambda>s. (s $ VAR ''x'')\<^sup>2" "\<lambda>s. 2 * s $ VAR ''x'' * x $ VAR ''x''" "at x"
                               "\<lambda>s. (s $ VAR ''y'')\<^sup>2" "\<lambda>s. 2 * s $ VAR ''y'' * x $ VAR ''y''"])
  subgoal
    using derivcoord has_derivative_power[of "\<lambda>s. (s $ VAR ''x'')" "\<lambda>s. (s $ VAR ''x'')" x UNIV 2] by auto
   subgoal
     using derivcoord has_derivative_power[of "\<lambda>s. (s $ VAR ''y'')" "\<lambda>s. (s $ VAR ''y'')" x UNIV 2] by auto
   done

lemma sumsqvalid:
  assumes "p=(\<lambda>s. (s $ VAR ''x'') = 2 \<and> (s $ VAR ''y'') = 3)"
      and "ode=ODE {VAR ''x'', VAR ''y''} (\<lambda>x. if x=VAR ''x'' then (\<lambda>s. s $ VAR ''y'') else if x=VAR ''y'' then (\<lambda>s. -s $ VAR ''x'') else undefined)"
      and "Inv=(\<lambda>s. sumsq s = 13)"
      and "b=(\<lambda>s. (s $ VAR ''x'')<3)"
    shows "\<Turnstile> {p} <ode && Inv&b> {(Inv [&][\<not>]b); (almost (Inv [&]  b) [[\<or>]] elE 0)}"
  apply(rule continTR)
    apply auto
  unfolding INV_def
  subgoal premises pre for tr d
  proof-
    have step1:"d\<ge>0"
      using pre assms(2) unfolding ODEsol_def by auto
    have step2:" ((\<lambda>t. sumsq (tr t)) has_derivative (\<lambda>t. (\<lambda>s. sumsq'(tr t) (s*\<^sub>R(ODE2Vec ode(tr t))))) x) (at x within {0..d})" if cond1:"0\<le>x\<and>x\<le>d" for x
      using chainrule[of sumsq sumsq' ode tr d x]
      using pre cond1 sumsqderiv by auto
    have step3:"\<forall>t\<in>{0 .. d}. \<forall>s. (\<lambda>t. (\<lambda>s. sumsq'(tr t) (s*\<^sub>R(ODE2Vec ode(tr t))))) t s = 0"
      unfolding sumsq'_def assms(2) ODE2Vec.simps apply simp
      using vars_neq(1) by force
    have step4:"\<forall>t\<in>{0 .. d}. (\<lambda>t. sumsq (tr t)) 0 = (\<lambda>t. sumsq (tr t)) t"
      using mvt_real_eq[of d "(\<lambda>t. sumsq (tr t))" "(\<lambda>t. (\<lambda>s. sumsq'(tr t) (s*\<^sub>R(ODE2Vec ode(tr t)))))"]
      using step1 step2 step3 by auto
    have step5:"Inv (tr 0)" using assms pre unfolding sumsq_def by auto
    have step6:"\<forall>t\<in>{0 .. d}. Inv (tr t)" using step4 step5 assms by auto
    then show ?thesis using step1 by auto
  qed
done

end


(*<*)(*:maxLineLen=68:*)
theory AndAutomat

imports automaton.dAutomaton_causal inAndData outAndData

begin
(*>*)

subsubsection\<open>And Automaton\<close>

text\<open>The And automaton consists of a transition function and a
initial state. The states and the Montiarc transition function of
the and automaton, the interpretation\<close>

datatype S_and = Single

instance S_and::countable
  by(countable_datatype)

fun dAand_tran::
"S_and \<Rightarrow> (bool option \<times> bool option) \<Rightarrow> (S_and \<times> bool option)"where
"dAand_tran S (Some bool1,Some bool2) = (S,Some (bool1 \<and> bool2))" |
"dAand_tran S (None,bool2) = (S,(Some False))" |
"dAand_tran S (bool1,None) = (S,(Some False))"

interpretation and_smap:smapGen dAand_tran    Single
                                buildAndInSBE buildAndOutSBE
                                Single
  apply(unfold_locales)
  using S_and.exhaust by blast

(*And Sem*)

abbreviation andStep::"(S_and \<Rightarrow> (inAnd\<^sup>\<Omega> \<rightarrow> outAnd\<^sup>\<Omega>))"where
"andStep \<equiv> dawStateSem and_smap.da"

definition andSpf::"(inAnd\<^sup>\<Omega> \<rightarrow> outAnd\<^sup>\<Omega>)"where
"andSpf = dawSem and_smap.da"

lemma andstep2smap:
  "andOutSBE.getterSB\<cdot>(andStep Single\<cdot>(andInSBE.setterSB\<cdot>input)) =
   smap and_smap.smapTransition\<cdot>input"
  by(simp add: and_smap.daut2smap)

theorem "andOutSBE.getterSB\<cdot>(andSpf\<cdot>(andInSBE.setterSB\<cdot>input)) =
         smap and_smap.smapTransition\<cdot>input"
  apply(simp add: andSpf_def dawSem_def)
  by (metis (mono_tags, lifting) S_and.exhaust andstep2smap)

theorem and_step_t1:
"(smap and_smap.smapTransition)\<cdot>(\<up>((Some x),(Some y)) \<bullet> s) =
 \<up>(Some (x\<and>y)) \<bullet> smap and_smap.smapTransition\<cdot>s"
  by(simp)

theorem and_step_t2:
  "(smap and_smap.smapTransition)\<cdot>(\<up>((None),(y)) \<bullet> s) =
   \<up>(Some (False)) \<bullet> smap and_smap.smapTransition\<cdot>s"
  by(simp)

theorem and_step_t3:
  "(smap and_smap.smapTransition)\<cdot>(\<up>((x),(None)) \<bullet> s) =
   \<up>(Some (False)) \<bullet> smap and_smap.smapTransition\<cdot>s"
  apply(simp)
  by (metis dAand_tran.elims option.distinct(1) snd_conv)

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Alternating List Predicates\<close>
theory Alternating
  imports Main
begin

paragraph \<open>Summary\<close>
text \<open>This theory introduces alternating list predicates @{term "alternating P Q xs"}:
for a list @{term xs} all elements with an odd index satisfy P and all elements with an
even index satisfy Q.

We introduce alternating variables @{term "alt x y zs"} that enable us to state variables
that depend on the positions within lists.

Furthermore, we introduce lemmas that split lists into lists of lists where each
for each sublist all element either belong to P or to Q.\<close>

paragraph \<open>Major Definitions\<close>
text \<open>\<^item> alternating: alternating list predicate\<close>
text \<open>\<^item> alternating': alternating list predicate with explicitly stated last element\<close>
text \<open>\<^item> alt: alternating list predicate with explicitly stated last element\<close>

paragraph \<open>Major Lemmas\<close>
text \<open>
\<^item> @{term alternating_induct}
\<^item> @{term alternating_induct'}
\<^item> @{term alternating_induct'_symmetric}
\<^item> @{term alternating_induct'_symmetric'}
\<^item> @{term alternating'_induct}
\<^item> @{term alternating'_induct'}
\<^item> @{term alternating'_induct'_symmetric}
\<^item> @{term alternating'_induct'_symmetric'}
\<^item> @{term split_segments}
\<close>

fun alternating :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "alternating _ _ [] = True" |
  "alternating P Q (x # xs) = (P x \<and> alternating Q P xs)"

fun alternating' where
  "alternating' P Q [] y = P y" |
  "alternating' P Q (x # xs) y = (P x \<and> alternating' Q P xs y)"

lemma alternating_to_alternating':
  assumes "alternating P Q xs" "xs \<noteq> []"
  shows "alternating' P Q (butlast xs) (last xs)"
  using assms
  by (induction xs arbitrary: P Q, auto)

lemma alternating'_to_alternating: "alternating' P Q xs y \<Longrightarrow> alternating P Q xs"
  by (induction xs rule: induct_list012, auto)

section \<open>Induction rules for alternating lists\<close>

lemma alternating_induct'[consumes 1, case_names emptyP emptyQ baseP baseQ stepP stepQ]:
  assumes "alternating P Q xs" "R a aa b bb []" "R b bb a aa []"
    "\<And>x. alternating P Q [x] \<Longrightarrow> P x \<Longrightarrow> R a aa b bb [x]" "\<And>x. alternating Q P [x] \<Longrightarrow>  Q x
          \<Longrightarrow> R b bb a aa [x]"
    "\<And>x y zs. alternating P Q (x # y #zs) \<Longrightarrow> P x \<Longrightarrow> Q y \<Longrightarrow> R b bb a aa (y # zs)
          \<Longrightarrow> R a aa b bb (x # y # zs)"
    "\<And>x y zs. alternating Q P (x # y #zs) \<Longrightarrow> Q x \<Longrightarrow> P y \<Longrightarrow> R a aa b bb (y # zs)
          \<Longrightarrow> R b bb a aa (x # y # zs)"
  shows "R a aa b bb xs"
  using assms
proof (induction xs arbitrary: a aa b bb P Q rule: induct_list012)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 x y zs)
  then have "P x" "Q y" by auto
  moreover have "R b bb a aa (y # zs)"
    apply (rule "3.IH"[of Q P])
    using 3 by simp_all
  ultimately show ?case
    using 3 by blast
qed

lemma alternating_induct[consumes 1, case_names empty baseP baseQ stepP stepQ]:
  assumes "alternating P Q xs" "R []"
    "\<And>x. alternating P Q [x] \<Longrightarrow> P x \<Longrightarrow> R [x]" "\<And>x. alternating Q P [x] \<Longrightarrow>  Q x \<Longrightarrow> R [x]"
    "\<And>x y zs. alternating P Q (x # y #zs) \<Longrightarrow> P x \<Longrightarrow> Q y \<Longrightarrow> R (y # zs) \<Longrightarrow> R (x # y # zs)"
    "\<And>x y zs. alternating Q P (x # y #zs) \<Longrightarrow> Q x \<Longrightarrow> P y \<Longrightarrow> R (y # zs) \<Longrightarrow> R (x # y # zs)"
  shows "R xs"
  apply (rule alternating_induct'[where a=P and aa=P and b=Q and bb=Q])
  using assms by blast+

lemma alternating_induct'_symmetric[consumes 1, case_names empty base step]:
  assumes "alternating (P a b) (P b a) xs" "\<And>a b. R a b []"
    "\<And>a b x. alternating (P a b) (P b a) [x] \<Longrightarrow> (P a b) x \<Longrightarrow> R a b [x]"
    "\<And>a b x y zs. alternating (P a b) (P b a) (x # y # zs) \<Longrightarrow> (P a b) x \<Longrightarrow> (P b a) y
          \<Longrightarrow> R b a (y # zs) \<Longrightarrow> R a b (x # y # zs)"
  shows "R a b xs"
  using assms
  by (induction xs rule: alternating_induct'[where a=a and b=b and aa=a and bb=b], blast+)

lemma alternating_induct'_symmetric'[consumes 1, case_names empty base step]:
  assumes "alternating (P a b aa bb) (P b a bb aa) xs" "\<And>a b aa bb. R a b aa bb []"
    "\<And>a b aa bb x. (P a b aa bb) x \<Longrightarrow> R a b aa bb [x]"
    "\<And>a b aa bb x y zs. (P a b aa bb) x \<Longrightarrow> (P b a bb aa) y \<Longrightarrow> R b a bb aa (y # zs)
          \<Longrightarrow> R a b aa bb (x # y # zs)"
  shows "R a b aa bb xs"
  using assms
  by (induction xs rule: alternating_induct'[where a=a and b=b and aa=aa and bb=bb], blast+)

lemma alternating'_induct'[consumes 1, case_names emptyP emptyQ baseP baseQ stepP stepQ]:
  assumes "alternating' P Q xs y" "P y \<Longrightarrow> R a aa b bb []" "Q y \<Longrightarrow> R b bb a aa []"
    "\<And>x. P x \<Longrightarrow> Q y \<Longrightarrow> R a aa b bb [x]" "\<And>x. Q x \<Longrightarrow> P y \<Longrightarrow> R b bb a aa [x]"
    "\<And>x y' zs. alternating' P Q (x # y' # zs) y \<Longrightarrow> P x \<Longrightarrow> Q y' \<Longrightarrow> R b bb a aa (y' # zs)
          \<Longrightarrow> R a aa b bb (x # y' # zs)"
    "\<And>x y' zs. alternating' Q P (x # y' # zs) y \<Longrightarrow> Q x \<Longrightarrow> P y' \<Longrightarrow> R a aa b bb (y' # zs)
          \<Longrightarrow> R b bb a aa (x # y' # zs)"
  shows "R a aa b bb xs"
  using assms
proof (induction xs arbitrary: a b aa bb P Q rule: induct_list012)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by auto
next
  case (3 x y zs)
  then have "P x" "Q y" by auto
  moreover have "R b bb a aa (y # zs)"
    apply (rule "3.IH"[of Q P])
    using 3 by simp_all
  ultimately show ?case
    using 3 by auto
qed

lemma alternating'_induct[consumes 1, case_names emptyP emptyQ baseP baseQ stepP stepQ]:
  assumes "alternating' P Q xs y" "P y \<Longrightarrow> R []" "Q y \<Longrightarrow> R []"
    "\<And>x. P x \<Longrightarrow> Q y \<Longrightarrow> R [x]" "\<And>x. Q x \<Longrightarrow> P y \<Longrightarrow> R [x]"
    "\<And>x y zs. P x \<Longrightarrow> Q y \<Longrightarrow> R (y # zs) \<Longrightarrow> R (x # y # zs)"
    "\<And>x y zs. Q x \<Longrightarrow> P y \<Longrightarrow> R (y # zs) \<Longrightarrow> R (x # y # zs)"
  shows "R xs"
  using assms
  by (rule alternating'_induct'[where a=P and b=Q and aa=P and bb=Q], blast)

lemma alternating'_induct'_symmetric[consumes 1, case_names empty base step]:
  assumes "alternating' (P a b) (P b a) xs y" "\<And>a b. R a b []"
    "\<And>a b x. (P a b) x \<Longrightarrow> (P b a) y \<Longrightarrow> R a b [x]"
    "\<And>a b x y zs. (P a b) x \<Longrightarrow> (P b a) y \<Longrightarrow> R b a (y # zs) \<Longrightarrow> R a b (x # y # zs)"
  shows "R a b xs"
  using assms
  by (induction xs rule: alternating'_induct'[where a=a and b=b and aa=a and bb=b], blast+)

lemma alternating'_induct'_symmetric'[consumes 1, case_names empty base step]:
  assumes "alternating' (P a b aa bb) (P b a bb aa) xs y" "\<And>a b aa bb. R a b aa bb []"
    "\<And>a b aa bb x. (P a b aa bb) x \<Longrightarrow> (P b a bb aa) y \<Longrightarrow> R a b aa bb [x]"
    "\<And>a b aa bb x y' zs. alternating' (P a b aa bb) (P b a bb aa) (x # y' # zs) y
          \<Longrightarrow> (P a b aa bb) x \<Longrightarrow> (P b a bb aa) y' \<Longrightarrow> R b a bb aa (y' # zs)
          \<Longrightarrow> R a b aa bb (x # y' # zs)"
  shows "R a b aa bb xs"
  using assms
  by (induction xs rule: alternating'_induct'[where a=a and b=b and aa=aa and bb=bb], blast+)

section \<open>Lemmas on alternating list predicates\<close>

lemma alternating_append1:
  assumes "alternating P Q (xs @ ys)"
  shows "alternating P Q xs"
  using assms
  by (induction xs arbitrary: P Q, auto)

lemma alternating_props:
  "alternating P Q xs \<Longrightarrow> \<forall>x \<in> set xs. P x \<or> Q x"
  by (induction xs arbitrary: P Q, auto)

lemma alternatingD:
  assumes "alternating P Q xs" "\<And>x. P x \<Longrightarrow> R x" "\<And>x. Q x \<Longrightarrow> R x"
  shows "\<forall>x \<in> set xs. R x"
  using assms by (induction xs arbitrary: P Q, auto)

fun alternating_map where
  "alternating_map f g [] = []" |
  "alternating_map f g (x # xs) = f x # (alternating_map g f xs)"

lemma alternating_map_id: "alternating_map id id xs = xs"
  by (induction xs, auto)

lemma alternating_map_props:
  assumes "alternating P Q xs" "\<forall>x \<in> set xs. P x \<longrightarrow> P' (f x)" "\<forall>x \<in> set xs. Q x \<longrightarrow> Q' (g x)"
  shows "alternating P' Q' (alternating_map f g xs)"
  using assms by (induction xs arbitrary: P Q P' Q' f g, auto)

lemma alternating_map_fwd:
  assumes "alternating P Q xs" "\<And>x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> P' x" "\<And>x. x \<in> set xs \<Longrightarrow> Q x \<Longrightarrow> Q' x"
  shows "alternating P' Q' xs"
proof -
  have "alternating P' Q' (alternating_map id id xs)"
    using alternating_map_props[of P Q xs P' id Q' id] assms by simp
  then show ?thesis
    by (subst (asm) alternating_map_id, simp)
qed

lemma alternating'_props:
  assumes "alternating' P Q xs y"
  shows "(\<forall>x \<in> set xs. P x \<or> Q x) \<and> (P y \<or> Q y)"
  using assms
  by (induction xs arbitrary: P Q, auto)

lemma alternating_consequence:
  assumes "alternating P Q xs" "\<forall>x \<in> set xs. P x \<longrightarrow> P' x" "\<forall>x \<in> set xs. Q x \<longrightarrow> Q' x"
  shows "alternating P' Q' xs"
  using assms
  by (induction xs arbitrary: P Q P' Q', auto)

section \<open>Alternating Variables\<close>

text \<open>alt enables us to state the value of alternating variables that correspond to
a certain element in an alternating list.\<close>

fun alt :: "'a \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a" where
  "alt _ y [] = y" |
  "alt x y (_ # xs) = alt y x xs"

lemma alt_in: "zs \<noteq> [] \<Longrightarrow> alt x y zs \<in> {x,y}"
  by (induction zs arbitrary: x y rule: induct_list012, auto)

lemma alt_butlast:
  assumes "xss \<noteq> []"
  shows "alt x y xss = alt y x (butlast xss)"
  using assms
  by (induction xss arbitrary: x y rule: induct_list012, auto)

lemma alt_cases:
  assumes "alt x y zs = x \<Longrightarrow> P x" "alt x y zs = y \<Longrightarrow> P y"
  shows "P (alt x y zs)"
  using assms by (induction zs arbitrary: x y rule: induct_list012, auto)

lemma alt_odd: "alternating P Q xss \<Longrightarrow> xss \<noteq> [] \<Longrightarrow> \<not> Q (last xss) \<Longrightarrow> alt x y xss = x"
  and alt_even: "alternating P Q xss \<Longrightarrow> xss \<noteq> [] \<Longrightarrow> \<not> P (last xss) \<Longrightarrow> alt x y xss = y"
  by (induction xss arbitrary: P Q x y rule: induct_list012, auto)

lemma alt_comm:
  "alt x y xss = x \<Longrightarrow> alt y x xss = y" "alt x y xss = y \<Longrightarrow> alt y x xss = x"
  apply (induction xss arbitrary: x y rule: induct_list012)
  apply (simp, simp, simp, simp)
  by (metis alt.simps(2))+

lemma alt_sum:
  fixes h1 h2 :: "'a :: comm_monoid_add"
  shows "h1 + h2 = alt h1 h2 xs + alt h2 h1 xs"
  by (induction xs, auto simp: algebra_simps)

lemma alt_alt_to_alt: "alt (alt P Q xs) (alt Q P xs) ys = alt Q P (xs @ ys)"
  by (induction xs arbitrary: P Q, auto)

lemma alt_P_P_hom: "alt (P a) (P b) xs = P (alt a b xs)"
  by (induction xs arbitrary: a b, auto)

lemma alternating_append_inner: "alternating P Q (xs @ ys) \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> (alt Q P xs) (hd ys)"
proof -
  assume "alternating P Q (xs @ ys)"
  then have "alternating P Q xs" using alternating_append1 by auto
  then show "alternating P Q (xs @ ys) \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> (alt Q P xs) (hd ys)"
  proof (induction xs rule: alternating_induct'[where a=P and b=Q and aa=P and bb=Q])
    case emptyP
    then show ?case by (simp, cases ys, simp, simp)
  next
    case emptyQ
    then show ?case by (simp, cases ys, simp, simp)
  next
    case (baseP xs)
    then show ?case by (simp, cases ys, simp, simp)
  next
    case (baseQ xs)
    then show ?case by (simp, cases ys, simp, simp)
  next
    case (stepP xs ys zss)
    then show ?case by simp
  next
    case (stepQ xs ys zss)
    then show ?case by simp
  qed
qed

lemma alt_cases':
  assumes "P x" "P y"
  shows "P (alt x y zs)"
  using assms by (induction zs arbitrary: x y rule: induct_list012, auto)

lemma alternating_append2:
  assumes "alternating P Q (xs @ ys)"
  shows "alternating (alt Q P xs) (alt P Q xs) ys"
  using assms
  by (induction xs arbitrary: P Q, auto)

lemma alternating_to_alternating2':
  assumes "alternating P Q xs" "(alt Q P xs) y"
  shows "alternating' P Q xs y"
  using assms
  by (induction xs arbitrary: P Q, auto)

section \<open>Obtain and Extend Convoluted Alternating Lists\<close>

text \<open>segment enables us to lift the single-element-only alternating list predicate
to alternating list predicates that group multiple consecutive elements of lists into
sublists where all elements in a sublist satisfy the same one of the two predicates.\<close>

abbreviation "segment N \<equiv> \<lambda>xs. set xs \<subseteq> N \<and> xs \<noteq> []"

text \<open>@{term split_segments'} is the most general variant of the split lemmas\<close>

lemma split_segments':
  assumes "set xs \<subseteq> A \<union> B" "hd xs \<in> A"
  shows "\<exists>xss. concat xss = xs \<and> (\<forall>xs \<in> set xss. xs \<noteq> []) \<and>
    alternating (segment A) (segment B) xss"
  using assms
proof (induction xs arbitrary: A B rule: induct_list012)
  case 1
  then show ?case
    using concat.simps(1) by fastforce
next
  case (2 x)
  show ?case
    apply (rule exI[where x="[[x]]"])
    using 2 by auto
next
  case (3 x y xs')
  let ?xs = "y # xs'"
  show ?case
  proof (cases "y \<in> A")
    case True
    moreover have "set ?xs \<subseteq> A \<union> B"
      using 3 by auto
    moreover have "hd ?xs \<in> A"
      using True by simp
    ultimately obtain xss where **:
      "concat xss = ?xs \<and> alternating (segment A) (segment B) xss \<and> (\<forall>xs\<in>set xss. xs \<noteq> [])"
      using "3.IH"[of A B] by auto
    then have C: "hd xss \<noteq> [] \<and> set (hd xss) \<subseteq> A \<and> alternating (segment B) (segment A) (tl xss)"
      by (cases xss, auto)
    then have A: "x # hd xss \<noteq> []" "set (x # hd xss) \<subseteq> A"
      using 3 by auto
    have B: "concat ((x # hd xss) # tl xss) = x # ?xs"
      using ** 3
      by (metis append_eq_Cons_conv concat.simps(1) concat.simps(2) hd_Cons_tl list.simps(3))
    show ?thesis
      apply (rule exI[where x="(x # hd xss) # tl xss"])
      using A B C **
      by (metis (mono_tags, lifting) alternating.simps(2) concat.simps(1)
          list.set_sel(2) list.simps(3) set_ConsD)
  next
    case False
    moreover have "set ?xs \<subseteq> A \<union> B"
      using 3 by auto
    moreover have "hd ?xs \<in> B"
      using False 3 by simp
    ultimately obtain xss where **:
      "concat xss =?xs \<and> alternating (segment B) (segment A) xss \<and> (\<forall>xs\<in>set xss. xs \<noteq> [])"
      using "3.IH"[of B A] by auto
    then have C: "hd xss \<noteq> [] \<and> set (hd xss) \<subseteq> B \<and> alternating (segment A) (segment B) (tl xss)"
      by (cases xss, auto)
    show ?thesis
      apply (rule exI[where x="[x] # xss"])
      using 3 False ** by simp
  qed
qed

lemma split_segments:
  assumes "xs \<noteq> []" "set xs \<subseteq> A \<union> B" "hd xs \<in> A"
  shows "\<exists>xss. concat xss = xs \<and> xss \<noteq> [] \<and> (\<forall>xs \<in> set xss. xs \<noteq> []) \<and>
    alternating (segment A) (segment B) xss"
  using assms split_segments'[of xs A B] by auto

lemma split_segments_extend:
  assumes some: "alternating (segment h1) (segment h2) xss" "xss \<noteq> []"
    "ys = concat xss @ zs" "zs \<noteq> []" "h1 \<inter> h2 = {}" "set zs \<subseteq> h1 \<union> h2"
    "segment h1 zs \<longleftrightarrow> \<not> segment h2 zs" "segment h1 zs2 \<longleftrightarrow> \<not> segment h2 zs2"
    "segment h1 zs \<longleftrightarrow> segment h2 zs2"
  shows "\<exists>ys' yss.
    alternating' (segment h1) (segment h2) (butlast xss @ [last xss @ ys'] @ yss) zs2 \<and>
    ys = concat (butlast xss @ [last xss @ ys'] @ yss) \<and> (\<forall>xs \<in> set xss. xs \<noteq> []) \<and>
    last xss @ ys' \<noteq> [] \<and> (\<forall>xs \<in> set yss. xs \<noteq> []) \<and> (ys' @ concat yss = zs) \<and>
    (ys' = [] \<or> yss = [])"
  using some
proof (induction xss arbitrary: ys rule: alternating_induct'_symmetric[where a=h1 and b=h2])
  case empty
  then show ?case by simp
next
  case (base h1 h2 xs)

  show ?case
  proof (cases "hd zs \<in> h1")
    case True
    then have X: "segment h1 zs" using base by (meson disjoint_iff_not_equal hd_in_set subset_eq)
    then have XX: "segment h2 zs2" using base by simp
    show ?thesis
      apply (rule exI[where x="zs"])
      apply (rule exI[where x="[]"])
      using X base by simp
  next
    case False
    then have X: "segment h2 zs" using base by (meson disjoint_iff_not_equal hd_in_set subset_eq)
    then have XX: "segment h1 zs2" using base by simp
    show ?thesis
      apply (rule exI[where x="[]"])
      apply (rule exI[where x="[zs]"])
      using X base by simp
  qed
next
  case (step h1 h2 xs ys' zss)
  obtain ys yss where *:
    "alternating' (segment h2) (segment h1) (butlast (ys' # zss) @ [last (ys' # zss) @ ys] @ yss) zs2 \<and>
    concat (ys' # zss) @ zs = concat (butlast (ys' # zss) @ [last (ys' # zss) @ ys] @ yss) \<and>
    (\<forall>xs\<in>set (ys' # zss). xs \<noteq> []) \<and> last (ys' # zss) @ ys \<noteq> [] \<and>
    (\<forall>xs\<in>set yss. xs \<noteq> []) \<and> ys @ concat yss = zs \<and> (ys = [] \<or> yss = [])"
    using step(4)[of "concat (ys' # zss) @ zs"] step by auto
  show ?case apply (rule exI[where x=ys], rule exI[where x=yss]) using step * by simp
qed

section \<open>Auxiliary Result\<close>

lemma length_ge_2_alternating:
  assumes "N1 \<inter> N2 = {}" "n1 \<in> N1" "n2 \<in> N2" "n1 \<in> set (concat nss)" "n2 \<in> set (concat nss)"
    "alternating (segment N1) (segment N2) nss"
  shows "length nss \<ge> 2"
proof (rule ccontr)
  assume "\<not> 2 \<le> length nss"
  then have "length nss = 0 \<or> length nss = 1" by linarith
  then consider (a) "length nss = 0" | (b) "length nss = 1" by blast
  then show False
  proof cases
    case a
    then show ?thesis using assms by simp
  next
    case b
    then obtain ns where *: "nss = [ns]" by (metis One_nat_def Suc_length_conv length_0_conv)
    then have **: "n1 \<in> set ns" "n2 \<in> set ns" using assms by auto

    have "set ns \<subseteq> N1 \<or> set ns \<subseteq> N2" using assms * by simp
    then consider (a) "set ns \<subseteq> N1" | (b) "set ns \<subseteq> N2" by blast
    then show False
    proof cases
      case a
      then show ?thesis using assms ** by blast
    next
      case b
      then show ?thesis using assms ** by blast
    qed
  qed
qed

end