(* Title: thys/OnetrokeTM.thy
   Author: Franz Regensburger (FABR) 03/2022
 *)

subsection \<open>tm\_onestroke: A Machine for deciding the empty set\<close>

theory OneStrokeTM
  imports
    Turing_Hoare
begin

declare adjust.simps[simp del]

declare seq_tm.simps [simp del]
declare shift.simps[simp del]
declare composable_tm.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]

subsubsection \<open>Definition of the machine tm\_onestroke\<close>

text \<open>We can rely on the fact, that on the initial tape,
two consecutive blanks mean end of input
(see theorem @{thm "noDblBk_tape_of_nat_list"}).

Thus, the machine can check both ends of the (initial) tape.
Note however, that this is just a convention for encoding arguments for functions.
Nevertheless, the tape is (potentially) infinite on both sides.
\<close>

definition tm_onestroke :: "instr list"
  where
    "tm_onestroke \<equiv> [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2)]"

subsubsection \<open>The machine tm\_onestroke in action\<close>

(* <[]> *)
value "steps0 (1, [], <([]::nat list)>) tm_onestroke 0" (* "(1, [], [])" *)
value "steps0 (1, [], <([]::nat list)>) tm_onestroke 1" (* "(3, [Bk], [])" *)
value "steps0 (1, [], <([]::nat list)>) tm_onestroke 2" (* "(0, [Bk], [Oc])" *)

lemma "steps0 (1, [], <([]::nat list)>) tm_onestroke 2 = (0, [Bk], [Oc])"
  by (simp add: tape_of_nat_def tape_of_list_def
                tm_onestroke_def
                numeral_eqs_upto_12
                step.simps steps.simps)

(*  <[0]> *)
value "steps0 (1, [], <[0::nat]>) tm_onestroke 0"  (* "(1, [], [Oc])" *)
value "steps0 (1, [], <[0::nat]>) tm_onestroke 1"  (* "(2, [], [Bk])" *)
value "steps0 (1, [], <[0::nat]>) tm_onestroke 2"  (* "(1, [Bk], [])" *)
value "steps0 (1, [], <[0::nat]>) tm_onestroke 3"  (* "(3, [Bk, Bk], [])" *)
value "steps0 (1, [], <[0::nat]>) tm_onestroke 4"  (* "(0, [Bk, Bk], [Oc])" *)

lemma "steps0 (1, [], <[0::nat]>) tm_onestroke 4 = (0, [Bk, Bk], [Oc])"
  by (simp add: tape_of_nat_def tape_of_list_def
                tm_onestroke_def
                numeral_eqs_upto_12
                step.simps steps.simps)

(*  <[0,0]> *)
lemma "steps0 (1, [], <[0::nat,0]>) tm_onestroke 7 = (0, [Bk, Bk, Bk, Bk], [Oc])"
  by (simp add: tape_of_nat_def tape_of_list_def
                tm_onestroke_def
                numeral_eqs_upto_12
                step.simps steps.simps)

(*  <[1,1]> *)
lemma "steps0 (1, [], <[1::nat,1]>) tm_onestroke 11 = (0, [Bk, Bk, Bk, Bk, Bk, Bk], [Oc])"
  by (simp add: tape_of_nat_def tape_of_list_def
                tm_onestroke_def
                numeral_eqs_upto_12
                step.simps steps.simps)

subsubsection \<open>Partial and Total Correctness of machine tm\_onestroke\<close>

(* Assemble an invariant for the Hoare style proofs:

value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 0"    (* "(1, [], [Oc, Oc, Bk, Oc, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 1"    (* "(2, [], [Bk, Oc, Bk, Oc, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 2"    (* "(1, [Bk], [Oc, Bk, Oc, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 3"    (* "(2, [Bk], [Bk, Bk, Oc, Oc])" <== DblBk in r *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 4"    (* "(1, [Bk, Bk], [Bk, Oc, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 5"    (* "(3, [Bk, Bk, Bk], [Oc, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 6"    (* "(2, [Bk, Bk, Bk], [Bk, Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 7"    (* "(1, [Bk, Bk, Bk, Bk], [Oc])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 8"    (* "(2, [Bk, Bk, Bk, Bk], [Bk])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 9"    (* "(1, [Bk, Bk, Bk, Bk, Bk], [])" *)

value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 10"   (* "(3, [Bk, Bk, Bk, Bk, Bk, Bk], [])" *)
value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 11"   (* "(0, [Bk, Bk, Bk, Bk, Bk, Bk], [Oc])" *)

*)

fun
  inv_tm_onestroke1 :: "tape \<Rightarrow> bool" and
  inv_tm_onestroke2 :: "tape \<Rightarrow> bool" and
  inv_tm_onestroke3 :: "tape \<Rightarrow> bool" and
  inv_tm_onestroke0 :: "tape \<Rightarrow> bool"
  where
    "inv_tm_onestroke1 (l, r) =
        (noDblBk r \<and> l = Bk\<up> (length l) )"
  | "inv_tm_onestroke2 (l, r) =
        (noDblBk (tl r) \<and> l = Bk\<up> (length l) \<and> (\<exists>rs. r = Bk#rs))"
  | "inv_tm_onestroke3 (l, r) =
        (noDblBk r \<and> l = Bk\<up> (length l) \<and> (r= [] \<or> (\<exists>rs. r = Oc#rs)) )"
  | "inv_tm_onestroke0 (l, r) =
         (noDblBk r \<and> l = Bk\<up> (length l) \<and> (r = [Oc]))"

fun inv_tm_onestroke :: "config \<Rightarrow> bool"
  where
    "inv_tm_onestroke (s, tap) =
        (if s = 0 then inv_tm_onestroke0 tap else
         if s = 1 then inv_tm_onestroke1 tap else
         if s = 2 then inv_tm_onestroke2 tap else
         if s = 3 then inv_tm_onestroke3 tap
         else False)"

lemma tm_onestroke_cases:
  fixes s::nat
  assumes "inv_tm_onestroke (s,l,r)"
    and "s=0 \<Longrightarrow> P"
    and "s=1 \<Longrightarrow> P"
    and "s=2 \<Longrightarrow> P"
    and "s=3 \<Longrightarrow> P"
  shows "P"
proof -
  have "s < 4"
  proof (rule ccontr)
    assume "\<not> s < 4"
    with \<open>inv_tm_onestroke (s,l,r)\<close> show False by auto
  qed
  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3" by auto
  with assms show ?thesis by auto
qed

lemma inv_tm_onestroke_step:
  assumes "inv_tm_onestroke cf"
  shows "inv_tm_onestroke (step0 cf tm_onestroke)"
proof (cases cf)
  case (fields s l r)
  then have cf_cases: "cf = (s, l, r)" .
  show "inv_tm_onestroke (step0 cf tm_onestroke)"
  proof (rule tm_onestroke_cases)
    from cf_cases and assms
    show "inv_tm_onestroke (s, l, r)" by auto
  next
    assume "s = 0"
    with cf_cases and assms
    show ?thesis by (auto simp add: tm_onestroke_def)
  next
    assume "s = 1"
    show ?thesis
    proof -
      have "inv_tm_onestroke (step0 (1, l, r) tm_onestroke)"
      proof (cases r)
        case Nil
        then have "r = []" .
        with assms and cf_cases and \<open>s = 1\<close> show ?thesis
          by (auto simp add: tm_onestroke_def step.simps steps.simps)
      next
        case (Cons a rs)
        then have "r = a # rs" .
        show ?thesis
        proof (cases a)
        next
          case Oc
          then have "a = Oc" .
          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
          show ?thesis
            by (auto simp add: tm_onestroke_def noDblBk_def
                               step.simps steps.simps)
        next
          case Bk
          then have "a = Bk" .

          from assms and cf_cases  and \<open>s = 1\<close> have "noDblBk r" by auto
          with \<open>r = a # rs\<close> have "noDblBk rs" by (auto simp add: noDblBk_def)

          from \<open>r = a # rs\<close> and \<open>a = Bk\<close> and \<open>noDblBk r\<close>
          have "r!0 = Bk \<and> (rs = [] \<or> r!(Suc 0) = Oc)"
            using noDblBk_def by fastforce
          with \<open>r = a # rs\<close> have  "(rs = [] \<or> rs!0 = Oc)" by auto
          then have "(rs = [] \<or> (\<exists>rs'. rs = Oc#rs'))"
            by (metis hd_conv_nth list.collapse)

          from \<open>a = Bk\<close> and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
          have "inv_tm_onestroke (step0 (1, l, r) tm_onestroke) =
                  inv_tm_onestroke (step0 (1, l, Bk#rs) tm_onestroke)" by auto
          also have "... = inv_tm_onestroke (3, Bk#l,rs)"
            by (auto simp add: tm_onestroke_def step.simps steps.simps)

          also with assms and \<open>r = a # rs\<close>  and \<open>a = Bk\<close> and \<open>a = Bk\<close>
            and cf_cases and \<open>s = 1\<close> and \<open>noDblBk rs\<close>
            and \<open>(rs = [] \<or> (\<exists>rs'. rs = Oc#rs'))\<close>
          have "... = True"
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
          finally show ?thesis by auto
        qed
      qed
      with cf_cases and \<open>s=1\<close> show ?thesis by auto
    qed
  next
    assume "s = 2"
    show "inv_tm_onestroke (step0 cf tm_onestroke)"
    proof -
      have "inv_tm_onestroke (step0 (2, l, r) tm_onestroke)"
      proof (cases r)
        case Nil
        with assms and cf_cases and \<open>s = 2\<close> show ?thesis
          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
      next
        case (Cons a rs)
        then have "r = a # rs" .
        show ?thesis
        proof (cases a)
          case Bk
          then have "a = Bk" .
          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close>
          show ?thesis
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12
                               step.simps steps.simps)
        next
          case Oc
          then have "a = Oc" .
          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close>
          show ?thesis by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
        qed
      qed
      with cf_cases and \<open>s=2\<close> show ?thesis by auto
    qed
  next
    assume "s = 3"
    show "inv_tm_onestroke (step0 cf tm_onestroke)"
    proof -
      have "inv_tm_onestroke (step0 (3, l, r) tm_onestroke)"
      proof (cases r)
        case Nil
        with assms and cf_cases and \<open>s = 3\<close> show ?thesis
          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 noDblBk_def
                             step.simps steps.simps)
      next
        case (Cons a rs)
        then have "r = a # rs" .
        show ?thesis
        proof (cases a)
          case Oc
          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 3\<close>
          show ?thesis
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 noDblBk_def
                               step.simps steps.simps)
        next
          case Bk
          then have "a = Bk" .
          from assms and cf_cases and \<open>s = 3\<close>
          have "(r= [] \<or> (\<exists>rs. r = Oc#rs))" by auto
          with \<open>a = Bk\<close> and  \<open>r = a # rs\<close> have False by auto
          then show ?thesis by auto
        qed
      qed
      with cf_cases and \<open>s=3\<close> show ?thesis by auto
    qed
  qed
qed

lemma inv_tm_onestroke_steps:
  assumes "inv_tm_onestroke cf"
  shows "inv_tm_onestroke (steps0 cf tm_onestroke stp)"
proof (induct stp)
  case 0
  with assms show ?case
    by (auto simp add: inv_tm_onestroke_step step.simps steps.simps)
next
  case (Suc stp)
  with assms show ?case
    using inv_tm_onestroke_step step_red by auto
qed

lemma tm_onestroke_partial_correctness:
  assumes "\<exists>stp. is_final (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
  shows "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace>
           tm_onestroke
         \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l) \<rbrace>"
proof (rule Hoare_consequence)
  show "(\<lambda>tap. tap = ([], <nl>)) \<mapsto> (\<lambda>tap. tap = ([], <nl>))" by auto
next
  show "inv_tm_onestroke0 \<mapsto> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l))"
    using assert_imp_def by auto
next
  show "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace> tm_onestroke \<lbrace> inv_tm_onestroke0 \<rbrace>"
  proof (rule Hoare_haltI)
    fix l::"cell list"
    fix r:: "cell list"
    assume "(l, r) = ([], <nl:: nat list>)"
    with assms have "\<exists>n. is_final (steps0 (1, l, r) tm_onestroke n)" by auto
    then obtain stp where w_n: "is_final (steps0 (1, l, r) tm_onestroke stp)" by blast

    moreover have "inv_tm_onestroke0 holds_for steps0 (1, l, r) tm_onestroke stp"
    proof -
      have h: "inv_tm_onestroke (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
        by  (rule inv_tm_onestroke_steps)(auto simp add: noDblBk_tape_of_nat_list)
      with  \<open>(l, r) = ([], <nl:: nat list>)\<close> show ?thesis
        by (metis Pair_inject holds_for.elims(3) inv_tm_onestroke.elims(2) is_final_eq w_n)
    qed
    ultimately
    show "\<exists>n. is_final (steps0 (1, l, r) tm_onestroke n) \<and>
              inv_tm_onestroke0 holds_for steps0 (1, l, r) tm_onestroke n"
      by auto
  qed
qed

(* --- now, we prove termination of tm_onestroke and thus total correctness --- *)
(*
    Lexicographic orders (See List.measures)
    quote: "These are useful for termination proofs"

    lemma in_measures[simp]:
      "(x, y) \<in> measures [] = False"
      "(x, y) \<in> measures (f # fs)
             = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
*)

(* Assemble a lexicographic measure function *)

definition measure_tm_onestroke :: "(config \<times> config) set"
  where
    "measure_tm_onestroke = measures [
      \<lambda>(s, l, r). (if s = 0 then 0 else 1),
      \<lambda>(s, l, r). length r,
      \<lambda>(s, l, r). count_list r Oc,
      \<lambda>(s, l, r). (if s = 3 then 0 else 1)
      ]"

lemma wf_measure_tm_onestroke: "wf measure_tm_onestroke"
  unfolding measure_tm_onestroke_def
  by (auto)

lemma measure_tm_onestroke_induct [case_names Step]:
  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_onestroke\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
  using wf_measure_tm_onestroke
  by (metis wf_iff_no_infinite_down_chain)

(* Machine tm_onestroke always halts *)

lemma tm_onestroke_induct_halts: "\<exists> stp. is_final (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
proof (induct rule: measure_tm_onestroke_induct)
  case (Step stp)
  then have "\<not>is_final (steps0 (1, [], <nl>) tm_onestroke stp)" .

  have "inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)"
  proof (rule_tac inv_tm_onestroke_steps)
    show "inv_tm_onestroke (1, [], <nl>)"
      by (auto simp add: noDblBk_tape_of_nat_list)
  qed

  show "(steps0 (1, [], <nl>) tm_onestroke (Suc stp), steps0 (1, [], <nl>) tm_onestroke stp)
         \<in> measure_tm_onestroke"
  proof (cases "steps0 (1, [], <nl>) tm_onestroke stp")
    case (fields s l r)
    then have cf_cases: "steps0 (1, [], <nl>) tm_onestroke stp = (s, l, r)" .

    show ?thesis
    proof (rule tm_onestroke_cases)
      from \<open>inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)\<close> and cf_cases
      show "inv_tm_onestroke (s, l, r)" by auto
    next
      assume "s=0"
      with cf_cases \<open>\<not>is_final (steps0 (1, [], <nl>) tm_onestroke stp)\<close> show ?thesis by auto
    next
      assume "s=1"
      show ?thesis
      proof (cases r)
        case Nil
        then have "r = []" .
        with cf_cases and \<open>s=1\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, [])" by auto
        have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
              step0 (steps0 (1,[], <nl>) tm_onestroke stp) tm_onestroke"
          by (rule step_red)
        also with cf_cases and \<open>s=1\<close> and \<open>r = []\<close> have "... = step0 (1,l,[]) tm_onestroke" by auto
        also have "... = (3,Bk#l,[])"
          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
        finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (3,Bk#l,[])" by auto

        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, [])\<close>
        show ?thesis by (auto simp add: measure_tm_onestroke_def)
      next
        case (Cons a rs)
        then have "r = a # rs" .
        show ?thesis
        proof (cases "a")
          case Bk
          then have "a=Bk" .
          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
          have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Bk#rs)" by auto

          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
            by (rule step_red)
          also  with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close> and \<open>a=Bk\<close>
          have "... = step0 ((1, l, Bk#rs)) tm_onestroke" by auto
          also have "... = (3,Bk#l,rs)"
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (3,Bk#l,rs)" by auto

          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Bk#rs)\<close>
          show ?thesis by (auto simp add: measure_tm_onestroke_def)
        next
          case Oc
          then have "a=Oc" .
          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
          have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Oc#rs)"  by auto

          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
            by (rule step_red)
          also  with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close> and \<open>a=Oc\<close>
          have "... = step0 ((1, l, Oc#rs)) tm_onestroke" by auto
          also have "... = (2,l,Bk#rs)"
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (2,l,Bk#rs)" by auto

          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Oc#rs)\<close>
          show ?thesis by (auto simp add: measure_tm_onestroke_def)
        qed
      qed
    next
      assume "s=2"
      show ?thesis
      proof -
        from cf_cases and \<open>s=2\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (2, l, r)" by auto
        with \<open>inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)\<close> have "(\<exists>rs. r = Bk#rs)" by auto
        then obtain rs where "r = Bk#rs" by blast
        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (2, l, r)\<close>
        have "steps0 (1, [], <nl>) tm_onestroke stp = (2, l, Bk#rs)" by auto

        have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
              step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
          by (rule step_red)
        also with cf_cases and \<open>s=2\<close> and \<open>r = Bk#rs\<close>
        have "... = step0 (2,l,Bk#rs) tm_onestroke" by auto
        also have "... = (1,Bk#l,rs)"
          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
        finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (1,Bk#l,rs)" by auto

        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (2, l, Bk#rs)\<close>
        show ?thesis by (auto simp add: measure_tm_onestroke_def)
      qed
    next
      assume "s=3"
      show ?thesis
      proof -
        from cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l, r)" by auto
        with \<open>inv_tm_onestroke (steps0 (1,[], <nl>) tm_onestroke stp)\<close> have "(r= [] \<or> (\<exists>rs. r = Oc#rs))" by auto
        then show ?thesis
        proof
          assume "r = []"
          with cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l, [])" by auto
          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
            by (rule step_red)
          also with cf_cases and \<open>s=3\<close> and \<open>r = []\<close>
          have "... = step0 (3,l,[]) tm_onestroke" by auto
          also have "... = (0,l,[Oc])"
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (0,l,[Oc])" by auto

          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (3, l, [])\<close>
          show ?thesis by (auto simp add: measure_tm_onestroke_def)
        next
          assume "\<exists>rs. r = Oc # rs"
          then obtain rs where "r = Oc # rs" by blast
          with cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l,Oc # rs)" by auto
          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
            by (rule step_red)
          also with cf_cases and \<open>s=3\<close> and \<open>r = Oc # rs\<close>
          have "... = step0 (3,l,Oc # rs) tm_onestroke" by auto
          also have "... = (2,l,Bk#rs)"
            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (2,l,Bk#rs)" by auto

          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (3, l,Oc # rs)\<close>
          show ?thesis by (auto simp add: measure_tm_onestroke_def)
        qed
      qed
    qed
  qed
qed

lemma tm_onestroke_total_correctness:
  "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace> tm_onestroke \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l) \<rbrace>"
proof (rule tm_onestroke_partial_correctness)
  show "\<exists>stp. is_final (steps0 (1, [], <nl>) tm_onestroke stp)"
    using  tm_onestroke_induct_halts by auto
qed

end


(*
  File: Arrays_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of arrays\<close>

theory Arrays_Impl
  imports SepAuto "../Functional/Arrays_Ex"
begin

text \<open>
  Imperative implementations of common array operations.

  Imperative reverse on arrays is also verified in theory Imperative\_Reverse
  in Imperative\_HOL/ex in the Isabelle library.
\<close>

subsection \<open>Array copy\<close>

fun array_copy :: "'a::heap array \<Rightarrow> 'a array \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "array_copy a b 0 = (return ())"
| "array_copy a b (Suc n) = do {
      array_copy a b n;
      x \<leftarrow> Array.nth a n;
      Array.upd n x b;
      return () }"

lemma array_copy_rule [hoare_triple]:
  "n \<le> length as \<Longrightarrow> n \<le> length bs \<Longrightarrow>
   <a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs>
    array_copy a b n
   <\<lambda>_. a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a Arrays_Ex.array_copy as bs n>"
@proof @induct n @qed

subsection \<open>Swap\<close>

definition swap :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "swap a i j = do {
     x \<leftarrow> Array.nth a i;
     y \<leftarrow> Array.nth a j;
     Array.upd i y a;
     Array.upd j x a;
     return ()
   }"

lemma swap_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow>
   <p \<mapsto>\<^sub>a xs>
   swap p i j
   <\<lambda>_. p \<mapsto>\<^sub>a list_swap xs i j>" by auto2

subsection \<open>Reverse\<close>

fun rev :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "rev a i j = (if i < j then do {
     swap a i j;
     rev a (i + 1) (j - 1)
   }
   else return ())"

lemma rev_to_fun [hoare_triple]:
  "j < length xs \<Longrightarrow>
   <p \<mapsto>\<^sub>a xs>
   rev p i j
   <\<lambda>_. p \<mapsto>\<^sub>a rev_swap xs i j>"
@proof @fun_induct "rev_swap xs i j" @unfold "rev_swap xs i j" @qed

text \<open>Correctness of imperative reverse.\<close>
theorem rev_is_rev [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow>
   <p \<mapsto>\<^sub>a xs>
   rev p 0 (length xs - 1)
   <\<lambda>_. p \<mapsto>\<^sub>a List.rev xs>" by auto2

end


theory SubstDropEnv
  imports AltFlatLemma SubstExp
begin

fun drop_use_env_ex where
  "drop_use_env_ex r_s OwnPerm = r_s"
| "drop_use_env_ex r_s r = drop_use_env r_s"

definition tau_drop_req where
  "tau_drop_req r tau = (if r = OwnPerm then True else req_type tau \<noteq> Aff)"

lemma wt_sexp_drop_all_ex: "\<lbrakk> well_typed env rx e tau rx rx; tau_drop_req r tau; is_sexp e \<rbrakk> \<Longrightarrow> well_typed env (drop_use_env_ex rx r) e tau (drop_use_env_ex rx r) (drop_use_env_ex rx r)"
  apply (simp add: tau_drop_req_def)
  apply (case_tac r)
    apply (auto)
   apply (rule_tac wt_sexp_drop_all)
     apply (auto)
  apply (rule_tac wt_sexp_drop_all)
    apply (auto)
  done

lemma dist_drop_leq_use_env_ex: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (drop_use_env_ex r_s q) (drop_use_env_ex r_s r)"
  apply (case_tac "drop_use_env_ex r_s q = drop_use_env r_s")
   apply (case_tac r)
     apply (auto)
     apply (rule_tac id_leq_use_env)
    apply (rule_tac id_leq_use_env)
   apply (rule_tac self_drop_leq_use_env)
  apply (case_tac q)
    apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (rule_tac id_leq_use_env)
  done

lemma safe_lift_drop_use_env: "\<lbrakk> r \<noteq> NoPerm \<rbrakk> \<Longrightarrow> safe_use_lift (drop_use_env_ex r_s r) r"
  apply (case_tac r)
    apply (auto)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
  done

end


theory argument_structured
  imports four_logic embedding_basic
begin

type_synonym \<alpha> = "w \<Rightarrow> \<tau>" (*type for structured arguments*)

(*Observe that pairs of booleans have an alternative, simpler representation *)
lemma mkPair_setdef: "\<langle>a,b\<rangle> = (\<lambda>X. (a \<inter> (\<lambda>w. \<not>X)) \<union> (b \<inter> (\<lambda>w. X)))"
  unfolding connSet  by (metis (mono_tags, opaque_lifting) base.fst_def base.snd_def fst_prop snd_prop)

abbreviation "Support a \<equiv> fst (a\<^sup>T)"
abbreviation "Claim a \<equiv> snd (a\<^sup>T)"
lemma arg_char: "a = \<langle>Support a, Claim a\<rangle>\<^sup>T" by simp

named_theorems argDefs1
named_theorems argDefs2

(** deductive arguments *)
definition \<D>::"\<alpha> Set" where "\<D> \<equiv> \<lambda>A. [Support A \<^bold>\<turnstile> Claim A]"
(** consistent arguments *)
definition \<C>::"\<alpha> Set" where "\<C> \<equiv> \<lambda>A. [\<^bold>\<turnstile>\<^sup>s\<^sup>a\<^sup>t Support A, Claim A]"
(** premise-consistent arguments *)
definition \<C>'::"\<alpha> Set" where "\<C>' \<equiv> \<lambda>A. [\<^bold>\<turnstile>\<^sup>s\<^sup>a\<^sup>t Support A]"

declare \<D>_def[argDefs1] \<C>_def[argDefs1] \<C>'_def[argDefs1]

lemma \<D>_def2: "\<D> A = (\<forall>w. A w \<noteq> \<^bold>F)" by (smt (verit, del_insts) \<D>_def Fval_def mkPair_def mkPair_prop subset_def)
lemma \<C>_def2:  "\<C> A = (\<exists>w. A w = \<^bold>B)" by (smt (verit, del_insts) Bval_def \<C>_def fst_def snd_def eqset_def2 fst_prop inter_def mkPair_prop snd_prop subset_def)
lemma \<C>'_def2: "\<C>' A = (\<exists>w. A w = \<^bold>B \<or> A w = \<^bold>F)" by (smt (verit) \<C>'_def \<C>_def \<C>_def2 \<D>_def \<D>_def2 eqset_def inter_def subset_def)

declare \<D>_def2[argDefs2] \<C>_def2[argDefs2] \<C>'_def2[argDefs2]

lemma \<D>\<C>prop: "\<D> a \<longrightarrow> (\<C>' a = \<C> a)" unfolding argDefs2 by simp

definition \<V>::"\<alpha> Set" where "\<V> \<equiv> \<C> \<inter> \<D>" (** valid/correct arguments *)
definition \<E>::"\<alpha> Set" where "\<E> \<equiv> \<C> \<leftharpoonup> \<D>" (** enthymemes *)
definition \<T>::"\<alpha> Set" where "\<T> \<equiv> \<D> \<leftharpoonup> \<C>" (** trivial arguments *)
definition \<I>::"\<alpha> Set" where "\<I> \<equiv> \<midarrow>(\<C> \<union> \<D>)" (** invalid/self-rebutting arguments *)

declare \<V>_def[argDefs1] \<E>_def[argDefs1] \<T>_def[argDefs1] \<I>_def[argDefs1]

lemma partition: "\<forall>w. \<V> w \<or> \<E> w \<or> \<T> w \<or> \<I> w" unfolding \<E>_def \<I>_def \<T>_def \<V>_def connSet by blast

lemma \<T>_char: "\<T> = \<midarrow>\<C>'" unfolding \<T>_def connSet argDefs2 by blast
lemma \<I>_char: "\<I> = \<C>' \<inter> \<midarrow>\<C>" unfolding \<I>_def connSet argDefs2 by blast

lemma \<V>_def2: "\<V> A = ((\<exists>w. A w = \<^bold>B) \<and> (\<forall>w. A w \<noteq> \<^bold>F))" by (simp add: \<C>_def2 \<D>_def2 \<V>_def connSet)
lemma \<E>_def2: "\<E> A = ((\<exists>w. A w = \<^bold>B) \<and> (\<exists>w. A w = \<^bold>F))" by (simp add: \<C>_def2 \<D>_def2 \<E>_def diff_def)
lemma \<T>_def2: "\<T> A = (\<forall>w. A w = \<^bold>N \<or> A w = \<^bold>T)" by (smt (verit, del_insts) Bval_def Fval_def Nval_def Tval_def \<C>'_def2 \<T>_char compl_def fst_prop mkPair_prop)
lemma \<I>_def2: "\<I> A = ((\<forall>w. A w \<noteq> \<^bold>B) \<and> (\<exists>w. A w = \<^bold>F))" by (simp add: \<C>_def2 \<D>_def2 \<I>_def connSet)

(** Three different forms of attack *)
definition undermine::"\<alpha> Rel" ("undermine")
  where "undermine a b \<equiv> [\<^bold>\<turnstile>\<^sup>u\<^sup>n\<^sup>s\<^sup>a\<^sup>t Claim a, Support b]"
definition rebute::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" ("rebute")
  where "rebute a b \<equiv> [\<^bold>\<turnstile>\<^sup>u\<^sup>n\<^sup>s\<^sup>a\<^sup>t Claim a, Claim b]"
definition undercut::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" ("undercut")
  where "undercut a b \<equiv> [\<^bold>\<turnstile> Claim a] \<longrightarrow> \<not>(\<D> b)"

declare undermine_def[argDefs1] rebute_def[argDefs1] undercut_def[argDefs1]

lemma undermine_def2: "undermine a b = (\<forall>w. (a w = \<^bold>B \<or> a w = \<^bold>T) \<longrightarrow> (b w = \<^bold>N \<or> b w = \<^bold>T))"
  by (smt (z3) Bval_def Nval_def Tval_def fst_def snd_def eqset_def fst_prop inter_def mkPair_prop snd_prop undermine_def)
lemma rebute_def2: "rebute a b = (\<forall>w. (a w = \<^bold>B \<or> a w = \<^bold>T) \<longrightarrow> (b w = \<^bold>N \<or> b w = \<^bold>F))"
  by (smt (z3) Bval_def Fval_def Nval_def Tval_def snd_def eqset_def inter_def mkPair_prop rebute_def snd_prop)
lemma undercut_def2: "undercut a b = (\<exists>w. (a w = \<^bold>B \<or> a w = \<^bold>T) \<longrightarrow> b w = \<^bold>F)"
  unfolding undercut_def by (smt (z3) Bval_def \<D>_def2 Tval_def base.snd_def eqset_def mkPair_prop snd_prop )

declare undermine_def2[argDefs2] rebute_def2[argDefs2] undercut_def2[argDefs2]

(*We also introduce the relativized variants (wrt. and universe \<A> of arguments)*)
abbreviation undermine_rel::"\<alpha> Set \<Rightarrow> \<alpha> Rel" ("undermine\<^sup>_")
  where "undermine\<^sup>\<A> a b \<equiv> \<A> a \<and> \<A> b \<and> undermine a b"
abbreviation rebute_rel::"\<alpha> Set\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" ("rebute\<^sup>_")
  where "rebute\<^sup>\<A> a b \<equiv> \<A> a \<and> \<A> b \<and> rebute a b"
abbreviation undercut_rel::"\<alpha> Set\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" ("undercut\<^sup>_")
  where "undercut\<^sup>\<A> a b \<equiv> \<A> a \<and> \<A> b \<and> undercut a b"

(*Rebutting a deductive argument entails undermining it*)
lemma "rebute a b \<and> \<D> b \<longrightarrow> undermine a b" by (smt (verit) \<D>_def eqset_def inter_def rebute_def subset_def undermine_def)

(*The conjunction of the claims of a set of arguments*)
abbreviation "Claims S \<equiv> \<Inter>(\<lambda>C. \<exists>A. S A \<and> (C = Claim A))"
(*The argument-coalition supporting a claim C wrt. a set of arguments S (TODO: useful?)*)
abbreviation supporting::"\<alpha> Set \<Rightarrow> \<sigma> \<Rightarrow> \<alpha>" ("supports")
  where "supporting S C \<equiv> \<langle>Claims S,C\<rangle>\<^sup>T"
lemma "Support (supporting S C) = Claims S" by simp

(*It is in fact possible to define an algebra of arguments. This algebra inherits the structure of FOUR.*)
named_theorems connArg1
named_theorems connArg2

definition meetArg::"\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" (infixr "\<sqinter>\<^sup>a" 80)
  where "A \<sqinter>\<^sup>a B \<equiv> \<lambda>w. A w \<sqinter>\<^sup>4 B w"
definition joinArg::"\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" (infixr "\<squnion>\<^sup>a" 80)
  where "A \<squnion>\<^sup>a B \<equiv> \<lambda>w. A w \<squnion>\<^sup>4 B w"
definition cmplArg::"\<alpha> \<Rightarrow> \<alpha>" ("\<midarrow>\<^sup>a_" 90) (*the complemented argument*)
  where "\<midarrow>\<^sup>aA \<equiv> \<lambda>w. \<midarrow>\<^sup>4(A w)"
definition orderCArg::"\<alpha> Rel" (infixr "\<sqsubseteq>\<^sup>a" 80)
  where "A \<sqsubseteq>\<^sup>a B \<equiv> \<forall>w. A w \<sqsubseteq>\<^sup>4 B w"

declare meetArg_def[connArg1] joinArg_def[connArg1] cmplArg_def[connArg1] orderCArg_def[connArg1]

lemma meetArg_def2: "(A \<sqinter>\<^sup>a B) = \<langle>Support A \<inter> Support B, Claim A \<inter> Claim B\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
lemma joinArg_def2: "(A \<squnion>\<^sup>a B) = \<langle>Support A \<union> Support B, Claim A \<union> Claim B\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
lemma cmplArg_def2: "\<midarrow>\<^sup>aA = \<langle>\<midarrow>(Support A), \<midarrow>(Claim A)\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
lemma order1Arg_def2: "A \<sqsubseteq>\<^sup>a B = (Support A \<subseteq> Support B \<and> Claim A \<subseteq> Claim B)" unfolding connSet connArg1 by s1

declare meetArg_def2[connArg2] joinArg_def2[connArg2] cmplArg_def2[connArg2] order1Arg_def2[connArg2]

definition andArg::"\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" (infixr "\<and>\<^sup>a" 80)
  where "A \<and>\<^sup>a B \<equiv> \<lambda>w. A w \<and>\<^sup>4 B w"
definition orArg::"\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" (infixr "\<or>\<^sup>a" 80)
  where "A \<or>\<^sup>a B \<equiv> \<lambda>w. A w \<or>\<^sup>4 B w"
definition cnvArg::"\<alpha> \<Rightarrow> \<alpha>" ("\<sim>\<^sup>a_" 90) (*the converse argument*)
  where "\<sim>\<^sup>aA \<equiv> \<lambda>w. \<sim>\<^sup>4(A w)"
definition orderGArg::"\<alpha> Rel" (infixr "\<preceq>\<^sup>a" 80)
  where "A \<preceq>\<^sup>a B \<equiv> \<forall>w. A w \<preceq>\<^sup>4 B w"

declare andArg_def[connArg1] orArg_def[connArg1] cnvArg_def[connArg1] orderGArg_def[connArg1]

lemma andArg_def2: "A \<and>\<^sup>a B = \<langle>Support A \<union> Support B, Claim A \<inter> Claim B\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
lemma orArg_def2: "A \<or>\<^sup>a B = \<langle>Support A \<inter> Support B, Claim A \<union> Claim B\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
lemma cnvArg_def2: "\<sim>\<^sup>aA = \<langle>Claim A, Support A\<rangle>\<^sup>T" unfolding connSet connArg1 by s1
(*"B is more general/conservative than A": less demanding on the support and less specific on the claim*)
lemma orderGArg_def2: "A \<preceq>\<^sup>a B = (Support B \<subseteq> Support A \<and> Claim A \<subseteq> Claim B)" unfolding connSet connArg1 by s1

declare andArg_def2[connArg2] orArg_def2[connArg2] cnvArg_def2[connArg2] orderGArg_def2[connArg2]

(*A is a question-begging argument if its converse is deductive:*)
lemma "\<D>(\<sim>\<^sup>aA) = (Claim A \<subseteq> Support A)" by (simp add: \<D>_def fst_def snd_def mkPair_def cnvArg_def2)
end