theory regexp_SeqDistrPlus
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (q :: R) (r :: R) (s :: A list) .
     (recognise (Seq p (Plus q r)) s) =
       (recognise (Plus (Seq p q) (Seq p r)) s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Sufficient
  imports Computation
begin

datatype ('s, 'b) tdfa_s = STATE "('b list \<times> ('s \<times> nat) set)" | REJECT

context bNFT
begin

definition "K' \<equiv> K + output_speed"

definition tdfa_init :: "('s, 'b) tdfa_s" where
  "tdfa_init = (if active init [] then STATE ([], {(init, 0)}) else REJECT)"

definition tdfa_accept :: "('s, 'b) tdfa_s \<Rightarrow> bool" where
  "tdfa_accept q \<longleftrightarrow> (case q of STATE (bs, qs) \<Rightarrow> (\<exists>(q, n) \<in> qs. accept q \<and> n = length bs)
  | _ \<Rightarrow> False)"

definition tdfa_Q :: "('s, 'b) tdfa_s set" where
  "tdfa_Q = {REJECT} \<union> STATE ` ({(bs :: 'b list, qs). length bs \<le> K' \<and>
    qs \<subseteq> {(q, n). q \<in> Q \<and> n \<le> length bs}})"

definition upd_qs :: "'a \<Rightarrow> 'b list \<Rightarrow> ('s \<times> nat) set \<Rightarrow> ('s \<times> nat) set" where
  "upd_qs a bs qs = (\<Union>((\<lambda>(q, n). {(q', n'). active q' (drop n' bs) \<and> n \<le> n' \<and> n' \<le> length bs \<and>
    \<delta> q a (q', take (n' - n) (drop n bs))}) ` qs))"

definition drop_qs :: "nat \<Rightarrow> ('s \<times> nat) set \<Rightarrow> ('s \<times> nat) set" where
  "drop_qs m qs = {(q, n). (q, n + m) \<in> qs}"

definition ext_qs :: "'b \<Rightarrow> 'b list \<Rightarrow> ('s \<times> nat) set \<Rightarrow> ('s \<times> nat) set" where
  "ext_qs b bs qs = {(q, n) \<in> qs. active q (drop n (bs @ [b]))}"

fun tdfa_step :: "('s, 'b) tdfa_s \<Rightarrow> ('a Al \<times> 'b Al) \<Rightarrow>
  (('s, 'b) tdfa_s \<times> bool \<times> bool) option" where
  "tdfa_step (STATE (bs, qs)) (Symb a, Symb b) = (if length bs < K' then
    (let qs' = ext_qs b bs qs; m = Min (snd ` qs') in
    if qs' \<noteq> {} then Some (STATE (drop m (bs @ [b]), drop_qs m qs'), False, True) else None)
  else
    (let qs' = upd_qs a bs qs; m = Min (snd ` qs') in
    if qs' \<noteq> {} then Some (STATE (drop m bs, drop_qs m qs'), True, False) else None))"
| "tdfa_step (STATE (bs, qs)) (Symb a, Blank) =
  (let qs' = upd_qs a bs qs; m = Min (snd ` qs') in
    if qs' \<noteq> {} then Some (STATE (drop m bs, drop_qs m qs'), True, False) else None)"
| "tdfa_step _ _ = None"

lemma upd_qs_tdfa_Q: "STATE (bs, qs) \<in> tdfa_Q \<Longrightarrow> STATE (bs, upd_qs a bs qs) \<in> tdfa_Q"
  using \<delta>_closed
  by (force simp add: upd_qs_def tdfa_Q_def)

lemma drop_qs_tdfa_Q: "STATE (bs, qs) \<in> tdfa_Q \<Longrightarrow> qs \<noteq> {} \<Longrightarrow> m = Min (snd ` qs) \<Longrightarrow>
  STATE (drop m bs, drop_qs m qs) \<in> tdfa_Q"
  by (force simp add: drop_qs_def tdfa_Q_def)

lemma ext_qs_tdfa_Q: "STATE (bs, qs) \<in> tdfa_Q \<Longrightarrow> length bs < K' \<Longrightarrow>
  STATE (bs @ [b], ext_qs b bs qs) \<in> tdfa_Q"
  by (force simp add: ext_qs_def tdfa_Q_def)

lemma init_in_tdfa_Q: "tdfa_init \<in> tdfa_Q"
  using init_in_Q
  by (auto simp add: tdfa_init_def tdfa_Q_def)

lemma finite_tdfa_Q: "finite tdfa_Q"
proof -
  have "tdfa_Q \<subseteq> {ACCEPT, REJECT} \<union>
    STATE ` ({bs :: 'b list. length bs \<le> K'} \<times> {qs. qs \<subseteq> Q \<times> {0..K'}})"
    using tdfa_Q_def by fastforce
  moreover have "finite ({bs :: 'b list. length bs \<le> K'} \<times> {qs. qs \<subseteq> Q \<times> {0..K'}})"
    using finite_bounded_lists finite_Q by auto
  ultimately show ?thesis
    using finite_subset by auto
qed

lemma tdfa_closed: "q \<in> tdfa_Q \<Longrightarrow> tdfa_step q ab = Some (q', b1, b2) \<Longrightarrow> q' \<in> tdfa_Q"
  apply (induction q ab rule: tdfa_step.induct)
  using drop_qs_tdfa_Q[OF ext_qs_tdfa_Q] drop_qs_tdfa_Q[OF upd_qs_tdfa_Q]
  by (fastforce simp: Let_def split: if_splits)+

interpretation tdfa: oTDFA tdfa_init tdfa_step tdfa_accept tdfa_Q
  apply standard
  using tdfa_closed
        apply (auto simp add: tdfa_accept_def finite_tdfa_Q init_in_tdfa_Q)[3]
  subgoal for q a b q' b2
    by (induction q "(a, b)" rule: tdfa_step.induct) (auto split: if_splits)
  subgoal for q a b q' b1
    by (induction q "(a, b)" rule: tdfa_step.induct) (auto simp: Let_def split: if_splits)
  subgoal for q a b q'
    by (induction q "(a, b)" rule: tdfa_step.induct) (auto simp: Let_def split: if_splits)
  subgoal for q a b q'
    by (induction q "(a, b)" rule: tdfa_step.induct) (auto simp: Let_def split: if_splits)
  done

lemmas tdfa_axioms = tdfa.TDFA_axioms

lemma finite_tdfa_Q_qs: "STATE (bs, qs) \<in> tdfa_Q \<Longrightarrow> finite qs"
proof -
  assume assms: "STATE (bs, qs) \<in> tdfa_Q"
  then have "qs \<subseteq> Q \<times> {0..length bs}"
    using tdfa_Q_def by auto
  then show "finite qs"
    using finite_Q finite_subset by auto
qed

definition tdfa_inv :: "'a list \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b Al \<Rightarrow> ('s \<times> nat) set \<Rightarrow> bool" where
  "tdfa_inv as' bs' bs b qs \<longleftrightarrow> (\<forall>(q, n) \<in> qs. q \<in> Q \<and> n \<le> length bs) \<and>
    (\<forall>q n. n \<le> length bs' \<and> init \<leadsto>(as', take n bs') q \<and> active q (drop n bs' @ bs) \<longrightarrow>
      n = length bs') \<and>
    (case b of Blank \<Rightarrow> True | Symb b' \<Rightarrow>
      (\<forall>q b'' bs''. \<not>(init \<leadsto>(as', bs' @ bs @ b'' # bs'') q \<and> active q []))) \<and>
    (\<forall>q n. q \<in> Q \<and> n \<le> length bs \<longrightarrow> ((q, n) \<in> qs \<longleftrightarrow>
      init \<leadsto>(as', bs' @ take n bs) q \<and> active q (drop n bs)))"

definition tdfa_inv_aligned :: "'a list \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b Al \<Rightarrow>
  ('s \<times> nat) set \<Rightarrow> bool" where
  "tdfa_inv_aligned as' bs' bs b qs \<longleftrightarrow> (\<exists>qm. (qm, 0) \<in> qs) \<and> tdfa_inv as' bs' bs b qs"

lemma tdfa_inv_init: "active init [] \<Longrightarrow>
  tdfa_inv_aligned [] [] [] (safe_hd bs'') {(init, 0)}"
  using init_in_Q no_step
  by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def split: Al.splits list.splits)

lemma app_eq_app: "cs @ cs' = bs' @ bs @ bs'' \<Longrightarrow> length bs' \<le> length cs \<Longrightarrow>
  \<exists>ds ds'. cs = bs' @ ds \<and> bs @ bs'' = ds @ ds'"
  apply (induction bs' arbitrary: cs cs' bs bs'')
   apply (metis self_append_conv2)
  by (metis (full_types) append_eq_append_conv_if append_eq_conv_conj)

lemma app_eq_app': "bs @ b'' # bs'' = ds @ ds' \<Longrightarrow> length bs < length ds \<Longrightarrow>
  \<exists>e es. ds = bs @ e # es"
  by (metis append_eq_append_conv_if id_take_nth_drop leD)

lemma tdfa_inv_upd_qs: "tdfa_inv_aligned as' bs' bs b qs \<Longrightarrow>
  (case b of Blank \<Rightarrow> True | Symb b' \<Rightarrow> length bs \<ge> K') \<Longrightarrow>
  tdfa_inv (as' @ [a]) bs' bs b (upd_qs a bs qs)"
proof -
  assume assms: "tdfa_inv_aligned as' bs' bs b qs"
    "(case b of Blank \<Rightarrow> True | Symb b' \<Rightarrow> length bs \<ge> K')"
  have assms': "\<And>q n. n \<le> length bs' \<Longrightarrow> init \<leadsto>(as', take n bs') q \<Longrightarrow>
    active q (drop n bs' @ bs) \<Longrightarrow> n = length bs'"
    using assms(1) unfolding tdfa_inv_aligned_def tdfa_inv_def by fast
  obtain qm where qm_def: "(qm, 0) \<in> qs" "qm \<in> Q" "init \<leadsto>(as', bs') qm" "active qm bs"
    using assms(1) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
  define qs' where "qs' = upd_qs a bs qs"
  have qs_dest: "\<And>q n. (q, n) \<in> qs \<Longrightarrow>
    q \<in> Q \<and> n \<le> length bs \<and> init \<leadsto>(as', bs' @ take n bs) q \<and> active q (drop n bs)"
    using assms(1) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
  have qs'_dest: "\<And>q n. (q, n) \<in> qs' \<Longrightarrow>
    q \<in> Q \<and> n \<le> length bs \<and> init \<leadsto>(as' @ [a], bs' @ take n bs) q \<and> active q (drop n bs)"
  proof -
    fix q' n'
    assume lassm: "(q', n') \<in> qs'"
    then obtain q n where qn_def: "(q, n) \<in> qs" "active q' (drop n' bs)" "n \<le> n'"
      "n' \<le> length bs" "\<delta> q a (q', take (n' - n) (drop n bs))"
      by (auto simp add: qs'_def upd_qs_def)
    have q'_Q: "q' \<in> Q"
      using qs_dest[OF qn_def(1)] qn_def(5) \<delta>_closed by auto
    have "init \<leadsto>(as', bs' @ take n bs) q"
      using qs_dest[OF qn_def(1)] by auto
    then have "init \<leadsto>(as' @ [a], bs' @ take n' bs) q'"
      using qn_def(3,4,5) computation_snoc[OF _ qn_def(5)]
      by (metis (no_types, lifting) append_eq_appendI le_add_diff_inverse take_add)
    then show "q' \<in> Q \<and> n' \<le> length bs \<and> init \<leadsto>(as' @ [a], bs' @ take n' bs) q' \<and>
      active q' (drop n' bs)"
      using q'_Q qn_def(2,4) by auto
  qed
  have qs_intro: "\<And>q n. q \<in> Q \<Longrightarrow> n \<le> length bs \<Longrightarrow> init \<leadsto>(as', bs' @ take n bs) q \<Longrightarrow>
    active q (drop n bs) \<Longrightarrow> (q, n) \<in> qs"
    using assms(1) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
  have qs'_intro: "\<And>q n. q \<in> Q \<Longrightarrow> n \<le> length bs \<Longrightarrow> init \<leadsto>(as' @ [a], bs' @ take n bs) q \<Longrightarrow>
    active q (drop n bs) \<Longrightarrow> (q, n) \<in> qs'"
  proof -
    fix q' n'
    assume lassms: "q' \<in> Q" "n' \<le> length bs" "init \<leadsto>(as' @ [a], bs' @ take n' bs) q'"
      "active q' (drop n' bs)"
    obtain q'' cs cs' where split: "init\<leadsto>(as', cs) q''" "\<delta> q'' a (q', cs')" "q'' \<leadsto>([a], cs') q'"
      "bs' @ take n' bs = cs @ cs'"
      using computation_split[OF lassms(3)] step_dest by fastforce
    have active_q'': "active q'' (cs' @ drop n' bs)"
      using active_comp lassms(4) split(3) by auto
    have "length cs \<ge> length bs'"
      using split(1,4) assms' active_q'' lassms(2)
      apply (auto simp add: append_eq_append_conv_if split: if_splits)
      by (metis nat_le_linear)
    then obtain n where n_def: "cs = bs' @ take n bs" "n \<le> n'"
      using split(4) lassms(2)
      apply (auto simp add: append_eq_append_conv_if append_eq_conv_conj)
      by (metis append_eq_conv_conj min.cobounded1 min.commute take_take)
    have cs'_drop: "cs' @ drop n' bs = drop n bs"
      using split(4)[unfolded n_def(1)] n_def(2)
      by (metis append.assoc append_take_drop_id same_append_eq)
    have cs'_take: "cs' = take (n' - n) (drop n bs)"
      using split(4)[unfolded n_def(1)] n_def(2)
      by (metis append.assoc le_add_diff_inverse same_append_eq take_add)
    have q''_Q: "q'' \<in> Q"
      using split(1) init_in_Q comp_closed by auto
    have q''_n_qs: "(q'', n) \<in> qs"
      using qs_intro q''_Q n_def(2) lassms(2) split(1) active_q''
      by (auto simp add: n_def(1) cs'_drop)
    then show "(q', n') \<in> qs'"
      using n_def(2) lassms(2) active_q'' split(2) lassms(4)
      by (auto simp add: qs'_def upd_qs_def cs'_take)
  qed
  have "\<And>q n. n \<le> length bs' \<Longrightarrow> init \<leadsto>(as' @ [a], take n bs') q \<Longrightarrow>
    active q (drop n bs' @ bs) \<Longrightarrow> n = length bs'"
  proof -
    fix q n'
    assume lassms: "n' \<le> length bs'" "init \<leadsto>(as' @ [a], take n' bs') q"
      "active q (drop n' bs' @ bs)"
    obtain q'' cs cs' where split: "init \<leadsto>(as', cs) q''" "q'' \<leadsto>([a], cs') q"
      "take n' bs' = cs @ cs'"
      using computation_split[OF lassms(2)] by auto
    obtain n where n_def: "cs = take n bs'" "n \<le> n'"
      using split(3) lassms(1)
      by (metis append_eq_conv_conj min.cobounded1 min.commute take_take)
    have "drop n bs' = cs' @ drop n' bs'"
      using n_def lassms(1) split(3)
      by (metis append.assoc append_take_drop_id same_append_eq)
    then have "active q'' (drop n bs' @ bs)"
      using active_comp[OF lassms(3) split(2)] by auto
    then show "n' = length bs'"
      using assms'[OF _ split(1)[unfolded n_def(1)]] n_def(2) lassms(1) by auto
  qed
  moreover have "(case b of Blank \<Rightarrow> True | Symb b' \<Rightarrow>
    (\<forall>q b'' bs''. \<not>(init \<leadsto>(as' @ [a], bs' @ bs @ b'' # bs'') q \<and> active q [])))"
  proof (cases b)
    case (Symb b')
    have len_bs: "length bs \<ge> K + output_speed"
      using assms(2)[unfolded Symb] by (auto simp add: K'_def)
    have "\<And>q b'' bs''. \<not> (init\<leadsto>(as' @ [a], bs' @ bs @ b'' # bs'')q \<and> active q [])"
    proof (rule ccontr)
      fix q b'' bs''
      assume lassm: "\<not> \<not> (init\<leadsto>(as' @ [a], bs' @ bs @ b'' # bs'')q \<and> active q [])"
      then obtain q'' cs cs' where split: "init \<leadsto>(as', cs) q''" "q'' \<leadsto>([a], cs') q"
        "cs @ cs' = bs' @ bs @ b'' # bs''"
        using computation_split by fastforce
      then have "\<delta> q'' a (q, cs')"
        using step_dest by auto
      then have "length cs' \<le> output_speed"
        using init_in_Q comp_closed[OF split(1)] output_speed_step by auto
      moreover have "length cs + length cs' \<ge> length bs' + K + output_speed + 1"
        using arg_cong[OF split(3), of length] len_bs by auto
      ultimately have len_cs: "length cs \<ge> length bs' + K + 1"
        by auto
      then obtain ds ds' where split': "cs = bs' @ ds" "bs @ b'' # bs'' = ds @ ds'"
        using app_eq_app[OF split(3)] by auto
      have active_q'': "active q'' []"
        using lassm active_comp split(2) active_mono by blast
      show "False"
      proof (cases "length ds \<le> length bs")
        case True
        have "active qm ds"
          using qm_def(4) split'(2) True active_mono[of qm ds]
          by (metis app_eq_app append.left_neutral)
        then have "length ds \<le> K"
          using bounded'[OF split(1)[unfolded split'] active_q'' qm_def(3)] by auto
        then show ?thesis
          using arg_cong[OF split'(1), of length, simplified] len_cs by auto
      next
        case False
        obtain e es where es_def: "ds = bs @ e # es"
          using app_eq_app'[OF split'(2)] False by auto
        have "(\<forall>q b'' bs''. \<not>(init \<leadsto>(as', bs' @ bs @ b'' # bs'') q \<and> active q []))"
          using assms(1) Symb by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
        then show ?thesis
          using split(1)[unfolded split'(1) es_def] active_q'' by auto
      qed
    qed
    then show ?thesis
      unfolding Symb
      by auto
  qed auto
  ultimately show "tdfa_inv (as' @ [a]) bs' bs b (upd_qs a bs qs)"
    unfolding qs'_def[symmetric] tdfa_inv_def
    using qs'_dest qs'_intro by fast
qed

lemma drop_take_drop: "n \<le> m \<Longrightarrow> m \<le> length bs \<Longrightarrow> drop n bs = drop n (take m bs) @ drop m bs"
  by (metis append.assoc append_eq_conv_conj append_take_drop_id length_take min.absorb2)

lemma tdfa_inv_drop_qs: "tdfa_inv as' bs' bs b qs \<Longrightarrow> qs \<noteq> {} \<Longrightarrow> m = Min (snd ` qs) \<Longrightarrow>
  m \<le> length bs \<and> tdfa_inv_aligned as' (bs' @ take m bs) (drop m bs) b (drop_qs m qs)"
proof -
  assume assms: "tdfa_inv as' bs' bs b qs" "qs \<noteq> {}" "m = Min (snd ` qs)"
  define qs' where "qs' = drop_qs m qs"
  have qs_dest: "\<And>q n. (q, n) \<in> qs \<Longrightarrow>
    q \<in> Q \<and> n \<le> length bs \<and> init \<leadsto>(as', bs' @ take n bs) q \<and> active q (drop n bs)"
    using assms(1) by (auto simp add: tdfa_inv_def)
  have qs_sub: "qs \<subseteq> Q \<times> {0..length bs}"
    using assms(1) by (auto simp add: tdfa_inv_def)
  then have snd_qs: "finite (snd ` qs)" "snd ` qs \<noteq> {}"
    using finite_Q finite_subset assms(2) by fastforce+
  have m_leq_bs: "m \<le> length bs"
    using assms(3) qs_dest Min_in[OF snd_qs] by auto
  obtain qm where qm_def: "(qm, m) \<in> qs"
    using Min_in[OF snd_qs] by (auto simp add: assms(3))
  then have qm_zero: "(qm, 0) \<in> qs'"
    by (auto simp add: qs'_def assms(3) drop_qs_def)
  have min: "\<And>q n. n \<le> length bs' \<Longrightarrow> init \<leadsto>(as', take n bs') q \<Longrightarrow>
    active q (drop n bs' @ bs) \<Longrightarrow> n = length bs'"
    using assms(1) by (auto simp add: tdfa_inv_def)
  have qs_intro: "\<And>q n. q \<in> Q \<Longrightarrow> n \<le> length bs \<Longrightarrow> init \<leadsto>(as', bs' @ take n bs) q \<Longrightarrow>
    active q (drop n bs) \<Longrightarrow> (q, n) \<in> qs"
    using assms(1) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
  have "\<And>q n. n \<le> length (bs' @ take m bs) \<Longrightarrow> init \<leadsto>(as', take n (bs' @ take m bs)) q \<Longrightarrow>
    active q (drop n (bs' @ take m bs) @ (drop m bs)) \<Longrightarrow> n = length (bs' @ take m bs)"
  proof -
    fix q n
    assume lassms: "n \<le> length (bs' @ take m bs)" "init \<leadsto>(as', take n (bs' @ take m bs)) q"
      "active q (drop n (bs' @ take m bs) @ (drop m bs))"
    show "n = length (bs' @ take m bs)"
    proof (cases "n \<ge> length bs'")
      case True
      have q_Q: "q \<in> Q"
        using init_in_Q comp_closed lassms(2) by auto
      define n' where "n' = n - length bs'"
      have n'_le_bs: "n' \<le> length bs"
        using True lassms(1) m_leq_bs
        by (simp add: n'_def)
      have "init \<leadsto>(as', bs' @ take n' bs) q"
        using lassms(1,2) True m_leq_bs
        by (auto simp add: min_absorb1 n'_def)
      moreover have "active q (drop n' bs)"
      proof -
        have "drop n' bs = drop n (bs' @ take m bs) @ drop m bs"
        proof -
          have "n' \<le> m"
            using n'_def True m_leq_bs lassms(1)
            by auto
          then have "drop n' bs = drop n' (take m bs) @ drop m bs"
            using m_leq_bs
            by (rule drop_take_drop)
          moreover have "\<dots> = drop n (bs' @ take m bs) @ drop m bs"
            using m_leq_bs True
            by (auto simp add: n'_def)
          finally show ?thesis .
        qed
        then show ?thesis
          using lassms(3)
          by auto
      qed
      ultimately have "n' \<ge> m"
        using qs_intro[OF q_Q n'_le_bs] assms(3) Min_le[OF snd_qs(1)] by fastforce
      then show ?thesis
        using n'_def True lassms(1) by auto
    next
      case False
      then show ?thesis
        using lassms(2,3) m_leq_bs min nat_le_linear by auto
    qed
  qed
  moreover have "(case b of Blank \<Rightarrow> True | Symb b' \<Rightarrow>
    (\<forall>q b'' bs''. \<not>(init \<leadsto>(as', (bs' @ take m bs) @ drop m bs @ b'' # bs'') q \<and> active q [])))"
    using assms(1) m_leq_bs
    apply (auto simp add: tdfa_inv_def split: Al.splits)
    by (metis append_assoc append_take_drop_id)
  ultimately have "tdfa_inv as' (bs' @ take m bs) (drop m bs) b qs'"
    using assms(1) m_leq_bs
    apply (auto simp add: tdfa_inv_def qs'_def drop_qs_def)
     apply (metis add.commute take_add)
    by (metis add.commute take_add)
  then show "m \<le> length bs \<and> tdfa_inv_aligned as' (bs' @ take m bs) (drop m bs) b (drop_qs m qs)"
    unfolding qs'_def[symmetric] tdfa_inv_aligned_def
    using m_leq_bs qm_zero by auto
qed

lemma tdfa_inv_ext_qs: "tdfa_inv as' bs' bs (Symb b) qs \<Longrightarrow>
  tdfa_inv as' bs' (bs @ [b]) x (ext_qs b bs qs)"
proof -
  assume assms: "tdfa_inv as' bs' bs (Symb b) qs"
  have assms': "(\<forall>q b'' bs''. \<not>(init \<leadsto>(as', bs' @ bs @ b'' # bs'') q \<and> active q []))"
    using assms(1) by (auto simp add: tdfa_inv_def)
  define qs' where "qs' = ext_qs b bs qs"
  have qs'_sub_qs: "qs' \<subseteq> qs"
    by (auto simp add: qs'_def ext_qs_def)
  have qs_sub: "qs \<subseteq> Q \<times> {0..length bs}"
    using assms(1) by (auto simp add: tdfa_inv_def)
  then have snd_qs': "finite (snd ` qs')"
    using finite_Q qs'_sub_qs by (auto simp add: qs'_def finite_subset)
  have qs_dest: "\<And>q n. (q, n) \<in> qs \<Longrightarrow>
    q \<in> Q \<and> n \<le> length bs \<and> init \<leadsto>(as', bs' @ take n bs) q \<and> active q (drop n bs)"
    using assms(1) by (auto simp add: tdfa_inv_def ext_qs_def)
  then have qs'_dest: "\<And>q n. (q, n) \<in> qs' \<Longrightarrow>
    q \<in> Q \<and> n \<le> length (bs @ [b]) \<and> init \<leadsto>(as', bs' @ take n (bs @ [b])) q \<and>
    active q (drop n (bs @ [b]))"
    by (fastforce simp add: qs'_def ext_qs_def)
  have qs_intro: "\<And>q n. q \<in> Q \<Longrightarrow> n \<le> length bs \<Longrightarrow> init \<leadsto>(as', bs' @ take n bs) q \<Longrightarrow>
    active q (drop n bs) \<Longrightarrow> (q, n) \<in> qs"
    using assms(1) by (auto simp add: tdfa_inv_def)
  have qs'_intro: "\<And>q n. q \<in> Q \<Longrightarrow> n \<le> length (bs @ [b]) \<Longrightarrow>
    init \<leadsto>(as', bs' @ take n (bs @ [b])) q \<Longrightarrow> active q (drop n (bs @ [b])) \<Longrightarrow> (q, n) \<in> qs'"
  proof -
    fix q n
    assume lassms: "q \<in> Q" "n \<le> length (bs @ [b])" "init \<leadsto>(as', bs' @ take n (bs @ [b])) q"
      "active q (drop n (bs @ [b]))"
    have n_le: "n \<le> length bs"
      using assms' lassms(3) active_mono lassms(2,4)
      by fastforce
    then show "(q, n) \<in> qs'"
      using lassms(3,4) qs_intro[OF lassms(1) n_le] active_mono
      by (auto simp add: qs'_def ext_qs_def)
  qed
  have "\<And>q n. n \<le> length bs' \<Longrightarrow> init \<leadsto>(as', take n bs') q \<Longrightarrow> active q (drop n bs' @ bs) \<Longrightarrow>
    n = length bs'"
    using assms(1) by (auto simp add: tdfa_inv_def)
  then have "\<And>q n. n \<le> length bs' \<Longrightarrow> init \<leadsto>(as', take n bs') q \<Longrightarrow>
    active q (drop n bs' @ (bs @ [b])) \<Longrightarrow> n = length bs'"
    using active_mono by auto
  moreover have "(case x of Blank \<Rightarrow> True | Symb b' \<Rightarrow>
    (\<forall>q b'' bs''. \<not>(init \<leadsto>(as', bs' @ (bs @ [b]) @ b'' # bs'') q \<and> active q [])))"
    using assms' by (auto split: Al.splits)
  ultimately show "tdfa_inv as' bs' (bs @ [b]) x (ext_qs b bs qs)"
    unfolding tdfa_inv_def qs'_def[symmetric]
    using qs'_dest qs'_intro by fast
qed

lemma tdfa_inv_drop_upd_qs: "tdfa_inv_aligned as' bs' bs
  (if length bs \<ge> K' then ext_b else Blank) qs \<Longrightarrow>
  qs' = upd_qs a bs qs \<Longrightarrow> qs' \<noteq> {} \<Longrightarrow> m = Min (snd ` qs') \<Longrightarrow> m \<le> length bs \<and>
  tdfa_inv_aligned (as' @ [a]) (bs' @ take m bs) (drop m bs)
  (if length bs \<ge> K' then ext_b else Blank) (drop_qs m qs')"
  apply (rule tdfa_inv_drop_qs)
  using tdfa_inv_upd_qs by (auto split: if_splits Al.splits)

lemma tdfa_inv_drop_ext_qs: "tdfa_inv_aligned as' bs' bs (Symb b) qs \<Longrightarrow>
  qs' = ext_qs b bs qs \<Longrightarrow> qs' \<noteq> {} \<Longrightarrow> m = Min (snd ` qs') \<Longrightarrow> m \<le> length (bs @ [b]) \<and>
  tdfa_inv_aligned as' (bs' @ take m (bs @ [b])) (drop m (bs @ [b])) x (drop_qs m qs')"
  apply (rule tdfa_inv_drop_qs)
  using tdfa_inv_ext_qs by (auto simp add: tdfa_inv_aligned_def)

lemma \<tau>_tdfa_\<tau>: "q \<leadsto>(as, drop n bs @ bs'') q' \<Longrightarrow> accept q' \<Longrightarrow>
  init \<leadsto>(as', bs' @ take n bs) q \<Longrightarrow> q \<in> Q \<Longrightarrow> n \<le> length bs \<Longrightarrow>
  STATE (bs, qs) \<in> tdfa_Q \<Longrightarrow> tdfa_inv_aligned as' bs' bs (safe_hd bs'') qs \<Longrightarrow>
  \<exists>r. tdfa.computation (STATE (bs, qs)) ((as, []), (bs'', [])) r \<and> tdfa_accept r"
proof (induction q "(as, drop n bs @ bs'')" q' arbitrary: n as bs bs'' as' bs' qs
  rule: computation.induct)
  case (base q)
  then have "(q, n) \<in> qs"
    by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def active_def)
  then show ?case
    using base(1,2,5,6,7)
    by (auto simp: tdfa_inv_aligned_def tdfa_inv_def active_def
        intro!: exI[of _ "STATE (bs, qs)"]) (auto simp: tdfa_accept_def)
next
  case (step q a q' cs as cs' q'')
  then show ?case
  proof (induction bs'' arbitrary: n as bs as' bs' qs)
    case Nil
    define qs' where "qs' = upd_qs a bs qs"
    define m where "m = Min (snd ` qs')"
    have n_cs_le_bs: "n + length cs \<le> length bs"
      using Nil(4,8)
      by (metis Nat.le_diff_conv2 add.commute le_add1 length_append length_drop self_append_conv)
    have cs'_def: "cs' = drop (n + length cs) bs"
      using Nil(4)
      by (metis add.commute append_Nil2 append_eq_conv_conj drop_drop)
    have act_q: "active q (drop n bs)"
      using Nil(1,2,4,5)
      apply (auto simp add: active_def)
      by (metis Nil.prems(4) computation.step)
    have act_q': "active q' (drop (n + length cs) bs)"
      using Nil(2,5)
      apply (auto simp add: active_def cs'_def)
      by (metis append.right_neutral)
    define x where "x = (q, n)"
    have q_n_qs: "(q, n) \<in> qs"
      using act_q Nil(6,7,8,9,10)
      by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
    have fin_qs: "finite qs"
      using finite_tdfa_Q_qs Nil(9) by auto
    have cs_take: "cs = take (length cs) (drop n bs)"
      using Nil(1,4)
      by (metis append_Nil2 append_eq_conv_conj)
    have q'_qs': "(q', n + length cs) \<in> qs'"
      using Nil(1) cs_take Nil(4) act_q' n_cs_le_bs q_n_qs
      by (auto simp add: x_def qs'_def upd_qs_def intro: bexI[of _ "x"])
    then have qs'_nonempty: "qs' \<noteq> {}"
      by auto
    have qs_sub: "qs \<subseteq> Q \<times> {0..length bs}"
      using Nil(9) by (auto simp add: tdfa_Q_def)
    then have qs'_sub: "qs' \<subseteq> Q \<times> {0..length bs}"
      using \<delta>_closed by (auto simp add: qs'_def upd_qs_def)
    then have snd_qs': "finite (snd ` qs')" "snd ` qs' \<noteq> {}"
      using finite_Q finite_subset qs'_nonempty by fastforce+
    have m_n_cs: "m \<le> n + length cs"
      using m_def Min_le[OF snd_qs'(1)] q'_qs' by fastforce
    have inv': "m \<le> length bs \<and> tdfa_inv_aligned (as' @ [a]) (bs' @ take m bs) (drop m bs) Blank
      (drop_qs m qs')"
      using tdfa_inv_drop_upd_qs[OF _ qs'_def qs'_nonempty m_def, of as' bs'] Nil(10)
      by (cases "K' \<le> length bs") (auto simp: safe_hd_def)
    have q'_Q: "q' \<in> Q"
      using Nil(1,7) \<delta>_closed by auto
    have drop_tdfa_Q: "STATE (drop m bs, drop_qs m qs') \<in> tdfa_Q"
      using qs'_def m_def drop_qs_tdfa_Q[OF upd_qs_tdfa_Q, OF Nil(9)] qs'_nonempty
      by (auto simp add: qs'_def m_def)
    have init': "init \<leadsto>(as' @ [a], (bs' @ take m bs) @ take (n + length cs - m) (drop m bs)) q'"
      using Nil(1,6) cs_take
      by (metis append.assoc computation_snoc le_add_diff_inverse m_n_cs take_add)
    have cs'_def': "cs' = drop (n + length cs - m) (drop m bs)"
      using cs'_def m_n_cs by auto
    obtain r where r_def:
      "tdfa.computation (STATE (drop m bs, drop_qs m qs')) ((as, []), ([], [])) r" "tdfa_accept r"
      using Nil(3)[OF _ Nil(5) init' q'_Q _ drop_tdfa_Q, of "[]"] n_cs_le_bs m_n_cs
        cs'_def conjunct2[OF inv'] cs'_def'
      by (fastforce simp: safe_hd_def)
    have step: "tdfa_step (STATE (bs, qs)) (Symb a, Blank) =
      Some (STATE (drop m bs, drop_qs m qs'), True, False)"
      using qs'_def m_def qs'_nonempty Nil(9)
      by (cases "length bs \<ge> K'") (auto simp: Let_def)
    show ?case
      using r_def(1,2) step
      by (auto simp: safe_hd_def intro!: exI[of _ r])
  next
    case (Cons b bs'')
    have q_q'': "q \<leadsto>(a # as, drop n bs @ b # bs'') q''"
      using Cons(2,3,5)
      using computation.step by fastforce
    have act_q_cs: "active q cs"
      using q_q'' Cons(5,6) active_mono
      by (metis active_def)
    have act_q: "active q (drop n bs @ b # bs'')"
      using q_q'' Cons(6)
      apply (auto simp add: active_def)
      by (metis (full_types) append_Nil2)
    then have act_q_b: "active q (drop n bs @ [b])"
      using active_mono by auto
    have q_n_qs: "(q, n) \<in> qs"
      using Cons(7,8,9,11) act_q
      by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def active_def)
    have q'_Q: "q' \<in> Q"
      using Cons(2,8) \<delta>_closed by auto
    show ?case
    proof (cases "length bs \<ge> K'")
      case True
      define qs' where "qs' = upd_qs a bs qs"
      define m where "m = Min (snd ` qs')"
      have qs_sub: "qs \<subseteq> Q \<times> {0..length bs}"
        using Cons(10) by (auto simp add: tdfa_Q_def)
      have n_cs_le_bs: "n + length cs \<le> length bs"
      proof -
        have "finite qs"
          using finite_Q finite_subset qs_sub by auto
        obtain qm where "(qm, 0) \<in> qs"
          using Cons(11) by (auto simp add: tdfa_inv_aligned_def)
        then have init_qm: "init \<leadsto>(as', bs') qm" "active qm bs"
          using Cons(11) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
        have init_q: "init \<leadsto>(as', bs' @ take n bs) q" "active q (drop n bs)"
          using q_n_qs Cons(11) by (auto simp add: tdfa_inv_aligned_def tdfa_inv_def)
        have act_q_empty: "active q []"
          using init_q(2) active_mono by auto
        have act_qm: "active qm (take n bs)"
          using init_qm(2) Cons(9) active_mono
          by (metis append_take_drop_id)
        have "n \<le> K"
          using bounded'[OF init_q(1) act_q_empty init_qm(1) act_qm] Cons(9) by auto
        moreover have "length cs \<le> output_speed"
          using output_speed_step Cons(2,8) by auto
        ultimately show ?thesis
          using True unfolding K'_def by auto
      qed
      have cs'_def: "cs' = drop (n + length cs) bs @ b # bs''"
        using Cons(5) n_cs_le_bs
        by (metis Cons.prems(8) add.commute add_le_imp_le_left append_eq_append_conv_if drop_drop
            le_add_diff_inverse length_drop)
      have act_q': "active q' (drop (n + length cs) bs)"
        using act_q Cons(2) n_cs_le_bs
        apply (auto simp add: active_def)
        by (metis cs'_def step.hyps(2) step.prems(1))
      define x where "x = (q, n)"
      have cs_take: "cs = take (length cs) (drop n bs)"
        using n_cs_le_bs Cons(5) append_eq_conv_conj cs'_def
        by auto
      have q'_qs': "(q', n + length cs) \<in> qs'"
        using cs_take act_q' n_cs_le_bs q_n_qs upd_qs_def Cons(2)
        by (auto simp add: x_def qs'_def upd_qs_def intro!: bexI[of _ "x"])
      then have qs'_nonempty: "qs' \<noteq> {}"
        by auto
      have qs'_sub: "qs' \<subseteq> Q \<times> {0..length bs}"
        using qs_sub \<delta>_closed by (auto simp add: qs'_def upd_qs_def)
      then have snd_qs': "finite (snd ` qs')" "snd ` qs' \<noteq> {}"
        using finite_Q finite_subset qs'_nonempty by fastforce+
      have m_n_cs: "m \<le> n + length cs"
        using m_def Min_le[OF snd_qs'(1)] q'_qs' by fastforce
      have inv': "m \<le> length bs \<and> tdfa_inv_aligned (as' @ [a]) (bs' @ take m bs) (drop m bs)
        (Symb b) (drop_qs m qs')"
        using tdfa_inv_drop_upd_qs[OF _ qs'_def qs'_nonempty m_def, of as' bs'] Cons(11) True
        by (auto simp: safe_hd_def)
      have q'_Q: "q' \<in> Q"
        using Cons(2,8) \<delta>_closed by auto
      have drop_tdfa_Q: "STATE (drop m bs, drop_qs m qs') \<in> tdfa_Q"
        using qs'_def m_def drop_qs_tdfa_Q[OF upd_qs_tdfa_Q] Cons(10) qs'_nonempty
        by (auto simp add: qs'_def m_def)
      have init': "init \<leadsto>(as' @ [a], (bs' @ take m bs) @ take (n + length cs - m) (drop m bs)) q'"
        using Cons(2,7) cs_take m_n_cs computation_snoc
        by (metis append.assoc le_add_diff_inverse take_add)
      have cs'_def': "cs' = drop (n + length cs - m) (drop m bs) @ b # bs''"
        using cs'_def m_n_cs by auto
      obtain r where r_def:
        "tdfa.computation (STATE (drop m bs, drop_qs m qs')) ((as, []), (b # bs'', [])) r"
        "tdfa_accept r"
        using Cons(4)[OF _ _ init' q'_Q _ drop_tdfa_Q, of "b # bs''"] Cons(6) n_cs_le_bs m_n_cs
          cs'_def conjunct2[OF inv'] cs'_def'
        by (auto simp: safe_hd_def) fastforce
      have step: "tdfa_step (STATE (bs, qs)) (Symb a, Symb b) =
        Some (STATE (drop m bs, drop_qs m qs'), True, False)"
        using Cons(10) qs'_def m_def qs'_nonempty True
        by (auto simp: Let_def)
      show ?thesis
        using r_def(1,2) step
        by (auto simp: safe_hd_def intro!: exI[of _ r])
    next
      case False
      define qs' where "qs' = ext_qs b bs qs"
      define m where "m = Min (snd ` qs')"
      have qs'_nonempty: "qs' \<noteq> {}"
        using q_n_qs Cons(9) act_q_b
        by (fastforce simp add: qs'_def ext_qs_def)
      have step: "tdfa_step (STATE (bs, qs)) (Symb a, Symb b) =
        Some (STATE (drop m (bs @ [b]), drop_qs m qs'), False, True)"
        using Cons(10) qs'_def m_def qs'_nonempty False
        by (auto simp: Let_def)
      have inv': "m \<le> length (bs @ [b]) \<and> tdfa_inv_aligned as' (bs' @ take m (bs @ [b]))
        (drop m (bs @ [b])) (safe_hd bs'') (drop_qs m qs')"
        using Cons(11) tdfa_inv_drop_ext_qs[OF _ qs'_def qs'_nonempty m_def]
        by (auto simp: safe_hd_def)
      have drop_tdfa_Q: "STATE (drop m (bs @ [b]), drop_qs m (ext_qs b bs qs)) \<in> tdfa_Q"
        using qs'_def m_def drop_qs_tdfa_Q[OF ext_qs_tdfa_Q, OF Cons(10)] False qs'_nonempty
        by (auto simp add: qs'_def m_def)
      have q_n_qs': "(q, n) \<in> qs'"
        using q_n_qs Cons(9) act_q_b
        by (auto simp add: qs'_def ext_qs_def)
      have qs_sub: "qs \<subseteq> Q \<times> {0..length bs}"
        using Cons by (auto simp add: tdfa_Q_def)
      then have qs'_sub: "qs' \<subseteq> Q \<times> {0..length bs}"
        by (auto simp add: qs'_def ext_qs_def)
      then have snd_qs': "finite (snd ` qs')" "snd ` qs' \<noteq> {}"
        using finite_Q finite_subset qs'_nonempty by fastforce+
      have m_n: "m \<le> n"
        using q_n_qs' m_def Min_le[OF snd_qs'(1)] by fastforce
      have cs_app_cs': "cs @ cs' = drop (n - m) (drop m (bs @ [b])) @ bs''"
        using m_n conjunct1[OF inv'] Cons by auto
      have "n - m \<le> length (drop m (bs @ [b]))"
        using conjunct1[OF inv'] Cons by auto
      moreover have "init \<leadsto>(as', (bs' @ take m (bs @ [b])) @ take (n - m) (drop m (bs @ [b]))) q"
        using Cons(7) m_n conjunct1[OF inv']
        by (metis Cons.prems(8) append_Nil2 append_eq_append_conv2 append_eq_conv_conj
            diff_is_0_eq' le_add_diff_inverse list.size(3) take_add take_append)
      ultimately obtain r where r_def: "tdfa.computation (STATE (drop m (bs @ [b]), drop_qs m qs'))
        ((a # as, []), (bs'', [])) r" "tdfa_accept r"
        using Cons(1)[OF Cons(2) Cons(3) _ cs_app_cs' Cons(6) _ Cons(8) _
          drop_tdfa_Q[folded qs'_def] conjunct2[OF inv']] Cons(4) m_n conjunct1[OF inv']
        by fast
      show ?thesis
        using r_def(1,2) step
        by (auto simp: safe_hd_def intro!: exI[of _ r])
    qed
  qed
qed

lemma tdfa_\<tau>_\<tau>: "tdfa.computation (STATE (bs, qs)) ((as, []), (bs'', [])) r \<Longrightarrow>
  tdfa_accept r \<Longrightarrow> tdfa_inv_aligned as' bs' bs (safe_hd bs'') qs \<Longrightarrow>
  (as' @ as, bs' @ bs @ bs'') \<in> \<tau>"
proof (induction "STATE (bs, qs)" "((as, [] :: 'a list), (bs'', [] :: 'b list))" r
    arbitrary: bs qs as bs'' as' bs' rule: tdfa.computation.induct)
  case base
  obtain q n where qn_def: "(q, n) \<in> qs" "accept q" "n = length bs"
    using base(1)
    by (auto simp: tdfa_accept_def)
  then show ?case
    using base(2)
    by (fastforce simp add: tdfa_inv_aligned_def tdfa_inv_def \<tau>_def)
next
  case (step_TF a bs'' q' as q'')
  define qs' where "qs' = upd_qs a bs qs"
  define m where "m = Min (snd ` qs')"
  have props: "qs' \<noteq> {}" "q' = STATE (drop m bs, drop_qs m qs')"
    using qs'_def m_def step_TF(1)
    by (auto simp: safe_hd_def Let_def split: list.splits if_splits)
  have "\<not>K' \<le> length bs \<Longrightarrow> bs'' = []"
    using step_TF(1)
    by (cases bs'') (auto simp: safe_hd_def Let_def split: if_splits)
  then have "m \<le> length bs \<and>
    tdfa_inv_aligned (as' @ [a]) (bs' @ take m bs) (drop m bs) (safe_hd bs'') (drop_qs m qs')"
    using tdfa_inv_drop_upd_qs[OF _ qs'_def props(1) m_def, of as' bs'] step_TF(5)
    by (cases "K' \<le> length bs") (auto simp: safe_hd_Nil split: list.splits)
  then show ?case
    using step_TF(3)[OF props(2) step_TF(4), of "as' @ [a]" "bs' @ take m bs"]
    by auto (metis append.assoc append_take_drop_id)
next
  case (step_FT as b q' bs'' q'' bs)
  define qs' where "qs' = ext_qs b bs qs"
  define m where "m = Min (snd ` qs')"
  have props: "length bs < K'" "qs' \<noteq> {}" "q' = STATE (drop m (bs @ [b]), drop_qs m qs')"
    using qs'_def m_def step_FT(1)
    by (auto simp: safe_hd_def Let_def split: list.splits if_splits)
  have inv: "m \<le> length (bs @ [b])" "tdfa_inv_aligned as' (bs' @ take m (bs @ [b]))
    (drop m (bs @ [b])) (safe_hd bs'') (drop_qs m qs')"
    using tdfa_inv_drop_ext_qs[OF _ qs'_def props(2) m_def] step_FT(5)
    by (auto simp: safe_hd_def)
  show ?case
    using step_FT(3)[OF props(3) step_FT(4) inv(2)] inv(1)
    by (metis append.assoc append_Cons append_Nil append_take_drop_id)
qed (auto simp: Let_def split: if_splits)

lemma comp_REJECT_ACCEPT:
  "tdfa.computation q ((as, as'), bs, bs') q' \<Longrightarrow> q = REJECT \<Longrightarrow> tdfa_accept q' \<Longrightarrow> False"
  by (drule tdfa.comp_unreachable) (auto simp: tdfa_accept_def)

lemma not_active_init: "\<not>active init [] \<Longrightarrow> tdfa.\<tau> = \<tau>"
  using comp_REJECT_ACCEPT
  unfolding tdfa.\<tau>_def
  by (force simp add: active_def tdfa_init_def \<tau>_def)

lemma tdfa_\<tau>_sub_\<tau>: "tdfa.\<tau> \<subseteq> \<tau>"
  using tdfa_\<tau>_\<tau>[OF _ _ tdfa_inv_init] not_active_init
  unfolding tdfa.\<tau>_def
  unfolding tdfa_init_def tdfa_accept_def
  by auto

lemma \<tau>_sub_tdfa_\<tau>: "\<tau> \<subseteq> tdfa.\<tau>"
  using init_in_tdfa_Q
  unfolding \<tau>_def tdfa.\<tau>_def
  unfolding tdfa_init_def
  using \<tau>_tdfa_\<tau>[of init _ 0 "[]" _ _ "[]" "[]"] init_in_Q tdfa_inv_init
  by (fastforce simp: active_def split: if_splits)

(* Theorem 9 *)
lemma tdfa_correct: "\<tau> = tdfa.\<tau>"
  using tdfa_\<tau>_sub_\<tau> \<tau>_sub_tdfa_\<tau> by auto

end

end


theory Proofs_1
  imports Requirements ExtraInv VCTheoryLemmas
begin

definition inv1 where "inv1 s \<equiv> R1 s \<and> extraInv s"

theorem proof_1_1: "VC1 inv1 s0"
  apply(simp only: VC1_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_2: "VC2 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC2_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_3: "VC3 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC3_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_4: "VC4 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC4_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_5: "VC5 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC5_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_6: "VC6 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC6_def inv1_def R1_def extraInv_def)
  by auto

theorem proof_1_7: "VC7 inv11 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC7_def)
  by auto

theorem proof_1_8: "VC8 R1 env s0 userAtTop_value userAtBotton_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC8_def inv1_def R1_def extraInv_def)
  by auto

end


theory SINVAR_BLPtrusted
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Basic Bell LaPadula with trusted entities *}

type_synonym privacy_level = nat

record node_config =
    privacy_level::privacy_level
    trusted::bool

definition default_node_properties :: "node_config"
  where  "default_node_properties \<equiv> \<lparr> privacy_level = 0, trusted = False \<rparr>"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow>  bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (if trusted (nP e2) then True else privacy_level (nP e1) \<le> privacy_level (nP e2) ))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto split: split_split split_split_asm)[6]
   apply(simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops split: split_split split_split_asm)[1]
   apply (metis prod.inject)
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma "a \<noteq> b \<Longrightarrow> ((\<exists> x. y x)) \<Longrightarrow> ((\<forall> x. \<not> y x) \<Longrightarrow> a = b )" by simp

lemma BLP_def_unique: "otherbot \<noteq> default_node_properties \<Longrightarrow>
    \<exists>G p i f. valid_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
         i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp add:default_node_properties_def)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split)
  apply(rule_tac x="\<lparr> nodes={vertex_1, vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := \<lparr>privacy_level = 1, trusted = False \<rparr>, vertex_2 := \<lparr>privacy_level = 0, trusted = False \<rparr>)" in exI, simp add:default_node_properties_def)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(case_tac otherbot)
  apply simp
  apply(erule disjE)
   apply force
  apply fast
  done

subsubsection {*ENF*}
  definition BLP_P where "BLP_P \<equiv> (\<lambda>n1 n2.(if trusted n2 then True else privacy_level n1 \<le> privacy_level n2 ))"
  lemma zero_default_candidate: "\<forall>nP e1 e2. \<not> BLP_P (nP e1) (nP e2) \<longrightarrow> \<not> BLP_P (nP e1) default_node_properties"
    apply(rule allI)+
    apply(case_tac "nP e1")
    apply(case_tac "nP e2")
    apply(rename_tac privacy2 trusted2 more2)
    apply (simp add: BLP_P_def default_node_properties_def)
    done
  lemma privacylevel_refl: "BLP_P e e"
    by(simp_all add: BLP_P_def)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    unfolding BLP_P_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> BLP_P (nP e1) (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation BLPtrusted: SecurityInvariant_IFS
  where default_node_properties = default_node_properties
  and sinvar = sinvar
  and verify_globals = verify_globals
  where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply unfold_locales
      apply(rule ballI)
      apply (rule_tac f=f in SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl zero_default_candidate])
       apply(simp)
      apply(simp)
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPtrusted: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_type (open) node_config
hide_const (open) sinvar_mono

hide_const (open) BLP_P
hide_fact BLP_def_unique zero_default_candidate  privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


theory Inconsistency_S5U imports QML_S5U
begin
 consts P :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (*P: Positive*)
 axiomatization where
  A1a: "\<lfloor>\<^bold>\<forall>\<Phi>. P(\<^sup>\<not>\<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>P(\<Phi>)\<rfloor>" and
  A1b: "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<not>P(\<Phi>) \<^bold>\<rightarrow> P(\<^sup>\<not>\<Phi>)\<rfloor>" and
  A2:  "\<lfloor>\<^bold>\<forall>\<Phi> \<Psi>. P(\<Phi>) \<^bold>\<and>
         \<^bold>\<box>(\<^bold>\<forall>x. \<Phi>(x) \<^bold>\<rightarrow> \<Psi>(x)) \<^bold>\<rightarrow> P(\<Psi>)\<rfloor>"
 definition G where
  "G(x) = (\<^bold>\<forall>\<Phi>. P(\<Phi>) \<^bold>\<rightarrow> \<Phi>(x))"
 axiomatization where
  A3:  "\<lfloor>P(G)\<rfloor>" and
  A4:  "\<lfloor>\<^bold>\<forall>\<Phi>. P(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<box>(P(\<Phi>))\<rfloor>"
 definition ess (infixl "ess" 85) where
  "\<Phi> ess x =
    (\<^bold>\<forall>\<Psi>. \<Psi>(x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>y. \<Phi>(y) \<^bold>\<rightarrow> \<Psi>(y)))"
 definition NE where
  "NE(x) = (\<^bold>\<forall>\<Phi>. \<Phi> ess x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists> \<Phi>))"
 axiomatization where
  A5:  "\<lfloor>P(NE)\<rfloor>"

 lemma False     (* Inconsistency *)
  (* sledgehammer [remote_leo2, verbose] *)
  sledgehammer
  by (metis (full_types) A1a A2 A3 A4
      A5 G_def NE_def ess_def)
end


theory QML_S5U imports Main
begin
 typedecl i (* "type for possible worlds" *)
 typedecl \<mu> (* "type for individuals" *)
 type_synonym \<sigma> = "(i\<Rightarrow>bool)"

 abbreviation mnot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mnotpred :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>(\<mu>\<Rightarrow>\<sigma>)" ("\<^sup>\<not>_"[52]53)
  where "\<^sup>\<not>\<Phi> \<equiv> \<lambda>x.\<lambda>w. \<not>\<Phi>(x)(w)"
 abbreviation mand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51)
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation mor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50)
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation mimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49)
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation mequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<equiv>"48)
  where "\<phi>\<^bold>\<equiv>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"
 abbreviation mall :: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>")
  where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. \<Phi>(x)(w)"
 abbreviation mallB:: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<forall>"[8]9)
  where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation mexi :: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>")
  where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. \<Phi>(x)(w)"
 abbreviation mexiB:: "('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<exists>"[8]9)
  where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"
 abbreviation mbox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<box>")
  where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v. \<phi>(v)"
 abbreviation mdia :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<diamond>")
  where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v. \<phi>(v)"

 abbreviation valid :: "\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]8)
   where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"

lemma "\<lfloor>\<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<phi>\<rfloor>" sledgehammer
  by simp
lemma "\<lfloor>\<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<phi>\<rfloor>" sledgehammer
  by simp
lemma "\<lfloor>\<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<box>\<phi>)\<rfloor>" sledgehammer
  by simp

end


theory AssemblyCode
  imports "../00Utils/Iteration" "../00Utils/Environment"
begin

datatype register = Hp | Env | Vals | Stk

datatype pseudoreg = Reg register | PC nat | Con nat | Acc pseudoreg

datatype assm =
  AMov pseudoreg
  | AGet pseudoreg pseudoreg
  | APut register pseudoreg
  | ASub pseudoreg nat
  | AAdd pseudoreg nat
  | AJmp

datatype assm_state =
  AS "register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat" "register \<Rightarrow> nat" nat pseudoreg nat

fun mem_upd :: "(register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat) \<Rightarrow> register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat \<Rightarrow>
    register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat" where
  "mem_upd mem m mp k m' x = (if m = m' \<and> mp = x then k else mem m' x)"

fun assm_step :: "(register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat) \<Rightarrow> (register \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> pseudoreg \<Rightarrow>
    nat \<Rightarrow> assm \<rightharpoonup> assm_state" where
  "assm_step mem ps a act pc (AMov (Reg r)) = Some (AS mem ps (ps r) (Reg r) pc)"
| "assm_step mem ps a act pc (AMov (PC _)) = Some (AS mem ps pc (PC 0) pc)"
| "assm_step mem ps a act pc (AMov (Con k)) = Some (AS mem ps k (Con 0) pc)"
| "assm_step mem ps a act pc (AMov (Acc _)) = None"
| "assm_step mem ps a act pc (AGet (Reg r) t) = (case mem r (ps r) of
      (t', b) \<Rightarrow> if t = t' then Some (AS mem ps b t pc) else None)"
| "assm_step mem ps a act pc (AGet (PC _) t) = None"
| "assm_step mem ps a act pc (AGet (Con k) t) = None"
| "assm_step mem ps a act pc (AGet (Acc (Reg r)) t) = (case mem r a of
      (t', b) \<Rightarrow> if act = Reg r \<and> t = t' then Some (AS mem ps b t pc) else None)"
| "assm_step mem ps a act pc (AGet (Acc (PC _)) t) = None"
| "assm_step mem ps a act pc (AGet (Acc (Con k)) t) = None"
| "assm_step mem ps a act pc (AGet (Acc (Acc r)) t) = None"
| "assm_step mem ps a act pc (APut r (Reg r')) =
    Some (AS (mem_upd mem r (ps r) (Reg r', ps r')) ps a act pc)"
| "assm_step mem ps a act pc (APut r (PC k)) =
    Some (AS (mem_upd mem r (ps r) (PC 0, k)) ps a act pc)"
| "assm_step mem ps a act pc (APut r (Con k)) =
    Some (AS (mem_upd mem r (ps r) (Con 0, k)) ps a act pc)"
| "assm_step mem ps a act pc (APut r (Acc _)) =
    Some (AS (mem_upd mem r (ps r) (act, a)) ps a act pc)"
| "assm_step mem ps a act pc (ASub (Reg r) k) =
    (if ps r \<ge> k then Some (AS mem (ps(r := ps r - k)) a act pc) else None)"
| "assm_step mem ps a act pc (ASub (PC _) k) = None"
| "assm_step mem ps a act pc (ASub (Con m) k) = None"
| "assm_step mem ps a act pc (ASub (Acc t) k) =
    (if t = act \<and> a \<ge> k then Some (AS mem ps (a - k) act pc) else None)"
| "assm_step mem ps a act pc (AAdd (Reg r) k) = Some (AS mem (ps(r := ps r + k)) a act pc)"
| "assm_step mem ps a act pc (AAdd (PC _) k) = None"
| "assm_step mem ps a act pc (AAdd (Con m) k) = None"
| "assm_step mem ps a act pc (AAdd (Acc t) k) =
    (if t = act then Some (AS mem ps (a + k) act pc) else None)"
| "assm_step mem ps a act pc AJmp =
    (if act = PC 0 then Some (AS mem ps 0 (Con 0) a) else None)"

fun alg_evala :: "assm list \<Rightarrow> assm_state \<rightharpoonup> assm_state" (infix "\<tturnstile>\<^sub>a" 50) where
  "cd \<tturnstile>\<^sub>a AS mem ps a act pc = (case pc of
      0 \<Rightarrow> None
    | Suc pc \<Rightarrow> Option.bind (lookup cd pc) (assm_step mem ps a act pc))"

primrec iter_evala :: "assm list \<Rightarrow> nat \<Rightarrow> assm_state \<rightharpoonup> assm_state" where
  "iter_evala cd 0 \<Sigma> = Some \<Sigma>"
| "iter_evala cd (Suc x) \<Sigma> = Option.bind (cd \<tturnstile>\<^sub>a \<Sigma>) (iter_evala cd x)"

inductive evala :: "assm list \<Rightarrow> assm_state \<Rightarrow> assm_state \<Rightarrow> bool" (infix "\<tturnstile> _ \<leadsto>\<^sub>a" 50) where
  eva_movr [simp]: "lookup cd pc = Some (AMov (Reg r)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps (ps r) (Reg r) pc"
| eva_movp [simp]: "lookup cd pc = Some (AMov (PC _)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps pc (PC 0) pc"
| eva_movk [simp]: "lookup cd pc = Some (AMov (Con k)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps k (Con 0) pc"
| eva_get [simp]: "lookup cd pc = Some (AGet (Reg r) t) \<Longrightarrow> mem r (ps r) = (t, b) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps b t pc"
| eva_geta [simp]: "lookup cd pc = Some (AGet (Acc (Reg m)) t) \<Longrightarrow> mem m a = (t, b) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a (Reg m) (Suc pc) \<leadsto>\<^sub>a AS mem ps b t pc"
| eva_putr [simp]: "lookup cd pc = Some (APut r (Reg r')) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS (mem_upd mem r (ps r) (Reg r', ps r')) ps a act pc"
| eva_putk [simp]: "lookup cd pc = Some (APut r (Con k)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS (mem_upd mem r (ps r) (Con 0, k)) ps a act pc"
| eva_putp [simp]: "lookup cd pc = Some (APut r (PC k)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS (mem_upd mem r (ps r) (PC 0, k)) ps a act pc"
| eva_puta [simp]: "lookup cd pc = Some (APut r (Acc _)) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS (mem_upd mem r (ps r) (act, a)) ps a act pc"
| eva_suba [simp]: "lookup cd pc = Some (ASub (Acc act) k) \<Longrightarrow> a \<ge> k \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps (a - k) act pc"
| eva_sub [simp]: "lookup cd pc = Some (ASub (Reg r) k) \<Longrightarrow> ps r \<ge> k \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem (ps(r := ps r - k)) a act pc"
| eva_add [simp]: "lookup cd pc = Some (AAdd (Reg r) k) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem (ps(r := ps r + k)) a act pc"
| eva_adda [simp]: "lookup cd pc = Some (AAdd (Acc act) k) \<Longrightarrow>
    cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a AS mem ps (a + k) act pc"
| eva_jmp [simp]: "lookup cd pc = Some AJmp \<Longrightarrow>
    cd \<tturnstile> AS mem ps a (PC 0) (Suc pc) \<leadsto>\<^sub>a AS mem ps 0 (Con 0) a"

lemma [simp]: "mem_upd (case_register h e vs sh) Env x y = case_register h (e(x := y)) vs sh"
  by (rule+) (simp_all split: register.splits)

lemma [simp]: "mem_upd (case_register h e vs sh) Vals x y = case_register h e (vs(x := y)) sh"
  by (rule+) (simp_all split: register.splits)

lemma [simp]: "mem_upd (case_register h e vs sh) Stk x y = case_register h e vs (sh(x := y))"
  by (rule+) (simp_all split: register.splits)

lemma [simp]: "(case_register hp ep vp sp)(Hp := x) = case_register x ep vp sp"
  by rule (simp split: register.splits)

lemma [simp]: "(case_register hp ep vp sp)(Env := x) = case_register hp x vp sp"
  by rule (simp split: register.splits)

lemma [simp]: "(case_register hp ep vp sp)(Vals := x) = case_register hp ep x sp"
  by rule (simp split: register.splits)

lemma [simp]: "(case_register hp ep vp sp)(Stk := x) = case_register hp ep vp x"
  by rule (simp split: register.splits)

lemma iter_evala_combine [simp]: "iter_evala cd n \<Sigma> = Some \<Sigma>' \<Longrightarrow>
  iter_evala cd m \<Sigma>' = Some \<Sigma>'' \<Longrightarrow> iter_evala cd (n + m) \<Sigma> = Some \<Sigma>''"
proof (induction n arbitrary: \<Sigma>)
  case (Suc n)
  then show ?case by (cases "cd \<tturnstile>\<^sub>a \<Sigma>") simp_all
qed simp_all

lemma assm_step_equiv: "(Option.bind (lookup cd pc) (assm_step mem ps a act pc) = Some \<Sigma>) \<Longrightarrow>
  (cd \<tturnstile> AS mem ps a act (Suc pc) \<leadsto>\<^sub>a \<Sigma>)"
proof (cases "lookup cd pc")
  case (Some op)
  moreover assume "Option.bind (lookup cd pc) (assm_step mem ps a act pc) = Some \<Sigma>"
  ultimately show ?thesis
    by (induction mem ps a act pc op rule: assm_step.induct) (auto split: if_splits prod.splits)
qed simp_all

lemma alg_evala_equiv: "cd \<tturnstile>\<^sub>a \<Sigma> = Some \<Sigma>' = (cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>a \<Sigma>')"
proof
  show "cd \<tturnstile>\<^sub>a \<Sigma> = Some \<Sigma>' \<Longrightarrow> cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>a \<Sigma>'"
    by (induction \<Sigma>) (auto simp add: assm_step_equiv split: nat.splits)
  show "cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>a \<Sigma>' \<Longrightarrow> cd \<tturnstile>\<^sub>a \<Sigma> = Some \<Sigma>'"
    by (induction cd \<Sigma> \<Sigma>' rule: evala.induct) simp_all
qed

lemma iter_evala_equiv: "(\<exists>n. iter_evala cd n \<Sigma> = Some \<Sigma>') = iter (\<tturnstile> cd \<leadsto>\<^sub>a) \<Sigma> \<Sigma>'"
proof
  assume "\<exists>n. iter_evala cd n \<Sigma> = Some \<Sigma>'"
  then obtain n where "iter_evala cd n \<Sigma> = Some \<Sigma>'" by fastforce
  thus "iter (\<tturnstile> cd \<leadsto>\<^sub>a) \<Sigma> \<Sigma>'"
  proof (induction n arbitrary: \<Sigma>)
    case (Suc n)
    thus ?case by (cases "cd \<tturnstile>\<^sub>a \<Sigma>") (simp_all add: alg_evala_equiv)
  qed simp_all
next
  show "iter (\<tturnstile> cd \<leadsto>\<^sub>a) \<Sigma> \<Sigma>' \<Longrightarrow> \<exists>n. iter_evala cd n \<Sigma> = Some \<Sigma>'"
  proof (induction \<Sigma> \<Sigma>' rule: iter.induct)
    case (iter_refl \<Sigma>)
    have "iter_evala cd 0 \<Sigma> = Some \<Sigma>" by simp
    thus ?case by blast
  next
    case (iter_step \<Sigma> \<Sigma>' \<Sigma>'')
    then obtain n where "iter_evala cd n \<Sigma>' = Some \<Sigma>''" by fastforce
    moreover from iter_step have "cd \<tturnstile>\<^sub>a \<Sigma> = Some \<Sigma>'" by (simp add: alg_evala_equiv)
    ultimately have "iter_evala cd (Suc n) \<Sigma> = Some \<Sigma>''" by simp
    thus ?case by blast
  qed
qed

end


section \<open>Menger's Theorem\<close>

theory Menger imports Y_eq_new_last Y_neq_new_last begin

text \<open>In this section, we combine the cases and finally prove Menger's Theorem.\<close>

locale ProofStepInductOptimalPaths = ProofStepInduct +
  assumes optimal_paths:
    "\<And>paths' P_new'. ProofStepInduct G v0 v1 paths' P_new' sep_size
      \<Longrightarrow> Digraph.distance (remove_vertex v0) (last P_new) v1
       \<le> Digraph.distance (remove_vertex v0) (last P_new') v1"
begin

lemma one_more_paths_exists_trivial:
  "new_last = v1 \<Longrightarrow> \<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  using P_new_solves_if_disjoint paths_sep_size by blast

lemma one_more_paths_exists_nontrivial:
  assumes "new_last \<noteq> v1"
  shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
proof-
  interpret ProofStepInduct_NonTrivial G v0 v1 paths P_new sep_size
    using assms new_last_def by unfold_locales simp
  obtain P_k_pre y P_k_post where
    "ProofStepInduct_NonTrivial_P_k_pre G v0 v1 paths P_new sep_size P_k_pre y P_k_post"
    using ProofStepInduct_NonTrivial_P_k_pre_exists by blast
  then interpret ProofStepInduct_NonTrivial_P_k_pre G v0 v1 paths P_new sep_size P_k_pre y P_k_post .
  {
    assume "y \<noteq> v1" "y = new_last"
    then interpret ProofStepInduct_y_eq_new_last G v0 v1 paths P_new sep_size P_k_pre y P_k_post
      using optimal_paths[folded H_def] by unfold_locales
    have ?thesis using with_optimal_paths_solves by blast
  } moreover {
    assume "y \<noteq> v1" "y \<noteq> new_last"
    then interpret ProofStepInduct_y_neq_new_last G v0 v1 paths P_new sep_size P_k_pre y P_k_post
      by unfold_locales
    have ?thesis using contradiction by blast
  }
  ultimately show ?thesis using y_eq_v1_solves by blast
qed

corollary one_more_paths_exists:
  shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  using one_more_paths_exists_trivial one_more_paths_exists_nontrivial by blast

end

lemma (in ProofStepInduct) one_more_paths_exists:
  "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
proof-
  define paths_weight where "paths_weight \<equiv>
    \<lambda>(paths' :: 'a Walk set, P_new'). Digraph.distance (remove_vertex v0) (last P_new') v1"
  define paths_good where "paths_good \<equiv>
    \<lambda>(paths', P_new'). ProofStepInduct G v0 v1 paths' P_new' sep_size"
  have "\<exists>paths' P_new'. paths_good (paths', P_new')"
    unfolding paths_good_def using ProofStepInduct_axioms by auto
  then obtain P' where
    P': "paths_good P'" "\<And>P''. paths_good P'' \<Longrightarrow> paths_weight P' \<le> paths_weight P''"
    using arg_min_ex[of paths_good paths_weight] by blast

  then obtain paths' P_new' where P'_decomp: "P' = (paths', P_new')" by (meson surj_pair)

  have optimal_paths_good: "ProofStepInduct G v0 v1 paths' P_new' sep_size"
    using P'(1) P'_decomp unfolding paths_good_def by auto

  have "\<And>paths'' P_new''. paths_good (paths'', P_new'')
    \<Longrightarrow> paths_weight P' \<le> paths_weight (paths'', P_new'')" by (simp add: P'(2))
  then have optimal_paths_min: "\<And>paths'' P_new''. ProofStepInduct G v0 v1 paths'' P_new'' sep_size
    \<Longrightarrow> Digraph.distance (remove_vertex v0) (last P_new') v1
        \<le> Digraph.distance (remove_vertex v0) (last P_new'') v1"
    unfolding paths_good_def paths_weight_def by (simp add: P'_decomp)

  interpret G: ProofStepInductOptimalPaths G v0 v1 paths' P_new' sep_size
    using optimal_paths_good optimal_paths_min
    by (simp add: ProofStepInductOptimalPaths.intro ProofStepInductOptimalPaths_axioms.intro)
  show ?thesis using G.one_more_paths_exists by blast
qed

subsection \<open>Menger's Theorem\<close>

theorem (in v0_v1_Digraph) menger:
  assumes "\<And>S. Separation G v0 v1 S \<Longrightarrow> card S \<ge> n"
  shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = n"
using assms v0_v1_Digraph_axioms proof (induct n arbitrary: G)
  case (0 G)
  then show ?case using v0_v1_Digraph.DisjointPaths_empty[of G] card_empty by blast
next
  case (Suc n G)
  interpret G: v0_v1_Digraph G v0 v1 using Suc(3) .
  have "\<And>S. Separation G v0 v1 S \<Longrightarrow> n \<le> card S" using Suc.prems Suc_leD by blast
  then obtain paths where P: "DisjointPaths G v0 v1 paths" "card paths = n" using Suc(1,3) by blast
  interpret G: DisjointPaths G v0 v1 paths using P(1) .

  obtain P_new where
    P_new: "v0 \<leadsto>P_new\<leadsto>\<^bsub>G\<^esub> v1" "set P_new \<inter> G.second_vertices = {}"
    using G.disjoint_paths_new_path P(2) Suc.prems(1) by blast
  have P_new_new: "P_new \<notin> paths"
    by (metis G.paths_tl_notnil G.second_vertex_def G.second_vertices_def G.path_from_toE IntI
        P_new empty_iff image_eqI list.set_sel(1) list.set_sel(2))

  have "G.hitting_paths v1" unfolding G.hitting_paths_def using v0_neq_v1 by blast
  then have "\<exists>x \<in> set P_new. G.hitting_paths x" using P_new(1) by fastforce
  then obtain new_pre x new_post where
    P_new_decomp: "P_new = new_pre @ x # new_post"
    and x: "G.hitting_paths x"
           "\<And>y. y \<in> set new_pre \<Longrightarrow> \<not>G.hitting_paths y"
    by (metis split_list_first_prop)

  have 1: "DisjointPathsPlusOne G v0 v1 paths (new_pre @ [x])" proof
    show "v0 \<leadsto>(new_pre @ [x])\<leadsto>\<^bsub>G\<^esub> last (new_pre @ [x])" using P_new(1)
      by (metis G.path_decomp' P_new_decomp append_is_Nil_conv hd_append2 list.distinct(1)
          list.sel(1) path_from_to_def self_append_conv2)
    then show "tl (new_pre @ [x]) \<noteq> []"
      by (metis DisjointPaths.hitting_paths_def G.DisjointPaths_axioms G.path_from_toE
          butlast.simps(1) butlast_snoc list.distinct(1) list.sel(1) self_append_conv2
          tl_append2 x(1))
    have "new_pre \<noteq> Nil" using G.hitting_paths_def P_new(1) P_new_decomp x(1) by auto
    then have "hd (tl (new_pre @ [x])) = hd (tl P_new)" by (simp add: P_new_decomp hd_append)
    then show "hd (tl (new_pre @ [x])) \<notin> G.second_vertices"
      by (metis P_new(2) P_new_decomp \<open>new_pre \<noteq> []\<close> append_is_Nil_conv disjoint_iff_not_equal
          list.distinct(1) list.set_sel(1) list.set_sel(2) tl_append2)
    show "G.hitting_paths (last (new_pre @ [x]))" using x(1) by auto
    show "\<And>v. v \<in> set (butlast (new_pre @ [x])) \<Longrightarrow> \<not>G.hitting_paths v" by (simp add: x(2))
  qed

  have 2: "NoSmallSeparationsInduct G v0 v1 n"
    by (simp add: G.v0_v1_Digraph_axioms NoSmallSeparationsInduct.intro
        NoSmallSeparationsInduct_axioms_def Suc.hyps Suc.prems(1))

  show ?case proof (rule ccontr)
    assume not_case: "\<not>?case"
    have "x \<noteq> v1" proof
      assume "x = v1"
      define paths' where "paths' = insert P_new paths"
      {
        fix xs v
        assume *: "xs \<in> paths" "v \<in> set xs" "v \<in> set P_new" "v \<noteq> v0" "v \<noteq> v1"
        have "v \<in> set new_pre"
          by (metis *(3,5) G.path_from_to_ends G.path_from_toE P_new(1) P_new_decomp
              \<open>x = v1\<close> butlast_snoc set_butlast)
        then have False using *(1,2,4) G.hitting_paths_def x(2) by auto
      }
      then have "DisjointPaths G v0 v1 paths'" unfolding paths'_def
        using G.DisjointPaths_extend P_new(1) by blast
      moreover have "card paths' = Suc n"
        using P_new_new by (simp add: G.finite_paths P(2) paths'_def)
      ultimately show False using not_case by blast
    qed
    have "ProofStepInduct_axioms paths n" proof
      show "n \<noteq> 0"
        using G.DisjointPaths_extend G.finite_paths P(2) P_new(1) not_case card_insert_disjoint
        by fastforce
    qed (insert P(2))
    then have "ProofStepInduct G v0 v1 paths (new_pre @ [x]) n"
      using 1 2 by (simp add: ProofStepInduct.intro)
    then show False using ProofStepInduct.one_more_paths_exists not_case by metis
  qed
qed

text \<open>
  The previous theorem was the difficult direction of Menger's Theorem.  Let us now prove the other
  direction: If we have @{term n} disjoint paths, than every separator must contain at least
  @{term n} vertices.  This direction is rather trivial because every separator needs to separate
  at least the @{term n} paths, so we do not need induction or an elaborate setup to prove this.
\<close>

theorem (in v0_v1_Digraph) menger_trivial:
  assumes "DisjointPaths G v0 v1 paths" "card paths = n"
  shows "\<And>S. Separation G v0 v1 S \<Longrightarrow> card S \<ge> n"
proof-
  interpret DisjointPaths G v0 v1 paths using assms(1) .
  fix S assume "Separation G v0 v1 S"
  then interpret S: Separation G v0 v1 S .

  text \<open>
    Our plan is to show @{term "card S \<ge> n"} by defining an injective function from @{term paths}
    into @{term S}.  Because we have @{term "card paths = n"}, the result follows.

    For the injective function, we simply use the observation stated above: Every path needs to
    be separated by @{term S} at some vertex, so we can choose such a vertex.
\<close>
  define f where "f \<equiv> \<lambda>xs. SOME v. v \<in> S \<and> v \<in> set xs"

  have f_good: "\<And>xs. xs \<in> paths \<Longrightarrow> f xs \<in> S \<and> f xs \<in> set xs" proof-
    fix xs assume "xs \<in> paths"
    then obtain v where "v \<in> set xs \<inter> S" using S.S_separates paths by fastforce
    then show "f xs \<in> S \<and> f xs \<in> set xs" unfolding f_def
      using someI[of "\<lambda>v. v \<in> S \<and> v \<in> set xs" v] by blast
  qed

  text \<open>This @{term f} is injective because no two paths intersect in the same vertex.\<close>
  have "inj_on f paths" proof
    fix xs ys
    assume *: "xs \<in> paths" "ys \<in> paths" "f xs = f ys"
    then obtain v where "v \<in> S" "v \<in> set xs" "v \<in> set ys"
      using f_good by fastforce
    then show "xs = ys" using *(1,2) paths_disjoint S.v0_notin_S S.v1_notin_S by fastforce
  qed

  then show "card S \<ge> n" using assms(2) f_good
    by (metis S.finite_S finite_paths image_subsetI inj_on_iff_card_le)
qed

subsection \<open>Self-contained Statement of the Main Theorem\<close>

text \<open>
  Let us state both directions of Menger's Theorem again in a more self-contained way in the
  @{locale Digraph} locale. Stating the theorems in a self-contained way helps avoiding mistakes
  due to wrong definitions hidden in one of the numerous locales we used and also significantly
  reduces the work needed to review this formalization.

  With the statements below, all you need to do in order to verify that this formalization
  actually expresses Menger's Theorem (and not something else), is to look into the assumptions
  and definitions of the @{locale Digraph} locale.
\<close>

theorem (in Digraph) menger:
  fixes v0 v1 :: 'a and n :: nat
  assumes v0_V: "v0 \<in> V"
      and v1_V: "v1 \<in> V"
      and v0_nonadj_v1: "\<not>v0\<rightarrow>v1"
      and v0_neq_v1: "v0 \<noteq> v1"
      and no_small_separators: "\<And>S.
        \<lbrakk> S \<subseteq> V; v0 \<notin> S; v1 \<notin> S; \<And>xs. v0 \<leadsto>xs\<leadsto> v1 \<Longrightarrow> set xs \<inter> S \<noteq> {} \<rbrakk> \<Longrightarrow> card S \<ge> n"
  shows "\<exists>paths. card paths = n \<and> (\<forall>xs \<in> paths.
    v0 \<leadsto>xs\<leadsto> v1 \<and> (\<forall>ys \<in> paths - {xs}. (\<forall>v \<in> set xs \<inter> set ys. v = v0 \<or> v = v1)))"
proof-
  interpret v0_v1_Digraph G v0 v1 using v0_V v1_V v0_nonadj_v1 v0_neq_v1 by unfold_locales
  have "\<And>S. Separation G v0 v1 S \<Longrightarrow> n \<le> card S" using no_small_separators
    by (simp add: Separation.S_V Separation.S_separates Separation.v0_notin_S Separation.v1_notin_S)
  then obtain paths where
    paths: "DisjointPaths G v0 v1 paths" "card paths = n" using no_small_separators menger by blast
  then show ?thesis
    by (metis DiffD1 DiffD2 DisjointPaths.paths DisjointPaths.paths_disjoint IntD1 IntD2 singletonI)
qed

theorem (in Digraph) menger_trivial:
  fixes v0 v1 :: 'a and n :: nat
  assumes v0_V: "v0 \<in> V"
      and v1_V: "v1 \<in> V"
      and v0_nonadj_v1: "\<not>v0\<rightarrow>v1"
      and v0_neq_v1: "v0 \<noteq> v1"
      and n_paths: "card paths = n"
      and paths_disjoint: "\<forall>xs \<in> paths.
        v0 \<leadsto>xs\<leadsto> v1 \<and> (\<forall>ys \<in> paths - {xs}. (\<forall>v \<in> set xs \<inter> set ys. v = v0 \<or> v = v1))"
  shows "\<And>S. \<lbrakk> S \<subseteq> V; v0 \<notin> S; v1 \<notin> S; \<And>xs. v0 \<leadsto>xs\<leadsto> v1 \<Longrightarrow> set xs \<inter> S \<noteq> {} \<rbrakk> \<Longrightarrow> card S \<ge> n"
proof-
  interpret v0_v1_Digraph G v0 v1 using v0_V v1_V v0_nonadj_v1 v0_neq_v1 by unfold_locales
  interpret DisjointPaths G v0 v1 paths proof
    show "\<And>xs. xs \<in> paths \<Longrightarrow> v0 \<leadsto>xs\<leadsto> v1" using paths_disjoint by simp
  next
    fix xs ys v assume "xs \<in> paths" "ys \<in> paths" "xs \<noteq> ys" "v \<in> set xs" "v \<in> set ys"
    then have "xs \<in> paths" "ys \<in> paths - {xs}" "v \<in> set xs \<inter> set ys" by blast+
    then show "v = v0 \<or> v = v1" using paths_disjoint by blast
  qed
  fix S assume "S \<subseteq> V" "v0 \<notin> S" "v1 \<notin> S" "\<And>xs. v0 \<leadsto>xs\<leadsto> v1 \<Longrightarrow> set xs \<inter> S \<noteq> {}"
  then interpret Separation G v0 v1 S by unfold_locales
  show "card S \<ge> n" using menger_trivial DisjointPaths_axioms Separation_axioms n_paths by blast
qed

end


(* Author: Tobias Nipkow *)

theory Hoare_Total_EX
imports Hoare
begin

subsubsection "Hoare Logic for Total Correctness --- \<open>nat\<close>-Indexed Invariant"

text{* This is the standard set of rules that you find in many publications.
The While-rule is different from the one in Concrete Semantics in that the
invariant is indexed by natural numbers and goes down by 1 with
every iteration. The completeness proof is easier but the rule is harder
to apply in program proofs. *}

definition hoare_tvalid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>t {P}c{Q}  \<longleftrightarrow>  (\<forall>s. P s \<longrightarrow> (\<exists>t. (c,s) \<Rightarrow> t \<and> Q t))"

inductive
  hoaret :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile>\<^sub>t ({(1_)}/ (_)/ {(1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>t {P} SKIP {P}"  |

Assign:  "\<turnstile>\<^sub>t {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1 {P\<^sub>2}; \<turnstile>\<^sub>t {P\<^sub>2} c\<^sub>2 {P\<^sub>3} \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1;;c\<^sub>2 {P\<^sub>3}"  |

If: "\<lbrakk> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q}; \<turnstile>\<^sub>t {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>t {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While:
  "\<lbrakk> \<And>n::nat. \<turnstile>\<^sub>t {P (Suc n)} c {P n};
     \<forall>n s. P (Suc n) s \<longrightarrow> bval b s;  \<forall>s. P 0 s \<longrightarrow> \<not> bval b s \<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>t {\<lambda>s. \<exists>n. P n s} WHILE b DO c {P 0}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile>\<^sub>t {P}c{Q}; \<forall>s. Q s \<longrightarrow> Q' s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>t {P'}c{Q'}"

text{* Building in the consequence rule: *}

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile>\<^sub>t {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

text{* The soundness theorem: *}

theorem hoaret_sound: "\<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  \<Turnstile>\<^sub>t {P}c{Q}"
proof(unfold hoare_tvalid_def, induction rule: hoaret.induct)
  case (While P c b)
  {
    fix n s
    have "\<lbrakk> P n s \<rbrakk> \<Longrightarrow> \<exists>t. (WHILE b DO c, s) \<Rightarrow> t \<and> P 0 t"
    proof(induction "n" arbitrary: s)
      case 0 thus ?case using While.hyps(3) WhileFalse by blast
    next
      case (Suc n)
      thus ?case by (meson While.IH While.hyps(2) WhileTrue)
    qed
  }
  thus ?case by auto
next
  case If thus ?case by auto blast
qed fastforce+

definition wpt :: "com \<Rightarrow> assn \<Rightarrow> assn" ("wp\<^sub>t") where
"wp\<^sub>t c Q  =  (\<lambda>s. \<exists>t. (c,s) \<Rightarrow> t \<and> Q t)"

lemma [simp]: "wp\<^sub>t (x ::= e) Q = (\<lambda>s. Q(s(x := aval e s)))"
by(auto intro!: ext simp: wpt_def)

lemma [simp]: "wp\<^sub>t (c\<^sub>1;;c\<^sub>2) Q = wp\<^sub>t c\<^sub>1 (wp\<^sub>t c\<^sub>2 Q)"
unfolding wpt_def
apply(rule ext)
apply auto
done

lemma [simp]:
 "wp\<^sub>t (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>s. wp\<^sub>t (if bval b s then c\<^sub>1 else c\<^sub>2) Q s)"
apply(unfold wpt_def)
apply(rule ext)
apply auto
done

text{* Function @{text wpw} computes the weakest precondition of a While-loop
that is unfolded a fixed number of times. *}

fun wpw :: "bexp \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> assn \<Rightarrow> assn" where
"wpw b c 0 Q s = (\<not> bval b s \<and> Q s)" |
"wpw b c (Suc n) Q s = (bval b s \<and> (\<exists>s'. (c,s) \<Rightarrow> s' \<and>  wpw b c n Q s'))"

lemma WHILE_Its: "(WHILE b DO c,s) \<Rightarrow> t \<Longrightarrow> Q t \<Longrightarrow> \<exists>n. wpw b c n Q s"
proof(induction "WHILE b DO c" s t rule: big_step_induct)
  case WhileFalse thus ?case using wpw.simps(1) by blast
next
  case WhileTrue thus ?case using wpw.simps(2) by blast
qed

lemma wpt_is_pre: "\<turnstile>\<^sub>t {wp\<^sub>t c Q} c {Q}"
proof (induction c arbitrary: Q)
  case SKIP show ?case by (auto intro:hoaret.Skip)
next
  case Assign show ?case by (auto intro:hoaret.Assign)
next
  case Seq thus ?case by (auto intro:hoaret.Seq)
next
  case If thus ?case by (auto intro:hoaret.If hoaret.conseq)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  have c1: "\<forall>s. wp\<^sub>t ?w Q s \<longrightarrow> (\<exists>n. wpw b c n Q s)"
    unfolding wpt_def by (metis WHILE_Its)
  have c3: "\<forall>s. wpw b c 0 Q s \<longrightarrow> Q s" by simp
  have w2: "\<forall>n s. wpw b c (Suc n) Q s \<longrightarrow> bval b s" by simp
  have w3: "\<forall>s. wpw b c 0 Q s \<longrightarrow> \<not> bval b s" by simp
  { fix n
    have 1: "\<forall>s. wpw b c (Suc n) Q s \<longrightarrow> (\<exists>t. (c, s) \<Rightarrow> t \<and> wpw b c n Q t)"
      by simp
    note strengthen_pre[OF 1 While.IH[of "wpw b c n Q", unfolded wpt_def]]
  }
  from conseq[OF c1 hoaret.While[OF this w2 w3] c3]
  show ?case .
qed

theorem hoaret_complete: "\<Turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> \<turnstile>\<^sub>t {P}c{Q}"
apply(rule strengthen_pre[OF _ wpt_is_pre])
apply(auto simp: hoare_tvalid_def wpt_def)
done

corollary hoaret_sound_complete: "\<turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow> \<Turnstile>\<^sub>t {P}c{Q}"
by (metis hoaret_sound hoaret_complete)

end