theory MDL
  imports Interval Trace
begin

section \<open>Formulas and Satisfiability\<close>

declare [[typedef_overloaded]]

datatype ('a, 't :: timestamp) formula = Bool bool | Atom 'a | Neg "('a, 't) formula" |
  Bin "bool \<Rightarrow> bool \<Rightarrow> bool" "('a, 't) formula" "('a, 't) formula" |
  Prev "'t \<I>" "('a, 't) formula" | Next "'t \<I>" "('a, 't) formula" |
  Since "('a, 't) formula" "'t \<I>" "('a, 't) formula" |
  Until "('a, 't) formula" "'t \<I>" "('a, 't) formula" |
  MatchP "'t \<I>" "('a, 't) regex" | MatchF "'t \<I>" "('a, 't) regex"
  and ('a, 't) regex = Lookahead "('a, 't) formula" | Symbol "('a, 't) formula" |
  Plus "('a, 't) regex" "('a, 't) regex" | Times "('a, 't) regex" "('a, 't) regex" |
  Star "('a, 't) regex"

fun eps :: "('a, 't :: timestamp) regex \<Rightarrow> bool" where
  "eps (Lookahead phi) = True"
| "eps (Symbol phi) = False"
| "eps (Plus r s) = (eps r \<or> eps s)"
| "eps (Times r s) = (eps r \<and> eps s)"
| "eps (Star r) = True"

fun atms :: "('a, 't :: timestamp) regex \<Rightarrow> ('a, 't) formula set" where
  "atms (Lookahead phi) = {phi}"
| "atms (Symbol phi) = {phi}"
| "atms (Plus r s) = atms r \<union> atms s"
| "atms (Times r s) = atms r \<union> atms s"
| "atms (Star r) = atms r"

lemma size_atms[termination_simp]: "phi \<in> atms r \<Longrightarrow> size phi < size r"
  by (induction r) auto

fun wf_fmla :: "('a, 't :: timestamp) formula \<Rightarrow> bool"
  and wf_regex :: "('a, 't) regex \<Rightarrow> bool" where
  "wf_fmla (Bool b) = True"
| "wf_fmla (Atom a) = True"
| "wf_fmla (Neg phi) = wf_fmla phi"
| "wf_fmla (Bin f phi psi) = (wf_fmla phi \<and> wf_fmla psi)"
| "wf_fmla (Prev I phi) = wf_fmla phi"
| "wf_fmla (Next I phi) = wf_fmla phi"
| "wf_fmla (Since phi I psi) = (wf_fmla phi \<and> wf_fmla psi)"
| "wf_fmla (Until phi I psi) = (wf_fmla phi \<and> wf_fmla psi)"
| "wf_fmla (MatchP I r) = (wf_regex r \<and> (\<forall>phi \<in> atms r. wf_fmla phi))"
| "wf_fmla (MatchF I r) = (wf_regex r \<and> (\<forall>phi \<in> atms r. wf_fmla phi))"
| "wf_regex (Lookahead phi) = False"
| "wf_regex (Symbol phi) = wf_fmla phi"
| "wf_regex (Plus r s) = (wf_regex r \<and> wf_regex s)"
| "wf_regex (Times r s) = (wf_regex s \<and> (\<not>eps s \<or> wf_regex r))"
| "wf_regex (Star r) = wf_regex r"

fun progress :: "('a, 't :: timestamp) formula \<Rightarrow> 't list \<Rightarrow> nat" where
  "progress (Bool b) ts = length ts"
| "progress (Atom a) ts = length ts"
| "progress (Neg phi) ts = progress phi ts"
| "progress (Bin f phi psi) ts = min (progress phi ts) (progress psi ts)"
| "progress (Prev I phi) ts = min (length ts) (Suc (progress phi ts))"
| "progress (Next I phi) ts = (case progress phi ts of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k)"
| "progress (Since phi I psi) ts = min (progress phi ts) (progress psi ts)"
| "progress (Until phi I psi) ts = (if length ts = 0 then 0 else
  (let k = min (length ts - 1) (min (progress phi ts) (progress psi ts)) in
   Min {j. 0 \<le> j \<and> j \<le> k \<and> memR (ts ! j) (ts ! k) I}))"
| "progress (MatchP I r) ts = Min ((\<lambda>f. progress f ts) ` atms r)"
| "progress (MatchF I r) ts = (if length ts = 0 then 0 else
  (let k = min (length ts - 1) (Min ((\<lambda>f. progress f ts) ` atms r)) in
   Min {j. 0 \<le> j \<and> j \<le> k \<and> memR (ts ! j) (ts ! k) I}))"

fun bounded_future_fmla :: "('a, 't :: timestamp) formula \<Rightarrow> bool"
  and bounded_future_regex :: "('a, 't) regex \<Rightarrow> bool" where
  "bounded_future_fmla (Bool b) \<longleftrightarrow> True"
| "bounded_future_fmla (Atom a) \<longleftrightarrow> True"
| "bounded_future_fmla (Neg phi) \<longleftrightarrow> bounded_future_fmla phi"
| "bounded_future_fmla (Bin f phi psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi"
| "bounded_future_fmla (Prev I phi) \<longleftrightarrow> bounded_future_fmla phi"
| "bounded_future_fmla (Next I phi) \<longleftrightarrow> bounded_future_fmla phi"
| "bounded_future_fmla (Since phi I psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi"
| "bounded_future_fmla (Until phi I psi) \<longleftrightarrow> bounded_future_fmla phi \<and> bounded_future_fmla psi \<and> right I \<in> tfin"
| "bounded_future_fmla (MatchP I r) \<longleftrightarrow> bounded_future_regex r"
| "bounded_future_fmla (MatchF I r) \<longleftrightarrow> bounded_future_regex r \<and> right I \<in> tfin"
| "bounded_future_regex (Lookahead phi) \<longleftrightarrow> bounded_future_fmla phi"
| "bounded_future_regex (Symbol phi) \<longleftrightarrow> bounded_future_fmla phi"
| "bounded_future_regex (Plus r s) \<longleftrightarrow> bounded_future_regex r \<and> bounded_future_regex s"
| "bounded_future_regex (Times r s) \<longleftrightarrow> bounded_future_regex r \<and> bounded_future_regex s"
| "bounded_future_regex (Star r) \<longleftrightarrow> bounded_future_regex r"

lemmas regex_induct[case_names Lookahead Symbol Plus Times Star, induct type: regex] =
  regex.induct[of "\<lambda>_. True", simplified]

definition "Once I \<phi> \<equiv> Since (Bool True) I \<phi>"
definition "Historically I \<phi> \<equiv> Neg (Once I (Neg \<phi>))"
definition "Eventually I \<phi> \<equiv> Until (Bool True) I \<phi>"
definition "Always I \<phi> \<equiv> Neg (Eventually I (Neg \<phi>))"

fun rderive :: "('a, 't :: timestamp) regex \<Rightarrow> ('a, 't) regex" where
  "rderive (Lookahead phi) = Lookahead (Bool False)"
| "rderive (Symbol phi) = Lookahead phi"
| "rderive (Plus r s) = Plus (rderive r) (rderive s)"
| "rderive (Times r s) = (if eps s then Plus (rderive r) (Times r (rderive s)) else Times r (rderive s))"
| "rderive (Star r) = Times (Star r) (rderive r)"

lemma atms_rderive: "phi \<in> atms (rderive r) \<Longrightarrow> phi \<in> atms r \<or> phi = Bool False"
  by (induction r) (auto split: if_splits)

lemma size_formula_positive: "size (phi :: ('a, 't :: timestamp) formula) > 0"
  by (induction phi) auto

lemma size_regex_positive: "size (r :: ('a, 't :: timestamp) regex) > Suc 0"
  by (induction r) (auto intro: size_formula_positive)

lemma size_rderive[termination_simp]: "phi \<in> atms (rderive r) \<Longrightarrow> size phi < size r"
  by (drule atms_rderive) (auto intro: size_atms size_regex_positive)

locale MDL =
  fixes \<sigma> :: "('a, 't :: timestamp) trace"
begin

fun sat :: "('a, 't) formula \<Rightarrow> nat \<Rightarrow> bool"
  and match :: "('a, 't) regex \<Rightarrow> (nat \<times> nat) set" where
  "sat (Bool b) i = b"
| "sat (Atom a) i = (a \<in> \<Gamma> \<sigma> i)"
| "sat (Neg \<phi>) i = (\<not> sat \<phi> i)"
| "sat (Bin f \<phi> \<psi>) i = (f (sat \<phi> i) (sat \<psi> i))"
| "sat (Prev I \<phi>) i = (case i of 0 \<Rightarrow> False | Suc j \<Rightarrow> mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> sat \<phi> j)"
| "sat (Next I \<phi>) i = (mem (\<tau> \<sigma> i) (\<tau> \<sigma> (Suc i)) I \<and> sat \<phi> (Suc i))"
| "sat (Since \<phi> I \<psi>) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> sat \<psi> j \<and> (\<forall>k \<in> {j<..i}. sat \<phi> k))"
| "sat (Until \<phi> I \<psi>) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> sat \<psi> j \<and> (\<forall>k \<in> {i..<j}. sat \<phi> k))"
| "sat (MatchP I r) i = (\<exists>j\<le>i. mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I \<and> (j, Suc i) \<in> match r)"
| "sat (MatchF I r) i = (\<exists>j\<ge>i. mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I \<and> (i, Suc j) \<in> match r)"
| "match (Lookahead \<phi>) = {(i, i) | i. sat \<phi> i}"
| "match (Symbol \<phi>) = {(i, Suc i) | i. sat \<phi> i}"
| "match (Plus r s) = match r \<union> match s"
| "match (Times r s) = match r O match s"
| "match (Star r) = rtrancl (match r)"

lemma "sat (Prev I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
  "sat (Next I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
  "sat (Since \<phi> I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
  "sat (Until \<phi> I (Bool False)) i \<longleftrightarrow> sat (Bool False) i"
  apply (auto split: nat.splits)
  done

lemma prev_rewrite: "sat (Prev I \<phi>) i \<longleftrightarrow> sat (MatchP I (Times (Symbol \<phi>) (Symbol (Bool True)))) i"
  apply (auto split: nat.splits)
  subgoal for j
    by (fastforce intro: exI[of _ j])
  done

lemma next_rewrite: "sat (Next I \<phi>) i \<longleftrightarrow> sat (MatchF I (Times (Symbol (Bool True)) (Symbol \<phi>))) i"
  by (fastforce intro: exI[of _ "Suc i"])

lemma trancl_Base: "{(i, Suc i) |i. P i}\<^sup>* = {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}"
proof -
  have "(x, y) \<in> {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}"
    if "(x, y) \<in> {(i, Suc i) |i. P i}\<^sup>*" for x y
    using that by (induct rule: rtrancl_induct) (auto simp: less_Suc_eq)
  moreover have "(x, y) \<in> {(i, Suc i) |i. P i}\<^sup>*"
    if "(x, y) \<in> {(i, j). i \<le> j \<and> (\<forall>k\<in>{i..<j}. P k)}" for x y
    using that unfolding mem_Collect_eq prod.case Ball_def
    by (induct y arbitrary: x)
       (auto 0 3 simp: le_Suc_eq intro: rtrancl_into_rtrancl[rotated])
  ultimately show ?thesis by blast
qed

lemma Ball_atLeastLessThan_reindex:
  "(\<forall>k\<in>{j..<i}. P (Suc k)) = (\<forall>k \<in> {j<..i}. P k)"
  by (auto simp: less_eq_Suc_le less_eq_nat.simps split: nat.splits)

lemma since_rewrite: "sat (Since \<phi> I \<psi>) i \<longleftrightarrow> sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
proof (rule iffI)
  assume "sat (Since \<phi> I \<psi>) i"
  then obtain j where j_def: "j \<le> i" "mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I" "sat \<psi> j"
    "\<forall>k \<in> {j..<i}. sat \<phi> (Suc k)"
    by auto
  have "k \<in> {Suc j..<Suc i} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)" for k
    using j_def(4)
    by (cases k) auto
  then have "(Suc j, Suc i) \<in> (match (Symbol \<phi>))\<^sup>*"
    using j_def(1) trancl_Base
    by auto
  then show "sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
    using j_def(1,2,3)
    by auto
next
  assume "sat (MatchP I (Times (Symbol \<psi>) (Star (Symbol \<phi>)))) i"
  then obtain j where j_def: "j \<le> i" "mem (\<tau> \<sigma> j) (\<tau> \<sigma> i) I" "(Suc j, Suc i) \<in> (match (Symbol \<phi>))\<^sup>*" "sat \<psi> j"
    by auto
  have "\<And>k. k \<in> {Suc j..<Suc i} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)"
    using j_def(3) trancl_Base[of "\<lambda>k. (k, Suc k) \<in> match (Symbol \<phi>)"]
    by simp
  then have "\<forall>k \<in> {j..<i}. sat \<phi> (Suc k)"
    by auto
  then show "sat (Since \<phi> I \<psi>) i"
    using j_def(1,2,4) Ball_atLeastLessThan_reindex[of j i "sat \<phi>"]
    by auto
qed

lemma until_rewrite: "sat (Until \<phi> I \<psi>) i \<longleftrightarrow> sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
proof (rule iffI)
  assume "sat (Until \<phi> I \<psi>) i"
  then obtain j where j_def: "j \<ge> i" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I" "sat \<psi> j"
    "\<forall>k \<in> {i..<j}. sat \<phi> k"
    by auto
  have "k \<in> {i..<j} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)" for k
    using j_def(4)
    by auto
  then have "(i, j) \<in> (match (Symbol \<phi>))\<^sup>*"
    using j_def(1) trancl_Base
    by simp
  then show "sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
    using j_def(1,2,3)
    by auto
next
  assume "sat (MatchF I (Times (Star (Symbol \<phi>)) (Symbol \<psi>))) i"
  then obtain j where j_def: "j \<ge> i" "mem (\<tau> \<sigma> i) (\<tau> \<sigma> j) I" "(i, j) \<in> (match (Symbol \<phi>))\<^sup>*" "sat \<psi> j"
    by auto
  have "\<And>k. k \<in> {i..<j} \<Longrightarrow> (k, Suc k) \<in> match (Symbol \<phi>)"
    using j_def(3) trancl_Base[of "\<lambda>k. (k, Suc k) \<in> match (Symbol \<phi>)"]
    by auto
  then have "\<forall>k \<in> {i..<j}. sat \<phi> k"
    by simp
  then show "sat (Until \<phi> I \<psi>) i"
    using j_def(1,2,4)
    by auto
qed

lemma match_le: "(i, j) \<in> match r \<Longrightarrow> i \<le> j"
proof (induction r arbitrary: i j)
  case (Times r s)
  then show ?case using order.trans by fastforce
next
  case (Star r)
  from Star.prems show ?case
    unfolding match.simps
    by (induct i j rule: rtrancl.induct) (force dest: Star.IH)+
qed auto

lemma match_Times: "(i, i + n) \<in> match (Times r s) \<longleftrightarrow>
  (\<exists>k \<le> n. (i, i + k) \<in> match r \<and> (i + k, i + n) \<in> match s)"
  using match_le by auto (metis le_iff_add nat_add_left_cancel_le)

lemma rtrancl_unfold: "(x, z) \<in> rtrancl R \<Longrightarrow>
  x = z \<or> (\<exists>y. (x, y) \<in> R \<and> x \<noteq> y \<and> (y, z) \<in> rtrancl R)"
  by (induction x z rule: rtrancl.induct) auto

lemma rtrancl_unfold': "(x, z) \<in> rtrancl R \<Longrightarrow>
  x = z \<or> (\<exists>y. (x, y) \<in> rtrancl R \<and> y \<noteq> z \<and> (y, z) \<in> R)"
  by (induction x z rule: rtrancl.induct) auto

lemma match_Star: "(i, i + Suc n) \<in> match (Star r) \<longleftrightarrow>
  (\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and> (i + 1 + k, i + Suc n) \<in> match (Star r))"
proof (rule iffI)
  assume assms: "(i, i + Suc n) \<in> match (Star r)"
  obtain k where k_def: "(i, k) \<in> local.match r" "i \<le> k" "i \<noteq> k"
    "(k, i + Suc n) \<in> (local.match r)\<^sup>*"
    using rtrancl_unfold[OF assms[unfolded match.simps]] match_le by auto
  from k_def(4) have "(k, i + Suc n) \<in> match (Star r)"
    unfolding match.simps by simp
  then have k_le: "k \<le> i + Suc n"
    using match_le by blast
  from k_def(2,3) obtain k' where k'_def: "k = i + Suc k'"
    by (metis Suc_diff_Suc le_add_diff_inverse le_neq_implies_less)
  show "\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and> (i + 1 + k, i + Suc n) \<in> match (Star r)"
    using k_def k_le unfolding k'_def by auto
next
  assume assms: "\<exists>k \<le> n. (i, i + 1 + k) \<in> match r \<and>
    (i + 1 + k, i + Suc n) \<in> match (Star r)"
  then show "(i, i + Suc n) \<in> match (Star r)"
    by (induction n) auto
qed

lemma match_refl_eps: "(i, i) \<in> match r \<Longrightarrow> eps r"
proof (induction r)
  case (Times r s)
  then show ?case
    using match_Times[where ?i=i and ?n=0]
    by auto
qed auto

lemma wf_regex_eps_match: "wf_regex r \<Longrightarrow> eps r \<Longrightarrow> (i, i) \<in> match r"
  by (induction r arbitrary: i) auto

lemma match_Star_unfold: "i < j \<Longrightarrow> (i, j) \<in> match (Star r) \<Longrightarrow> \<exists>k \<in> {i..<j}. (i, k) \<in> match (Star r) \<and> (k, j) \<in> match r"
  using rtrancl_unfold'[of i j "match r"] match_le[of _ j r] match_le[of i _ "Star r"]
  by auto (meson atLeastLessThan_iff order_le_less)

lemma match_rderive: "wf_regex r \<Longrightarrow> i \<le> j \<Longrightarrow> (i, Suc j) \<in> match r \<longleftrightarrow> (i, j) \<in> match (rderive r)"
proof (induction r arbitrary: i j)
  case (Times r1 r2)
  then show ?case
    using match_refl_eps[of "Suc j" r2] match_le[of _ "Suc j" r2]
    apply (auto)
          apply (metis le_Suc_eq relcomp.simps)
         apply (meson match_le relcomp.simps)
        apply (metis le_SucE relcomp.simps)
       apply (meson relcomp.relcompI wf_regex_eps_match)
      apply (meson match_le relcomp.simps)
     apply (metis le_SucE relcomp.simps)
    apply (meson match_le relcomp.simps)
    done
next
  case (Star r)
  then show ?case
    using match_Star_unfold[of i "Suc j" r]
    by auto (meson match_le rtrancl.simps)
qed auto

end

lemma atms_nonempty: "atms r \<noteq> {}"
  by (induction r) auto

lemma atms_finite: "finite (atms r)"
  by (induction r) auto

lemma progress_le_ts:
  assumes "\<And>t. t \<in> set ts \<Longrightarrow> t \<in> tfin"
  shows "progress phi ts \<le> length ts"
  using assms
proof (induction phi ts rule: progress.induct)
  case (8 phi I psi ts)
  have "ts \<noteq> [] \<Longrightarrow> Min {j. j \<le> min (length ts - Suc 0) (min (progress phi ts) (progress psi ts)) \<and>
    memR (ts ! j) (ts ! min (length ts - Suc 0) (min (progress phi ts) (progress psi ts))) I}
    \<le> length ts"
    apply (rule le_trans[OF Min_le[where ?x="min (length ts - Suc 0) (min (progress phi ts) (progress psi ts))"]])
      apply (auto simp: in_set_conv_nth intro!: memR_tfin_refl 8(3))
    apply (metis One_nat_def diff_less length_greater_0_conv less_numeral_extra(1) min.commute min.strict_coboundedI2)
    done
  then show ?case
    by auto
next
  case (9 I r ts)
  then show ?case
    using atms_nonempty[of r] atms_finite[of r]
    by auto (meson Min_le dual_order.trans finite_imageI image_iff)
next
  case (10 I r ts)
  have "ts \<noteq> [] \<Longrightarrow> Min {j. j \<le> min (length ts - Suc 0) (MIN f\<in>atms r. progress f ts) \<and>
    memR (ts ! j) (ts ! min (length ts - Suc 0) (MIN f\<in>atms r. progress f ts)) I}
    \<le> length ts"
    apply (rule le_trans[OF Min_le[where ?x="min (length ts - Suc 0) (Min ((\<lambda>f. progress f ts) ` atms r))"]])
      apply (auto simp: in_set_conv_nth intro!: memR_tfin_refl 10(2))
    apply (metis One_nat_def diff_less length_greater_0_conv less_numeral_extra(1) min.commute min.strict_coboundedI2)
    done
  then show ?case
    by auto
qed (auto split: nat.splits)

end


section "Algebraic laws for designs"
theory algebraic_laws_designs
imports "../theories/utp_fault_designs"

begin
named_theorems symbolic_exec_cp

subsection"Throw"

lemma throw_left_zero[simp]:
  "(THROW ;; Simpl P) = THROW"
  by rel_auto blast+

lemma throw_right_zero_skip[simp]:
  "(SKIP ;; THROW) = THROW "
  by rel_auto blast+

lemma throw_idem [simp]:
  "(THROW ;; THROW) = THROW "
  by rel_auto blast+

subsection"Skip"

text{*In this section we introduce the algebraic laws of programming related to the SKIP
      statement.*}

lemma skip_c_idem [simp]:
  "(SKIP ;; SKIP) = SKIP"
  by rel_auto blast+

lemma skip_c_left_unit[simp]:
  "(SKIP ;;  Simpl P) =  Simpl P"
  by rel_auto (blast, metis)

lemma skip_c_right_unit[simp]:
  "(Simpl P  ;;  SKIP) =  Simpl P"
  by rel_auto (metis option.exhaust_sel)+

lemma skip_c_lift_alpha_eq:
  "\<lceil>II\<rceil>\<^sub>C = ($\<Sigma>\<^sub>C\<acute> =\<^sub>u $\<Sigma>\<^sub>C)"
  by rel_auto

lemma skip_c_alpha_eq:
  "SKIP = Simpl (\<not>$abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and>$fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> ($\<Sigma>\<^sub>C\<acute> =\<^sub>u $\<Sigma>\<^sub>C))"
  by (simp add: skip_c_lift_alpha_eq skip_c_def)

lemma pre_skip_c_post:
  "(Simpl \<lceil>b\<rceil>\<^sub>C\<^sub>< \<and> SKIP) = (SKIP \<and> Simpl \<lceil>b\<rceil>\<^sub>C\<^sub>>)"
  by rel_auto

lemma skip_c_var:
  fixes x :: "(bool, ('a, 'b) cp) uvar"
  shows "(Simpl $x \<and> SKIP) = (SKIP \<and> Simpl $x\<acute>)"
  by rel_auto

lemma assigns_c_id [simp]: "\<langle>id\<rangle>\<^sub>C = SKIP"
  by (rel_auto)

lemma assign_c_alt_def [symbolic_exec_cp]:
  "\<langle>\<sigma>\<rangle>\<^sub>C = Simpl (\<not>$abrupt\<acute> \<and>\<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and>$fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright> \<and> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II\<rceil>\<^sub>C)"
  by rel_auto

subsection {*Assignment Laws*}
text{*In this section we introduce the algebraic laws of programming related to the assignment
      statement.*}

lemma usubst_c_cancel [usubst,symbolic_exec_cp]:
  assumes 1:"weak_lens v"
  shows "($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub>C\<^sub></$v\<rbrakk>= \<lceil>expr\<rceil>\<^sub>C\<^sub><"
  using 1
  by  rel_auto

lemma usubst_c_lift_cancel[usubst,symbolic_exec_cp]:
  assumes 1:"weak_lens v"
  shows "\<lceil>($v)\<lbrakk>\<lceil>expr\<rceil>\<^sub></$v\<rbrakk>\<rceil>\<^sub>C= \<lceil>expr\<rceil>\<^sub>C\<^sub><"
  using 1
  by  rel_auto

lemma assigns_c_comp: "(\<langle>f\<rangle>\<^sub>C ;; \<langle>g\<rangle>\<^sub>C) = \<langle>g \<circ> f\<rangle>\<^sub>C"
  by rel_auto blast+

lemma assign_test[symbolic_exec_cp]:
  assumes 1:"mwb_lens x"
  shows     "(x \<Midarrow> \<guillemotleft>u\<guillemotright> ;; x \<Midarrow> \<guillemotleft>v\<guillemotright>) = (x \<Midarrow> \<guillemotleft>v\<guillemotright>)"
  using 1
  by (simp add: assigns_c_comp subst_upd_comp subst_lit usubst_upd_idem)

lemma assign_c_left_comp:
  "(\<langle>\<sigma>\<rangle>\<^sub>C ;; Simpl(\<lceil>P\<rceil>\<^sub>C \<turnstile> \<lceil>Q\<rceil>\<^sub>C)) = Simpl(\<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P\<rceil>\<^sub>C \<turnstile> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> Q\<rceil>\<^sub>C)"
  by rel_auto blast+

lemma assign_c_left_comp_subst[symbolic_exec_cp]:
  "(x \<Midarrow> u ;; Simpl(\<lceil>P\<rceil>\<^sub>C \<turnstile> \<lceil>Q\<rceil>\<^sub>C)) = Simpl(\<lceil>P\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>\<rceil>\<^sub>C \<turnstile> \<lceil>Q\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>\<rceil>\<^sub>C)"
  by rel_auto blast+

lemma assign_c_twice[symbolic_exec_cp]:
  assumes "mwb_lens x" and  "x \<sharp> f"
  shows "(x \<Midarrow> e ;; x \<Midarrow> f) = (x \<Midarrow> f)"
  using assms
  by (simp add: assigns_c_comp usubst)

lemma assign_c_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x \<Midarrow> e ;; y \<Midarrow> f) = (y \<Midarrow> f ;; x \<Midarrow> e)"
proof -
  have "(x :== e ;; y :== f ) = y :== f ;; x :== e"
    using assms assign_commute by auto
  then show ?thesis
    using assigns_c_comp assigns_c_def utp_urel_laws.assigns_comp
    by metis
qed

lemma assign_c_cond_c[symbolic_exec_cp]:
   fixes x :: "('a, '\<alpha>) uvar"
  shows "(x \<Midarrow> e ;; (bif b then Simpl P else Simpl Q eif)) =
         (bif (b\<lbrakk>e/x\<rbrakk>) then (x \<Midarrow> e ;; Simpl P)  else (x \<Midarrow> e ;; Simpl Q) eif)"

  (*apply rel_auto  apply (metis option.distinct(1)*)
oops

lemma assign_c_uop1[symbolic_exec_cp]:
  assumes 1: "mwb_lens v"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (uop F (&v))) = (v \<Midarrow> (uop F e1))"
  by (simp add: assigns_c_comp assms subst_uop subst_upd_comp subst_var
                usubst_lookup_upd usubst_upd_idem)

lemma assign_c_bop1[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow>(bop bp (&v) e2)) = (v \<Midarrow> (bop bp e1 e2))"
  using 1 2
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_bop2[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (bop bp e2 (&v))) = (v \<Midarrow> (bop bp e2 e1))"
  using 1 2
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_trop1[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp (&v) e2 e3)) =
         (v \<Midarrow> (trop tp e1 e2 e3))"
  using 1 2 3
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_trop2[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp e2 (&v) e3)) =
         (v \<Midarrow> (trop tp e2 e1 e3))"
  using 1 2 3
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_trop3[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (trop tp e2 e3 (&v))) =
         (v \<Midarrow> (trop tp e2 e3 e1))"
  using 1 2 3
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_qtop1[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp (&v) e2 e3 e4)) =
         (v \<Midarrow> (qtop tp e1 e2 e3 e4))"
  using 1 2 3 4
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_qtop2[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 (&v) e3 e4)) =
         (v \<Midarrow> (qtop tp e2 e1 e3 e4))"
  using 1 2 3 4
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_qtop3[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 e3 (&v) e4)) =
         (v \<Midarrow> (qtop tp e2 e3 e1 e4))"
  using 1 2 3 4
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_qtop4[symbolic_exec_cp]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v \<Midarrow> e1 ;; v \<Midarrow> (qtop tp e2 e3 e4 (&v))) =
         (v \<Midarrow> (qtop tp e2 e3 e4 e1))"
  using 1 2 3 4
  by rel_auto (blast, metis mwb_lens.put_put mwb_lens_weak weak_lens.put_get)

lemma assign_c_cond_seqr_dist[symbolic_exec_cp]:
  "(bif (b\<lbrakk>e/v\<rbrakk>) then (v \<Midarrow> e ;; Simpl P) else (v \<Midarrow> e ;; Simpl Q) eif) =
   (v \<Midarrow> e ;; bif b then Simpl P else Simpl Q eif)"
  by (metis assign_c_cond_c)

text {*In the sequel we define assignment laws proposed by Hoare*}

lemma assign_c_vwb_skip_c:
  assumes 1: "vwb_lens v"
  shows "(v \<Midarrow> &v) = SKIP"
  by (simp add: assms  usubst_upd_var_id)

lemma assign_c_simultaneous:
  assumes  1: "vwb_lens var2"
  and      2: "var1 \<bowtie> var2"
  shows "var1, var2 \<Midarrow> exp, &var2 = var1 \<Midarrow> exp"
  by (simp add: "1" "2" usubst_upd_comm usubst_upd_var_id)

lemma assign_c_seq:
  assumes  1: "vwb_lens var2"
  shows"(var1 \<Midarrow> exp);; (var2 \<Midarrow> &var2) = (var1 \<Midarrow> exp)"
  using 1 by rel_auto (blast, metis)

lemma assign_c_cond_c_uop[symbolic_exec_cp]:
  assumes 1: "weak_lens v"
  shows "bif uop F exp then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
          v \<Midarrow> exp ;; bif uop F (&v) then Simpl C1 else Simpl C2 eif"
proof -
  have "uop F exp = uop F ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>)"
    by (metis (no_types) assms  usubst_cancel)
  then show ?thesis
  by (smt assign_c_cond_seqr_dist subst_uop)
qed

lemma assign_c_cond_bop1[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "bif bop bp exp exp2 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
          v \<Midarrow> exp ;; bif bop bp (&v) exp2 then Simpl C1 else Simpl C2 eif"
 proof -
  have "bop bp exp exp2 = bop bp ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp2"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_bop
    by (metis (no_types, hide_lams) "2" id_subst pr_var_def subst_unrest)
qed

lemma assign_c_cond_bop2[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "bif bop bp exp2 exp then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
          v \<Midarrow> exp ;; bif bop bp  exp2 (&v) then Simpl C1 else Simpl C2 eif"
 proof -
  have "bop bp exp2 exp  = bop bp  exp2 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>)"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_bop
    by (metis (no_types, hide_lams) "2" id_subst pr_var_def subst_unrest)
qed

lemma assign_cond_trop1[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp exp2 exp3 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif trop bp (&v) exp2 exp3 then Simpl C1 else Simpl C2 eif"
 proof -
  have "trop bp exp exp2 exp3 = trop bp ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp2 exp3"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_trop
    by (metis (no_types, hide_lams) "2" "3" id_subst pr_var_def subst_unrest)
qed

lemma assign_cond_trop2[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp2 exp  exp3 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif trop bp  exp2 (&v) exp3 then Simpl C1 else Simpl C2 eif"
 proof -
  have "trop bp exp2 exp exp3 = trop bp exp2 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp3"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_trop
    by (metis (no_types, hide_lams) "2" "3" id_subst pr_var_def subst_unrest)
qed

lemma assign_cond_trop3[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "bif trop bp exp2 exp3 exp then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif trop bp exp2 exp3 (&v)  then Simpl C1 else Simpl C2 eif"
 proof -
  have "trop bp exp2 exp3 exp  = trop bp exp2 exp3 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>)"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_trop
    by (metis (no_types, hide_lams) "2" "3" id_subst pr_var_def subst_unrest)
qed

lemma assign_cond_qtop1[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp exp2 exp3 exp4 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif qtop bp (&v) exp2 exp3 exp4 then Simpl C1 else Simpl C2 eif"
 proof -
  have "qtop bp exp exp2 exp3 exp4 = qtop bp ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp2 exp3 exp4"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_qtop
    by (metis (no_types, hide_lams) "2" "3" "4" id_subst pr_var_def subst_unrest)
qed

lemma assign_c_cond_qtop2[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4:"v \<sharp> exp4"
  shows "bif qtop bp exp2 exp  exp3 exp4 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2 (&v) exp3 exp4 then Simpl C1 else Simpl C2 eif"
 proof -
  have "qtop bp exp2 exp exp3 exp4 = qtop bp exp2 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp3 exp4"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_qtop
    by (metis (no_types, hide_lams) "2" "3" "4" id_subst pr_var_def subst_unrest)
qed

lemma assign_c_cond_qtop3[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp2 exp3 exp exp4 then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2  exp3 (&v) exp4 then Simpl C1 else Simpl C2 eif"
 proof -
  have "qtop bp exp2 exp3 exp  exp4 = qtop bp exp2  exp3 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>) exp4"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_qtop
    by (metis (no_types, hide_lams) "2" "3" "4" id_subst pr_var_def subst_unrest)
qed

lemma assign_c_cond_qtop4[symbolic_exec_cp]:
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "bif qtop bp exp2 exp3 exp4 exp then (v \<Midarrow> exp ;; Simpl C1) else (v \<Midarrow> exp ;; Simpl C2) eif =
         v \<Midarrow> exp ;; bif qtop bp exp2  exp3 exp4 (&v)  then Simpl C1 else Simpl C2 eif"
 proof -
  have "qtop bp exp2 exp3 exp4 exp = qtop bp exp2 exp3 exp4 ((&v::('a, 'b) uexpr)\<lbrakk>exp/v\<rbrakk>)"
    by (metis (no_types) assms(1)  usubst_cancel)
  then show ?thesis
    using assign_c_cond_seqr_dist subst_qtop
    by (metis (no_types, hide_lams) "2" "3" "4" id_subst pr_var_def subst_unrest)
qed

lemma assign_c_cond_If [symbolic_exec_cp]:
  "(bif bexp then (v \<Midarrow> exp1) else (v \<Midarrow> exp2) eif) =
   (v \<Midarrow> (trop If bexp exp1 exp2))"
  by rel_auto

subsection {*While laws*}
text{*In this section we introduce the algebraic laws of programming related to the while
      statement.*}

theorem while_unfold:
  "while b do P od = (bif b then (P ;; while b do P od) else SKIP eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (P ;; X) else SKIP eif)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while b do P od) = (\<nu> X \<bullet> bif b then (P ;; X) else SKIP eif)"
    by (simp add: While_def)
  also have "... = (bif b then (P ;; (\<nu> X \<bullet> bif b then (P ;; X) else SKIP eif)) else SKIP eif)"
    by (subst lfp_unfold, simp_all add: m)
  also have "... = (bif b then (P ;; while b do P od) else SKIP eif)"
    by (simp add: While_def)
  finally show ?thesis .
qed

lemma while_true:
  shows "(while true do P od) = false"
  apply (simp add: While_def alpha)
  apply (rule antisym)
  apply (simp_all)
  apply (rule lfp_lowerbound)
  apply (simp)
done

lemma while_false:
  shows "(while false do P od) = SKIP"
proof -
  have "(while false do P od) = bif false then (P ;; while false do P od) else SKIP eif"
    using while_unfold[of _ P] by simp
  also have "... = SKIP" by (simp add: aext_false)
  finally show ?thesis .
qed

lemma while_inv_unfold:
  "while b invr p do P od = (bif b then (P ;; while b invr p do P od) else SKIP eif)"
  unfolding While_inv_def using while_unfold
  by auto

theorem while_bot_unfold:
  "while\<^sub>\<bottom> b do P od = (bif b then (P ;; while\<^sub>\<bottom> b do P od) else SKIP eif)"
proof -
  have m:"mono (\<lambda>X. bif b then (P ;; X) else SKIP eif)"
    by (auto intro: monoI seqr_mono cond_mono)
  have "(while\<^sub>\<bottom> b do P od) = (\<mu> X \<bullet> bif b then (P ;; X) else SKIP eif)"
    by (simp add: While_bot_def)
  also have "... = (bif b then (P ;; (\<mu> X \<bullet> bif b then (P ;; X) else SKIP eif)) else SKIP eif)"
    by (subst gfp_unfold, simp_all add: m)
  also have "... = (bif b then (P ;; while\<^sub>\<bottom> b do P od) else SKIP eif)"
    by (simp add: While_bot_def)
  finally show ?thesis .
qed

theorem while_bot_false: "while\<^sub>\<bottom> false do P od = SKIP"
  by (simp add: While_bot_def mu_const alpha)

theorem while_bot_true: "while\<^sub>\<bottom> true do P od = (\<mu> X \<bullet> P ;; X)"
  by (simp add: While_bot_def alpha)

subsection {*assume laws*}

lemma assume_twice: "(b\<^sup>\<top>\<^sup>C ;; c\<^sup>\<top>\<^sup>C) = (b \<and> c)\<^sup>\<top>\<^sup>C"
  by (rel_auto) (blast, blast, blast, metis not_None_eq)

end


subsection \<open>AndNode Phase\<close>

theory AndPhase
  imports
    Common
    Proofs.StampEvalThms
begin

context stamp_mask
begin

lemma AndRightFallthrough: "(((and (not (\<down> x)) (\<up> y)) = 0)) \<longrightarrow> exp[x & y] \<ge> exp[y]"
  apply simp apply (rule impI; (rule allI)+)
  apply (rule impI)
  subgoal premises p for m p v
  proof -
    obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
      using p(2) by blast
    obtain yv where yv: "[m, p] \<turnstile> y \<mapsto> yv"
      using p(2) by blast
    have "v = val[xv & yv]"
      by (metis BinaryExprE bin_eval.simps(4) evalDet p(2) xv yv)
    then have "v = yv"
      by (smt (verit) eval_unused_bits_zero intval_and.elims new_int.elims new_int_bin.elims p(2)
          unfold_binary xv yv p(1) not_down_up_mask_and_zero_implies_zero)
    then show ?thesis using yv by simp
  qed
  done

lemma AndLeftFallthrough: "(((and (not (\<down> y)) (\<up> x)) = 0)) \<longrightarrow> exp[x & y] \<ge> exp[x]"
  apply simp apply (rule impI; (rule allI)+)
  apply (rule impI)
  subgoal premises p for m p v
  proof -
    obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
      using p(2) by blast
    obtain yv where yv: "[m, p] \<turnstile> y \<mapsto> yv"
      using p(2) by blast
    have "v = val[xv & yv]"
      by (metis BinaryExprE bin_eval.simps(4) evalDet p(2) xv yv)
    then have "v = xv"
      by (smt (verit) and.commute eval_unused_bits_zero intval_and.elims new_int.simps
          new_int_bin.simps p(2) unfold_binary xv yv p(1) not_down_up_mask_and_zero_implies_zero)
    then show ?thesis using xv by simp
  qed
  done
end

phase AndNode
  terminating size
begin

(* Word level proofs *)
lemma bin_and_nots:
 "(~x & ~y) = (~(x | y))"
  by simp

lemma bin_and_neutral:
 "(x & ~False) = x"
  by simp

(* Value level proofs *)
lemma val_and_equal:
  assumes "x = new_int b v"
  and     "val[x & x] \<noteq> UndefVal"
  shows   "val[x & x] = x"
   using assms by (cases x; auto)

lemma val_and_nots:
  "val[~x & ~y] = val[~(x | y)]"
  apply (cases x; cases y; auto) by (simp add: take_bit_not_take_bit)

lemma val_and_neutral:
  assumes "x = new_int b v"
  and     "val[x & ~(new_int b' 0)] \<noteq> UndefVal"
  shows   "val[x & ~(new_int b' 0)] = x"
   using assms apply (cases x; auto) apply (simp add: take_bit_eq_mask)
   by presburger

(* Not sure if this one is written correctly *)
(*
lemma val_and_sign_extend:
  assumes "e = (1 << In)-1"
  shows "val[(intval_sign_extend In Out x) & (IntVal b e)] = intval_zero_extend In Out x"
  using assms apply (cases x; auto)
  sorry

lemma val_and_sign_extend_2:
  assumes "e = (1 << In)-1 \<and> intval_and (intval_sign_extend In Out x) (IntVal 32 e) \<noteq> UndefVal"
  shows "val[(intval_sign_extend In Out x) &  (IntVal 32 e)] = intval_zero_extend In Out x"
  using assms apply (cases x;  auto)
  sorry*)

(* Extras which were missing *)
lemma val_and_zero:
  assumes "x = new_int b v"
  shows   "val[x & (IntVal b 0)] = IntVal b 0"
   using assms by (cases x; auto)

(* Exp level proofs *)
lemma exp_and_equal:
  "exp[x & x] \<ge> exp[x]"
   apply auto
  by (smt (verit) evalDet intval_and.elims new_int.elims val_and_equal eval_unused_bits_zero)

lemma exp_and_nots:
  "exp[~x & ~y] \<ge> exp[~(x | y)]"
   apply (cases x; cases y; auto) using val_and_nots
  by fastforce+

lemma exp_sign_extend:
  assumes "e = (1 << In) - 1"
  shows   "BinaryExpr BinAnd (UnaryExpr (UnarySignExtend In Out) x)
                             (ConstantExpr (new_int b e))
                           \<ge> (UnaryExpr (UnaryZeroExtend In Out) x)"
  apply auto
  subgoal premises p for m p va
    proof -
      obtain va where va: "[m,p] \<turnstile> x \<mapsto> va"
        using p(2) by auto
      then have "va \<noteq> UndefVal"
        by (simp add: evaltree_not_undef)
      then have 1: "intval_and (intval_sign_extend In Out va) (IntVal b (take_bit b e)) \<noteq> UndefVal"
        using evalDet p(1) p(2) va by blast
      then have 2: "intval_sign_extend In Out va \<noteq> UndefVal"
        by auto
      then have 21: "(0::nat) < b"
        using eval_bits_1_64 p(4) by blast
      then have 3: "b \<sqsubseteq> (64::nat)"
        using eval_bits_1_64 p(4) by blast
      then have 4: "- ((2::int) ^ b div (2::int)) \<sqsubseteq> sint (signed_take_bit (b - Suc (0::nat)) (take_bit b e))"
        by (simp add: "21" int_power_div_base signed_take_bit_int_greater_eq_minus_exp_word)
      then have 5: "sint (signed_take_bit (b - Suc (0::nat)) (take_bit b e)) < (2::int) ^ b div (2::int)"
        by (simp add: "21" "3" Suc_le_lessD int_power_div_base signed_take_bit_int_less_exp_word)
      then have 6: "[m,p] \<turnstile> UnaryExpr (UnaryZeroExtend In Out)
                 x \<mapsto> intval_and (intval_sign_extend In Out va) (IntVal b (take_bit b e))"
        apply (cases va; simp)
        apply (simp add: \<open>(va::Value) \<noteq> UndefVal\<close>) defer
         subgoal premises p for x3
          proof -
            have "va = ObjRef x3"
              using p(1) by auto
            then have "sint (signed_take_bit (b - Suc (0::nat)) (take_bit b e)) < (2::int) ^ b div (2::int)"
              by (simp add: "5")
            then show ?thesis
              using "2" intval_sign_extend.simps(3) p(1) by blast
          qed

         subgoal premises p for x4
          proof -
            have sg1: "va = ObjStr x4"
              using "2" p(1) by auto
            then have "sint (signed_take_bit (b - Suc (0::nat)) (take_bit b e)) < (2::int) ^ b div (2::int)"
              by (simp add: "5")
            then show ?thesis
              using "1" sg1 by auto
          qed

          (* Last subgoal*)
          subgoal premises p for x21 x22
            proof -
              have sgg1: "va = IntVal x21 x22"
                by (simp add: p(1))
              then have sgg2: "sint (signed_take_bit (b - Suc (0::nat)) (take_bit b e)) < (2::int) ^ b div (2::int)"
                by (simp add: "5")
              then show ?thesis
                sorry
              qed
            done
      then show ?thesis
        by (metis evalDet p(2) va)
    qed
  done

(*lemma exp_and_neutral:
  "exp[x & ~(const (new_int b 0))] \<ge> x"
  apply auto using val_and_neutral eval_unused_bits_zero sorry (*
  apply (cases x; simp) using val_and_neutral bin_eval.simps(4)
  apply (smt (verit) BinaryExprE Value.collapse(1) intval_and.simps(12) intval_not.simps(2)
         is_IntVal_def unary_eval.simps(3) unary_eval_int unfold_const64 unfold_unary)
         using val_and_neutral_64 bin_eval.simps(4)
  apply (metis (no_types, lifting) BinaryExprE UnaryExprE Value.collapse(1) bin_eval_int
         intval_and.simps(12) intval_not.simps(2) is_IntVal_def unary_eval.simps(3) unfold_const64)
         using val_and_neutral_64 bin_eval.simps(4) unary_eval.simps(3)
  apply (smt (z3) BinaryExprE UnaryExprE Value.discI(2) Value.distinct(9) intval_and.elims
         intval_not.simps(2) unfold_const64)
         using val_and_neutral_64 bin_eval.simps(4) unary_eval.simps(3) bin_and_neutral
               unfold_const64 intval_and.elims intval_not.simps(2)
         sorry*)*)

(* Helpers *)
lemma val_and_commute[simp]:
   "val[x & y] = val[y & x]"
   apply (cases x; cases y; auto)
  by (simp add: word_bw_comms(1))

text \<open>Optimisations\<close>

optimization AndEqual: "x & x \<longmapsto> x"
  using exp_and_equal by blast

optimization AndShiftConstantRight: "((const x) & y) \<longmapsto> y & (const x)
                                         when \<not>(is_ConstantExpr y)"
  using size_flip_binary by auto

optimization AndNots: "(~x) & (~y) \<longmapsto> ~(x | y)"
   apply (metis add_2_eq_Suc' less_SucI less_add_Suc1 not_less_eq size_binary_const size_non_add)
  using exp_and_nots by auto

(* Need to prove exp_sign_extend*)
optimization AndSignExtend: "BinaryExpr BinAnd (UnaryExpr (UnarySignExtend In Out) (x))
                                               (const (new_int b e))
                              \<longmapsto> (UnaryExpr (UnaryZeroExtend In Out) (x))
                                  when (e = (1 << In) - 1)"
   using exp_sign_extend by simp

optimization AndNeutral: "(x & ~(const (IntVal b 0))) \<longmapsto> x
   when (wf_stamp x \<and> stamp_expr x = IntegerStamp b lo hi)"
   apply auto
  by (smt (verit) Value.sel(1) eval_unused_bits_zero intval_and.elims intval_word.simps
      new_int.simps new_int_bin.simps take_bit_eq_mask)

optimization AndRightFallThrough: "(x & y) \<longmapsto> y
                                when (((and (not (IRExpr_down x)) (IRExpr_up y)) = 0))"
  by (simp add: IRExpr_down_def IRExpr_up_def)

optimization AndLeftFallThrough: "(x & y) \<longmapsto> x
                                when (((and (not (IRExpr_down y)) (IRExpr_up x)) = 0))"
   by (simp add: IRExpr_down_def IRExpr_up_def)

end (* End of AndPhase *)

end (* End of file *)


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM

Is there an optimal order of arguments for `next'?
Currently we can have laws like `delta A (a#w) = delta A w o delta A a'
Otherwise we could have `acceps A == fin A o delta A (start A)'
and use foldl instead of foldl2.
*)

header "Projection functions for automata"

theory AutoProj
imports Main
begin

definition start :: "'a * 'b * 'c => 'a" where "start A = fst A"
definition "next" :: "'a * 'b * 'c => 'b" where "next A = fst(snd(A))"
definition fin :: "'a * 'b * 'c => 'c" where "fin A = snd(snd(A))"

lemma [simp]: "next(q,d,f) = d"
by(simp add:next_def)

lemma [simp]: "fin(q,d,f) = f"
by(simp add:fin_def)

end


(* Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Preliminaries\<close>

theory MFMC_Misc imports
  "HOL-Probability.Probability"
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Complete_Partial_Order2"
  "HOL-Library.Bourbaki_Witt_Fixpoint"
begin

hide_const (open) cycle
hide_const (open) path
hide_const (open) cut
hide_const (open) orthogonal

lemmas disjE [consumes 1, case_names left right, cases pred] = disjE

lemma inj_on_Pair2 [simp]: "inj_on (Pair x) A"
by(simp add: inj_on_def)

lemma inj_on_Pair1 [simp]: "inj_on (\<lambda>x. (x, y)) A"
by(simp add: inj_on_def)

lemma inj_map_prod': "\<lbrakk> inj f; inj g \<rbrakk> \<Longrightarrow> inj_on (map_prod f g) X"
by(rule subset_inj_on[OF prod.inj_map subset_UNIV])

lemma not_range_Inr: "x \<notin> range Inr \<longleftrightarrow> x \<in> range Inl"
by(cases x) auto

lemma not_range_Inl: "x \<notin> range Inl \<longleftrightarrow> x \<in> range Inr"
by(cases x) auto

lemma Chains_into_chain: "M \<in> Chains {(x, y). R x y} \<Longrightarrow> Complete_Partial_Order.chain R M"
by(simp add: Chains_def chain_def)

lemma chain_dual: "Complete_Partial_Order.chain (\<ge>) = Complete_Partial_Order.chain (\<le>)"
by(auto simp add: fun_eq_iff chain_def)

subsection \<open>@{typ ereal} legacy theorems\<close>

lemma Cauchy_real_Suc_diff:
  fixes X :: "nat \<Rightarrow> real" and x :: real
  assumes bounded: "\<And>n. \<bar>f (Suc n) - f n\<bar> \<le> (c / x ^ n)"
  and x: "1 < x"
  shows "Cauchy f"
proof(cases "c > 0")
  case c: True
  show ?thesis
  proof(rule metric_CauchyI)
    fix \<epsilon> :: real
    assume "0 < \<epsilon>"

    from bounded[of 0] x have c_nonneg: "0 \<le> c" by simp
    from x have "0 < ln x" by simp
    from reals_Archimedean3[OF this] obtain M :: nat
      where "ln (c * x) - ln (\<epsilon> * (x - 1)) < real M * ln x" by blast
    hence "exp (ln (c * x) - ln (\<epsilon> * (x - 1))) < exp (real M * ln x)" by(rule exp_less_mono)
    hence M: "c * (1 / x) ^ M / (1 - 1 / x) < \<epsilon>" using \<open>0 < \<epsilon>\<close> x c
      by (simp add: exp_diff exp_of_nat_mult field_simps del: ln_mult)

    { fix n m :: nat
      assume "n \<ge> M" "m \<ge> M"
      then have "\<bar>f m - f n\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ max m n) / (1 - 1 / x)"
      proof(induction n m rule: linorder_wlog)
        case sym thus ?case by(simp add: abs_minus_commute max.commute min.commute)
      next
        case (le m n)
        then show ?case
        proof(induction k\<equiv>"n - m" arbitrary: n m)
          case 0 thus ?case using x c_nonneg by(simp add: field_simps mult_left_mono)
        next
          case (Suc k m n)
          from \<open>Suc k = _\<close> obtain m' where m: "m = Suc m'" by(cases m) simp_all
          with \<open>Suc k = _\<close> Suc.prems have "k = m' - n" "n \<le> m'" "M \<le> n" "M \<le> m'" by simp_all
          hence "\<bar>f m' - f n\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ (max m' n)) / (1 - 1 / x)" by(rule Suc)
          also have "\<dots> = c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x)" using \<open>n \<le> m'\<close> by(simp add: max_def)
          moreover
          from bounded have "\<bar>f m - f m'\<bar> \<le> (c / x ^ m')" by(simp add: m)
          ultimately have "\<bar>f m' - f n\<bar> + \<bar>f m - f m'\<bar> \<le> c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x) + \<dots>" by simp
          also have "\<dots> \<le> c * ((1 / x) ^ M - (1 / x) ^ m) / (1 - 1 / x)" using m x by(simp add: field_simps)
          also have "\<bar>f m - f n\<bar> \<le> \<bar>f m' - f n\<bar> + \<bar>f m - f m'\<bar>"
            using abs_triangle_ineq4[of "f m' - f n" "f m - f m'"] by simp
          ultimately show ?case using \<open>n \<le> m\<close> by(simp add: max_def)
        qed
      qed
      also have "\<dots> < c * (1 / x) ^ M / (1 - 1 / x)" using x c by(auto simp add: field_simps)
      also have "\<dots> < \<epsilon>" using M .
      finally have "\<bar>f m - f n\<bar> < \<epsilon>" . }
    thus "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. dist (f m) (f n) < \<epsilon>" unfolding dist_real_def by blast
  qed
next
  case False
  with bounded[of 0] have [simp]: "c = 0" by simp
  have eq: "f m = f 0" for m
  proof(induction m)
    case (Suc m) from bounded[of m] Suc.IH show ?case by simp
  qed simp
  show ?thesis by(rule metric_CauchyI)(subst (1 2) eq; simp)
qed

lemma complete_lattice_ccpo_dual:
  "class.ccpo Inf (\<ge>) ((>) :: _ :: complete_lattice \<Rightarrow> _)"
by(unfold_locales)(auto intro: Inf_lower Inf_greatest)

lemma card_eq_1_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
using card_eq_SucD by auto

lemma nth_rotate1: "n < length xs \<Longrightarrow> rotate1 xs ! n = xs ! (Suc n mod length xs)"
apply(cases xs; clarsimp simp add: nth_append not_less)
apply(subgoal_tac "n = length list"; simp)
done

lemma set_zip_rightI: "\<lbrakk> x \<in> set ys; length xs \<ge> length ys \<rbrakk> \<Longrightarrow> \<exists>z. (z, x) \<in> set (zip xs ys)"
by(fastforce simp add: in_set_zip in_set_conv_nth simp del: length_greater_0_conv intro!: nth_zip conjI[rotated])

lemma map_eq_append_conv:
  "map f xs = ys @ zs \<longleftrightarrow> (\<exists>ys' zs'. xs = ys' @ zs' \<and> ys = map f ys' \<and> zs = map f zs')"
by(auto 4 4 intro: exI[where x="take (length ys) xs"] exI[where x="drop (length ys) xs"] simp add: append_eq_conv_conj take_map drop_map dest: sym)

lemma rotate1_append:
  "rotate1 (xs @ ys) = (if xs = [] then rotate1 ys else tl xs @ ys @ [hd xs])"
by(clarsimp simp add: neq_Nil_conv)

lemma in_set_tlD: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
by(cases xs) simp_all

lemma countable_converseI:
  assumes "countable A"
  shows "countable (converse A)"
proof -
  have "converse A = prod.swap ` A" by auto
  then show ?thesis using assms by simp
qed

lemma countable_converse [simp]: "countable (converse A) \<longleftrightarrow> countable A"
using countable_converseI[of A] countable_converseI[of "converse A"] by auto

lemma nn_integral_count_space_reindex:
  "inj_on f A \<Longrightarrow>(\<integral>\<^sup>+ y. g y \<partial>count_space (f ` A)) = (\<integral>\<^sup>+ x. g (f x) \<partial>count_space A)"
by(simp add: embed_measure_count_space'[symmetric] nn_integral_embed_measure' measurable_embed_measure1)

syntax
  "_nn_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>\<^sup>+ _\<in>_./ _)" [0, 51, 10] 10)
  "_nn_sum_UNIV" :: "pttrn \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add" ("(2\<Sum>\<^sup>+ _./ _)" [0, 10] 10)
translations
  "\<Sum>\<^sup>+ i\<in>A. b" \<rightleftharpoons> "CONST nn_integral (CONST count_space A) (\<lambda>i. b)"
  "\<Sum>\<^sup>+ i. b" \<rightleftharpoons> "\<Sum>\<^sup>+ i\<in>CONST UNIV. b"

inductive_simps rtrancl_path_simps:
  "rtrancl_path R x [] y"
  "rtrancl_path R x (a # bs) y"

definition restrict_rel :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where "restrict_rel A R = {(x, y)\<in>R. x \<in> A \<and> y \<in> A}"

lemma in_restrict_rel_iff: "(x, y) \<in> restrict_rel A R \<longleftrightarrow> (x, y) \<in> R \<and> x \<in> A \<and> y \<in> A"
by(simp add: restrict_rel_def)

lemma restrict_relE: "\<lbrakk> (x, y) \<in> restrict_rel A R; \<lbrakk> (x, y) \<in> R; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(simp add: restrict_rel_def)

lemma restrict_relI [intro!]: "\<lbrakk> (x, y) \<in> R; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> restrict_rel A R"
by(simp add: restrict_rel_def)

lemma Field_restrict_rel_subset: "Field (restrict_rel A R) \<subseteq> A \<inter> Field R"
by(auto simp add: Field_def in_restrict_rel_iff)

lemma Field_restrict_rel [simp]: "Refl R \<Longrightarrow> Field (restrict_rel A R) = A \<inter> Field R"
using Field_restrict_rel_subset[of A R]
by auto (auto simp add: Field_def dest: refl_onD)

lemma Partial_order_restrict_rel:
  assumes "Partial_order R"
  shows "Partial_order (restrict_rel A R)"
proof -
  from assms have "Refl R" by(simp add: order_on_defs)
  from Field_restrict_rel[OF this, of A] assms show ?thesis
    by(simp add: order_on_defs trans_def antisym_def)
      (auto intro: FieldI1 FieldI2 intro!: refl_onI simp add: in_restrict_rel_iff elim: refl_onD)
qed

lemma Chains_restrict_relD: "M \<in> Chains (restrict_rel A leq) \<Longrightarrow> M \<in> Chains leq"
by(auto simp add: Chains_def in_restrict_rel_iff)

lemma bourbaki_witt_fixpoint_restrict_rel:
  assumes leq: "Partial_order leq"
  and chain_Field: "\<And>M. \<lbrakk> M \<in> Chains (restrict_rel A leq); M \<noteq> {} \<rbrakk> \<Longrightarrow> lub M \<in> A"
  and lub_least: "\<And>M z. \<lbrakk> M \<in> Chains leq; M \<noteq> {}; \<And>x. x \<in> M \<Longrightarrow> (x, z) \<in> leq \<rbrakk> \<Longrightarrow> (lub M, z) \<in> leq"
  and lub_upper: "\<And>M z. \<lbrakk> M \<in> Chains leq; z \<in> M \<rbrakk> \<Longrightarrow> (z, lub M) \<in> leq"
  and increasing: "\<And>x. \<lbrakk> x \<in> A; x \<in> Field leq \<rbrakk> \<Longrightarrow> (x, f x) \<in> leq \<and> f x \<in> A"
  shows "bourbaki_witt_fixpoint lub (restrict_rel A leq) f"
proof
  show "Partial_order (restrict_rel A leq)" using leq by(rule Partial_order_restrict_rel)
next
  from leq have Refl: "Refl leq" by(simp add: order_on_defs)

  { fix M z
    assume M: "M \<in> Chains (restrict_rel A leq)"
    presume z: "z \<in> M"
    hence "M \<noteq> {}" by auto
    with M have lubA: "lub M \<in> A" by(rule chain_Field)
    from M have M': "M \<in> Chains leq" by(rule Chains_restrict_relD)
    then have *: "(z, lub M) \<in> leq" using z by(rule lub_upper)
    hence "lub M \<in> Field leq" by(rule FieldI2)
    with lubA show "lub M \<in> Field (restrict_rel A leq)" by(simp add: Field_restrict_rel[OF Refl])
    from Chains_FieldD[OF M z] have "z \<in> A" by(simp add: Field_restrict_rel[OF Refl])
    with * lubA show "(z, lub M ) \<in> restrict_rel A leq" by auto

    fix z
    assume upper: "\<And>x. x \<in> M \<Longrightarrow> (x, z) \<in> restrict_rel A leq"
    from upper[OF z] have "z \<in> Field (restrict_rel A leq)" by(auto simp add: Field_def)
    with Field_restrict_rel_subset[of A leq] have "z \<in> A" by blast
    moreover from lub_least[OF M' \<open>M \<noteq> {}\<close>] upper have "(lub M, z) \<in> leq"
      by(auto simp add: in_restrict_rel_iff)
    ultimately show "(lub M, z) \<in> restrict_rel A leq" using lubA by(simp add: in_restrict_rel_iff) }
  { fix x
    assume "x \<in> Field (restrict_rel A leq)"
    hence "x \<in> A" "x \<in> Field leq" by(simp_all add: Field_restrict_rel[OF Refl])
    with increasing[OF this] show "(x, f x) \<in> restrict_rel A leq" by auto }
  show "(SOME x. x \<in> M) \<in> M" "(SOME x. x \<in> M) \<in> M" if "M \<noteq> {}" for M :: "'a set"
    using that by(auto intro: someI)
qed

lemma Field_le [simp]: "Field {(x :: _ :: preorder, y). x \<le> y} = UNIV"
by(auto intro: FieldI1)

lemma Field_ge [simp]: "Field {(x :: _ :: preorder, y). y \<le> x} = UNIV"
by(auto intro: FieldI1)

lemma refl_le [simp]: "refl {(x :: _ :: preorder, y). x \<le> y}"
by(auto intro!: refl_onI simp add: Field_def)

lemma refl_ge [simp]: "refl {(x :: _ :: preorder, y). y \<le> x}"
by(auto intro!: refl_onI simp add: Field_def)

lemma partial_order_le [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x \<le> x'}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma partial_order_ge [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x' \<le> x}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma incseq_chain_range: "incseq f \<Longrightarrow> Complete_Partial_Order.chain (\<le>) (range f)"
apply(rule chainI; clarsimp)
 using linear by (auto dest: incseqD)

end