theory SKAT_Eval
  imports SKAT KAT_Module Set_Model
begin

type_synonym 'a mems = "(nat \<Rightarrow> 'a) set"

fun eval_bexpr ::
  "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a pred bexpr \<Rightarrow> 'b mem \<Rightarrow> bool"
  where
  "eval_bexpr D (BLeaf P) mem = eval_pred D mem P"
| "eval_bexpr D (P :+: Q) mem = (eval_bexpr D P mem \<or> eval_bexpr D Q mem)"
| "eval_bexpr D (P :\<cdot>: Q) mem = (eval_bexpr D P mem \<and> eval_bexpr D Q mem)"
| "eval_bexpr D (BNot P) mem = (\<not> eval_bexpr D P mem)"
| "eval_bexpr D BOne mem = True"
| "eval_bexpr D BZero mem = False"

definition filter_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "filter_set p X \<equiv> \<Union>x\<in>X. if p x then {x} else {}"

definition eval_bexpr_set :: "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a pred bexpr \<Rightarrow> 'b mems" where
  "eval_bexpr_set D P = {mem. eval_bexpr D P mem}"

fun eval_bexpr_set_ind :: "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a pred bexpr \<Rightarrow> 'b mems" where
  "eval_bexpr_set_ind D (BLeaf P) = {mem. eval_pred D mem P}"
| "eval_bexpr_set_ind D (P :+: Q) = eval_bexpr_set_ind D P \<union> eval_bexpr_set_ind D Q"
| "eval_bexpr_set_ind D (P :\<cdot>: Q) = eval_bexpr_set_ind D P \<inter> eval_bexpr_set_ind D Q"
| "eval_bexpr_set_ind D (BNot P) = - eval_bexpr_set_ind D P"
| "eval_bexpr_set_ind D BOne = UNIV"
| "eval_bexpr_set_ind D BZero = {}"

lemma "eval_bexpr_set_ind D P = eval_bexpr_set D P"
  by (induct P, auto simp add: eval_bexpr_set_def)

lemma filter_set_inter: "filter_set P a = a \<inter> filter_set P UNIV"
  by (auto simp add: filter_set_def) (metis empty_iff singleton_iff)+

definition set_mems :: "nat \<Rightarrow> ('a mem \<Rightarrow> 'a) \<Rightarrow> 'a mems \<Rightarrow> 'a mems" where
  "set_mems x f \<Delta> \<equiv> (\<lambda>mem. set_mem x (f mem) mem) ` \<Delta>"

definition assigns ::
  "('a::ranked_alphabet, 'b) interp \<Rightarrow> nat \<Rightarrow> 'a trm \<Rightarrow> 'b mems \<Rightarrow> 'b mems"
  where
  "assigns D x s mems = set_mems x (\<lambda>mem. eval_trm D mem s) mems"

lemma finite_set_mems: assumes "finite \<Delta>" shows "finite (set_mems x f \<Delta>)"
  by (induct rule: finite_subset_induct_var[OF assms(1), of "\<Delta>"], simp_all add: set_mems_def)

lemma card_set_mems: "finite \<Delta> \<Longrightarrow> card (set_mems X f \<Delta>) \<le> card \<Delta>"
  by (simp add: set_mems_def, smt card_image_le)

lemma assign_image: "assigns D x t mems = assign D x t ` mems"
  by (auto simp add: assigns_def set_mems_def assign_def[symmetric])

lemma eval_assigns1:
  assumes xy: "x \<noteq> y" and ys: "y \<notin> FV s"
  shows "assigns D y t (assigns D x s mems) = assigns D x s (assigns D y (t[x|s]) mems)"
  by (auto simp add: assign_image image_def, (metis eval_assign1 xy ys)+)

lemma eval_assigns2:
  assumes xy: "x \<noteq> y" and xs: "x \<notin> FV s"
  shows "assigns D y t (assigns D x s mems) =
         assigns D y (t[x|s]) (assigns D x s mems)"
  by (auto simp add: assign_image image_def, (metis eval_assign2 xy xs)+)

lemma eval_assigns3: "assigns D x t (assigns D x s mems) = assigns D x (t[x|s]) mems"
  by (auto simp add: assign_image image_def, (metis eval_assign3)+)

lemma eval_assigns4: "filter_set (\<lambda>mem. eval_pred D mem P) (assigns D x t \<Delta>) =
                         assigns D x t (filter_set (\<lambda>mem. eval_pred D mem (P[x|t])) \<Delta>)"
  by (auto simp add: assign_image image_def filter_set_def) (metis empty_iff eval_assign4 singleton_iff)+

lemma eval_assign4_bexpr:
  fixes D :: "('a::ranked_alphabet, 'b) interp"
  shows "eval_bexpr D P (assign D x t mem) = eval_bexpr D (bexpr_map (\<lambda>a. a[x|t]) P) mem"
  by (induct P, simp_all, rule eval_assign4, auto)
lemma eval_assigns4_bexpr:
  "filter_set (eval_bexpr D P) (assigns D x t \<Delta>) =
   assigns D x t (filter_set (eval_bexpr D (bexpr_map (\<lambda>a. a[x|t]) P)) \<Delta>)"
  apply (auto simp add: assign_image image_def filter_set_def)
  defer
  apply (metis eval_assign4_bexpr)
  apply (rule_tac x = xb in bexI)
  defer
  apply assumption
  apply auto
  apply (metis empty_iff singleton_iff)
  apply (subgoal_tac "eval_bexpr D P (assign D x t xb)")
  apply (metis eval_assign4_bexpr)
  by (metis empty_iff)

lemma "filter_set (eval_bexpr D P) \<Delta> = \<Delta> \<inter> eval_bexpr_set D P"
  by (auto simp add: filter_set_def eval_bexpr_set_def) (metis empty_iff singleton_iff)+

fun eval_skat_expr ::
  "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a skat_expr \<Rightarrow> 'b mems \<Rightarrow> 'b mems"
  where
  "eval_skat_expr D (SKAssign x s) \<Delta> = assigns D x s \<Delta>"
| "eval_skat_expr D (SKBool P) \<Delta> = filter_set (eval_bexpr D P) \<Delta>"
| "eval_skat_expr D (s \<odot> t) \<Delta> = eval_skat_expr D t (eval_skat_expr D s \<Delta>)"
| "eval_skat_expr D (s \<oplus> t) \<Delta> = eval_skat_expr D s \<Delta> \<union> eval_skat_expr D t \<Delta>"
| "eval_skat_expr D (SKStar s) \<Delta> = (\<Union>n. iter n (eval_skat_expr D s) \<Delta>)"
| "eval_skat_expr D SKOne \<Delta> = \<Delta>"
| "eval_skat_expr D SKZero \<Delta> = {}"

definition eval_power :: "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a skat_expr \<Rightarrow> nat \<Rightarrow> 'b mems \<Rightarrow> 'b mems"
  where "eval_power D s n \<Delta> = iter n (eval_skat_expr D s) \<Delta>"

lemma eval_star_power: "eval_skat_expr D (SKStar s) \<Delta> = \<Union> {y. \<exists>n. y = eval_power D s n \<Delta>}"
  by (auto simp add: eval_power_def)

lemma eval_iter1: "eval_skat_expr D s (iter n (eval_skat_expr D s) \<Delta>)
     = iter n (eval_skat_expr D s) (eval_skat_expr D s \<Delta>)"
  by (induct n, auto)

lemma eval_mod1: "eval_skat_expr D s {} = {}"
proof (induct s, simp_all add: assigns_def set_mems_def, intro allI)
  fix s n assume "eval_skat_expr D s {} = {}"
  thus "iter n (eval_skat_expr D s) {} = {}"
    by (induct n, auto)
next
  fix P show "filter_set (eval_bexpr D P) {} = {}"
    by (induct P, auto simp add: filter_set_def)
qed

lemma eval_mod2: "eval_skat_expr D s (\<Delta> \<union> \<Gamma>) = eval_skat_expr D s \<Delta> \<union> eval_skat_expr D s \<Gamma>"
  apply (induct s arbitrary: \<Delta> \<Gamma>, simp_all add: assigns_def set_mems_def filter_set_def)
  apply (metis image_Un)
  apply (metis Un_assoc Un_left_commute)
proof -
  fix s \<Delta> \<Gamma>
  assume asm: "\<And>\<Delta> \<Gamma>. eval_skat_expr D s (\<Delta> \<union> \<Gamma>) = eval_skat_expr D s \<Delta> \<union> eval_skat_expr D s \<Gamma>"
  have "\<And>n. iter n (eval_skat_expr D s) (\<Delta> \<union> \<Gamma>) = iter n (eval_skat_expr D s) \<Delta> \<union> iter n (eval_skat_expr D s) \<Gamma>"
  proof -
    fix n
    show "iter n (eval_skat_expr D s) (\<Delta> \<union> \<Gamma>) = iter n (eval_skat_expr D s) \<Delta> \<union> iter n (eval_skat_expr D s) \<Gamma>"
      by (induct n, simp_all, metis asm)
  qed
  hence "(\<Union>n. iter n (eval_skat_expr D s) (\<Delta> \<union> \<Gamma>)) = (\<Union>n. iter n (eval_skat_expr D s) \<Delta> \<union> iter n (eval_skat_expr D s) \<Gamma>)"
    by auto
  thus "(\<Union>n. iter n (eval_skat_expr D s) (\<Delta> \<union> \<Gamma>)) =
        (\<Union>n. iter n (eval_skat_expr D s) \<Delta>) \<union>
        (\<Union>n. iter n (eval_skat_expr D s) \<Gamma>)"
    by auto
qed

lemma eval_mod3: "eval_skat_expr D r b \<union> a \<union> b = b \<Longrightarrow> eval_skat_expr D (SKStar r) a \<union> b = b"
proof simp
  assume asm: "eval_skat_expr D r b \<union> a \<union> b = b"
  have "\<And>n. iter n (eval_skat_expr D r) a \<union> b = b"
  proof -
    fix n show "iter n (eval_skat_expr D r) a \<union> b = b"
      apply (induct n)
      apply (simp, metis Un_assoc Un_commute asm sup.left_idem)
      by (simp, metis (no_types) asm eval_mod2 sup.assoc)
  qed
  thus "(\<Union>n. iter n (eval_skat_expr D r) a) \<union> b = b"
    by blast
qed

lemma eval_iter:
  "iter n (eval_skat_expr D x) (eval_skat_expr D x \<Delta>) = iter (Suc n) (eval_skat_expr D x) \<Delta>"
  by (induct n, auto)

lemma eval_star_unfoldl:
  fixes \<Delta> :: "'b mems"
  shows "eval_skat_expr D (SKOne \<oplus> x \<odot> SKStar x \<oplus> SKStar x) \<Delta> = eval_skat_expr D (SKStar x) \<Delta>"
proof auto
  fix mem :: "'b mem" assume "mem \<in> \<Delta>"
  thus "\<exists>n. mem \<in> iter n (eval_skat_expr D x) \<Delta>"
    by (rule_tac x = 0 in exI, simp)
next
  fix mem :: "'b mem" and n
  assume "mem \<in> iter n (eval_skat_expr D x) (eval_skat_expr D x \<Delta>)"
  thus "\<exists>n. mem \<in> iter n (eval_skat_expr D x) \<Delta>"
    by (rule_tac x = "Suc n" in exI, metis eval_iter)
qed

lemma eval_iso: "\<Delta> \<subseteq> \<Gamma> \<Longrightarrow> eval_skat_expr D s \<Delta> \<subseteq> eval_skat_expr D s \<Gamma>"
  by (metis eval_mod2 subset_Un_eq)

lemma iter_jp:
  assumes f_jp: "\<And>X. f (\<Union>X) = \<Union>(f ` X)"
  shows "iter n f (\<Union>X) = \<Union>(iter n f ` X)"
proof (induct n arbitrary: X, simp)
  fix n X
  assume "\<And>X. iter n f (\<Union>X) = \<Union>iter n f ` X"
  hence ind_hyp2: "iter n f (\<Union>X) = \<Union>iter n f ` X"
    by auto
  have "iter (Suc n) f (\<Union>X) = f (iter n f (\<Union> X))"
    by simp
  also have "... = f (\<Union>iter n f ` X)"
    by (metis ind_hyp2)
  also have "... = \<Union>f ` iter n f ` X"
    by (metis f_jp)
  also have "... = \<Union>iter (Suc n) f ` X"
    by (auto simp add: image_def)
  finally show "iter (Suc n) f (\<Union>X) = \<Union>iter (Suc n) f ` X" .
qed

lemma eval_jp: "eval_skat_expr D s (\<Union>X) = \<Union>(eval_skat_expr D s ` X)"
proof (induct s arbitrary: X)
  fix x and s :: "'b trm" and X
  show "eval_skat_expr D (SKAssign x s) (\<Union>X) = \<Union>eval_skat_expr D (SKAssign x s) ` X"
    by (auto simp add: assigns_def set_mems_def)
next
  fix s t :: "'b skat_expr" and X
  assume "\<And>X. eval_skat_expr D s (\<Union>X) = \<Union>eval_skat_expr D s ` X"
  and "\<And>X. eval_skat_expr D t (\<Union>X) = \<Union>eval_skat_expr D t ` X"
  thus "eval_skat_expr D (s \<oplus> t) (\<Union>X) = \<Union>eval_skat_expr D (s \<oplus> t) ` X"
    by auto
next
  fix s t :: "'b skat_expr" and X
  assume asm1: "\<And>X. eval_skat_expr D s (\<Union>X) = \<Union>eval_skat_expr D s ` X"
  and asm2: "\<And>X. eval_skat_expr D t (\<Union>X) = \<Union>eval_skat_expr D t ` X"
  have "eval_skat_expr D (s \<odot> t) (\<Union>X) = eval_skat_expr D t (eval_skat_expr D s (\<Union>X))"
    by simp
  also have "... = eval_skat_expr D t (\<Union>eval_skat_expr D s ` X)"
    by (simp add: asm1[of X])
  also have "... = \<Union>(eval_skat_expr D t ` eval_skat_expr D s ` X)"
    by (insert asm2[of "eval_skat_expr D s ` X"])
  also have "... = \<Union>eval_skat_expr D (s \<odot> t) ` X"
    by simp
  finally show "eval_skat_expr D (s \<odot> t) (\<Union>X) = \<Union>eval_skat_expr D (s \<odot> t) ` X" .
next
  fix s :: "'b skat_expr" and X
  assume asm: "\<And>X. eval_skat_expr D s (\<Union>X) = \<Union>eval_skat_expr D s ` X"
  show "eval_skat_expr D (SKStar s) (\<Union>X) = \<Union>eval_skat_expr D (SKStar s) ` X"
  proof auto
    fix x n assume "x \<in> iter n (eval_skat_expr D s) (\<Union>X)"
    hence "x \<in> \<Union>(iter n (eval_skat_expr D s) ` X)"
      by (metis asm iter_jp)
    thus "\<exists>y\<in>X. \<exists>n. x \<in> iter n (eval_skat_expr D s) y"
      by (metis (no_types) UnionE image_iff)
  next
    fix x y n assume "y \<in> X" and "x \<in> iter n (eval_skat_expr D s) y"
    hence "\<exists>n. x \<in> \<Union>(iter n (eval_skat_expr D s) ` X)"
      by (metis UnionI image_eqI)
    thus "\<exists>n. x \<in> iter n (eval_skat_expr D s) (\<Union>X)"
      by (metis asm iter_jp)
  qed
next
  fix P :: "'b pred bexpr" and X
  show "eval_skat_expr D (SKBool P) (\<Union>X) = \<Union>eval_skat_expr D (SKBool P) ` X"
    by (auto simp add: filter_set_def)
next
  fix X
  show "eval_skat_expr D SKOne (\<Union>X) = \<Union>eval_skat_expr D SKOne ` X"
    by auto
next
  fix X
  show "eval_skat_expr D SKZero (\<Union>X) = \<Union>eval_skat_expr D SKZero ` X"
    by auto
qed

lemma eval_star_slide:
  fixes \<Delta> :: "'b mems"
  shows "eval_skat_expr D (SKStar x \<odot> x) \<Delta> = eval_skat_expr D (x \<odot> SKStar x) \<Delta>"
  apply (simp add: eval_star_power del: eval_skat_expr.simps(5))
  apply (simp add: eval_jp)
  apply auto
  apply (metis (no_types) iter.simps(2) eval_iter eval_power_def)
  by (metis (no_types) iter.simps(2) eval_iter eval_power_def)

lemma eval_star_unfoldr:
  fixes \<Delta> :: "'b mems"
  shows "eval_skat_expr D (SKOne \<oplus> SKStar x \<odot> x \<oplus> SKStar x) \<Delta> = eval_skat_expr D (SKStar x) \<Delta>"
  by (subst eval_star_unfoldl[symmetric], insert eval_star_slide, auto)

lemma eval_star_inductl:
  assumes asm2: "\<forall>\<Delta>::'b mems. eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
  shows "\<forall>\<Delta>. eval_skat_expr D (SKStar x \<odot> z \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
proof (auto simp add: eval_star_power eval_jp eval_power_def simp del: eval_skat_expr.simps(5))
  fix \<Delta> :: "'b mems" and mem :: "'b mem" and n
  assume "mem \<in> eval_skat_expr D z (iter n (eval_skat_expr D x) \<Delta>)"
  hence "mem \<in> eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) \<Delta>"
  proof (induct n arbitrary: \<Delta>, simp, simp only: iter.simps eval_iter1)
    fix m and \<Gamma> :: "'b mems"
    assume "\<And>\<Delta>. mem \<in> eval_skat_expr D z (iter m (eval_skat_expr D x) \<Delta>) \<Longrightarrow>
                mem \<in> eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) \<Delta>"
      and "mem \<in> eval_skat_expr D z (iter m (eval_skat_expr D x) (eval_skat_expr D x \<Gamma>))"
    hence a: "mem \<in> eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) (eval_skat_expr D x \<Gamma>)"
      by auto
    thus "mem \<in> eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) \<Gamma>"
      by (auto, (metis a asm2)+)
  qed
  thus "mem \<in> eval_skat_expr D y \<Delta>"
    by (metis asm2)
qed

lemma eval_iso2:
  assumes "\<And>mem. mem \<in> \<Delta> \<Longrightarrow> mem \<in> \<Gamma>"
  and "mem \<in> eval_skat_expr D s \<Delta>"
  shows "mem \<in> eval_skat_expr D s \<Gamma>"
proof -
  have "\<Delta> \<subseteq> \<Gamma>"
    by (insert assms(1), auto)
  thus ?thesis
    by (metis assms(2) eval_iso set_mp)
qed

lemma eval_star_inductr:
  assumes asm2: "\<forall>\<Delta>::'b mems. eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
  shows "\<forall>\<Delta>. eval_skat_expr D (z \<odot> SKStar x \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
proof auto
  fix \<Delta> :: "'b mems" and mem :: "'b mem" and n
  assume "mem \<in> iter n (eval_skat_expr D x) (eval_skat_expr D z \<Delta>)"
  hence "mem \<in> eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta>"
  proof (induct n arbitrary: mem, simp)
    fix n mem
    assume asm:
      "\<And>mem. mem \<in> iter n (eval_skat_expr D x) (eval_skat_expr D z \<Delta>) \<Longrightarrow>
             mem \<in> eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta>"
    and "mem \<in> iter (Suc n) (eval_skat_expr D x) (eval_skat_expr D z \<Delta>)"
    hence "mem \<in> eval_skat_expr D x (iter n (eval_skat_expr D x) (eval_skat_expr D z \<Delta>))"
      by simp
    hence "mem \<in> eval_skat_expr D x (eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta>)"
      by (smt asm eval_iso2)
    thus "mem \<in> eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta>"
      by (metis (lifting) UnI1 UnI2 asm2 eval_skat_expr.simps(3) eval_skat_expr.simps(4))
  qed
  thus "mem \<in> eval_skat_expr D y \<Delta>"
    by (metis asm2)
qed

theorem hunt_cong_eval: "hunt_cong s t \<Longrightarrow> \<forall>\<Delta>. eval_bexpr D s \<Delta> = eval_bexpr D t \<Delta>"
  by (induct rule: hunt_cong.induct, auto)

lemma evap_bexpr_not[simp]: "eval_bexpr D (BNot x) \<Delta> = (\<not> eval_bexpr D x \<Delta>)" by simp

lemma filter_compl [simp]: "filter_set (\<lambda>x. \<not> p x) X = (- filter_set p X \<inter> X)"
proof -
  have "filter_set (\<lambda>x. \<not> p x) X \<subseteq> (- filter_set p X \<inter> X)"
    by (auto simp add: filter_set_def, (metis empty_iff singleton_iff)+)
  moreover have "(- filter_set p X \<inter> X) \<subseteq> filter_set (\<lambda>x. \<not> p x) X"
    by (auto simp add: filter_set_def, metis insertI1)
  ultimately show ?thesis
    by blast
qed

lemma eval_skat_not: "eval_skat_expr D (SKBool (BNot x)) \<Delta> = (- eval_skat_expr D (SKBool x) \<Delta> \<inter> \<Delta>)"
  by (simp add: filter_set_def, metis Compl_UN filter_compl filter_set_def)

method_setup simp_solve = {*
Scan.succeed (fn ctxt =>
  ALLGOALS (fn n => TRY (SOLVED' (asm_full_simp_tac (simpset_of ctxt)) n) ORELSE all_tac)
  |> SIMPLE_METHOD)
*}

declare filter_set_def [simp]

theorem skat_cong_eval: "skat_cong s t \<Longrightarrow> \<forall>\<Delta>. eval_skat_expr D s \<Delta> = eval_skat_expr D t \<Delta>"
proof (induct rule: skat_cong.induct, simp_solve)
  fix x y assume asm1: "skat_cong x y"
  and asm2: "\<forall>\<Delta>. eval_skat_expr D x \<Delta> = eval_skat_expr D y \<Delta>"
  hence "\<And>n. \<forall>\<Delta>. iter n (eval_skat_expr D x) \<Delta> = iter n (eval_skat_expr D y) \<Delta>"
  proof -
    fix n show "\<forall>\<Delta>. iter n (eval_skat_expr D x) \<Delta> = iter n (eval_skat_expr D y) \<Delta>"
      by (induct n, simp_all add: asm2)
  qed
  thus "\<forall>\<Delta>. eval_skat_expr D (SKStar x) \<Delta> = eval_skat_expr D (SKStar y) \<Delta>"
    by auto
next
  fix x y assume "skat_cong (SKBool x) (SKBool y)"
  and "\<forall>\<Delta>. eval_skat_expr D (SKBool x) \<Delta> = eval_skat_expr D (SKBool y) \<Delta>"
  thus "\<forall>\<Delta>. eval_skat_expr D (SKBool (BNot x)) \<Delta> = eval_skat_expr D (SKBool (BNot y)) \<Delta>"
    by (simp only: eval_skat_not, auto)
next
 fix x y z show "\<forall>\<Delta>. eval_skat_expr D (x \<oplus> y \<oplus> z) \<Delta> = eval_skat_expr D (x \<oplus> (y \<oplus> z)) \<Delta>"
   by auto
next
  fix x y show "\<forall>\<Delta>. eval_skat_expr D (x \<oplus> y) \<Delta> = eval_skat_expr D (y \<oplus> x) \<Delta>"
    by auto
next
  fix x y z show "\<forall>\<Delta>. eval_skat_expr D ((x \<oplus> y) \<odot> z) \<Delta> = eval_skat_expr D (x \<odot> z \<oplus> y \<odot> z) \<Delta>"
    by (simp, metis eval_mod2)
next
  fix x show "\<forall>\<Delta>. eval_skat_expr D (SKZero \<odot> x) \<Delta> = eval_skat_expr D SKZero \<Delta>"
    by (simp, metis eval_mod1)
next
  fix x
  show "\<forall>\<Delta>. eval_skat_expr D (SKOne \<oplus> x \<odot> SKStar x \<oplus> SKStar x) \<Delta> = eval_skat_expr D (SKStar x) \<Delta>"
    by (metis eval_star_unfoldl)
next
  fix x
  show "\<forall>\<Delta>. eval_skat_expr D (SKOne \<oplus> SKStar x \<odot> x \<oplus> SKStar x) \<Delta> = eval_skat_expr D (SKStar x) \<Delta>"
    by (metis eval_star_unfoldr)
next
  fix z x y assume "\<forall>\<Delta>. eval_skat_expr D (z \<oplus> x \<odot> y \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
  thus "\<forall>\<Delta>. eval_skat_expr D (SKStar x \<odot> z \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
    by (metis eval_star_inductl)
next
  fix z y x assume "skat_cong (z \<oplus> y \<odot> x \<oplus> y) y"
  and "\<forall>\<Delta>. eval_skat_expr D (z \<oplus> y \<odot> x \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
  thus "\<forall>\<Delta>. eval_skat_expr D (z \<odot> SKStar x \<oplus> y) \<Delta> = eval_skat_expr D y \<Delta>"
    by (metis eval_star_inductr)
next
  fix x y :: "'a pred bexpr" assume "hunt_cong x y"
  hence "\<forall>\<Delta>. eval_bexpr D x \<Delta> = eval_bexpr D y \<Delta>"
    by (metis hunt_cong_eval)
  hence "eval_bexpr D x = eval_bexpr D y"
    by auto
  thus "\<forall>\<Delta>. eval_skat_expr D (SKBool x) \<Delta> = eval_skat_expr D (SKBool y) \<Delta>"
    by (simp del: filter_set_def)
next
  fix x y show "\<forall>\<Delta>. eval_skat_expr D (SKBool (x :\<cdot>: y)) \<Delta> = eval_skat_expr D (SKBool x \<odot> SKBool y) \<Delta>"
    by (auto, (metis empty_iff singleton_iff)+)
next
  fix x y show "\<forall>\<Delta>. eval_skat_expr D (SKBool (x :+: y)) \<Delta> = eval_skat_expr D (SKBool x \<oplus> SKBool y) \<Delta>"
    by (auto, (metis empty_iff singleton_iff)+)
next
  fix x y :: nat and s t :: "'a trm" assume "x \<noteq> y" and "y \<notin> FV s"
  thus "\<forall>\<Delta>. eval_skat_expr D (SKAssign x s \<odot> SKAssign y t) \<Delta> =
            eval_skat_expr D (SKAssign y (t[x|s]) \<odot> SKAssign x s) \<Delta>"
    by (simp, metis eval_assigns1)
next
  fix x y :: nat and s t :: "'a trm" assume "x \<noteq> y" and "x \<notin> FV s"
  thus "\<forall>\<Delta>. eval_skat_expr D (SKAssign x s \<odot> SKAssign y t) \<Delta> =
            eval_skat_expr D (SKAssign x s \<odot> SKAssign y (t[x|s])) \<Delta>"
    by (simp, metis eval_assigns2)
next
  fix x s t
  show "\<forall>\<Delta>. eval_skat_expr D (SKAssign x s \<odot> SKAssign x t) \<Delta> =
            eval_skat_expr D (SKAssign x (t[x|s])) \<Delta>"
    by (simp, metis eval_assigns3)
next
  fix x t \<phi>
  show "\<forall>\<Delta>. eval_skat_expr D (SKBool (bexpr_map (pred_subst x t) \<phi>) \<odot> SKAssign x t) \<Delta> =
            eval_skat_expr D (SKAssign x t \<odot> SKBool \<phi>) \<Delta>"
    by (simp del: filter_set_def, metis eval_assigns4_bexpr)
qed

lift_definition eval ::
  "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a skat \<Rightarrow> 'b mems \<Rightarrow> 'b mems"
  is eval_skat_expr
proof -
  fix D :: "('a::ranked_alphabet, 'b) interp" and s t :: "'a skat_expr"
  assume "skat_cong s t"
  hence "\<forall>\<Delta>. eval_skat_expr D s \<Delta> = eval_skat_expr D t \<Delta>"
    by (metis skat_cong_eval)
  thus "eval_skat_expr D s = eval_skat_expr D t"
    by auto
qed

definition eval_pred :: "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a skat \<Rightarrow> 'b mem \<Rightarrow> bool" where
  "eval_pred D b mem \<equiv> mem \<in> eval D b {mem}"

definition expr_determ ::
  "('a::ranked_alphabet, 'b) interp \<Rightarrow> 'a skat_expr \<Rightarrow> bool"
  where
  "expr_determ D s \<equiv> \<forall>start. \<exists>!end. eval_skat_expr D s {start} = {end}"

lemma pred_expr_to_test [simp]: "pred_expr \<circ> rep_bterm = test"
  by (rule ext, simp add: o_def test_def pred_expr_def)

lemma test_to_pred_expr [simp]: "test \<circ> abs_bterm = pred_expr"
  apply (rule ext, simp add: o_def test_def pred_expr_def)
  by (metis o_eq_dest_lhs pred_expr_test pred_expr_unfold abs.simps(4) test_to_pred_expr unfold_is_abs)

lemma test_range: "range pred_expr = range test"
  by (metis test_to_pred_expr equalityI image_compose image_subsetI pred_expr_to_test rangeI)

lemma pred_exists: "p \<in> carrier tests \<Longrightarrow> \<exists>P. p = pred_expr P"
proof -
  assume p_test: "p \<in> carrier tests"
  hence "p \<in> range pred_expr"
    by (simp add: tests_def test_set_def test_range[symmetric])
  thus "\<exists>P. p = pred_expr P"
    by (metis (lifting) image_iff)
qed

locale interp = fixes D :: "('a::ranked_alphabet,'b) interp"

context interp
begin

  definition module :: "'b mems \<Rightarrow> 'a skat \<Rightarrow> 'b mems" (infix "\<Colon>" 75) where
    "module \<Delta> x \<equiv> eval D x \<Delta>"

  (* Properties from Kleene modules and linear languages by Hans Leiss *)

  lemma mod_empty [simp]: "{} \<Colon> r = {}"
    by (simp add: module_def, transfer, metis eval_mod1)

  lemma mod_union: "(a \<union> b) \<Colon> r = a \<Colon> r \<union> b \<Colon> r"
    by (simp add: module_def, transfer, metis eval_mod2)

  lemma mod_zero [simp]: "a \<Colon> \<zero> = {}"
    by (simp add: module_def, transfer, simp)

  lemma mod_plus: "a \<Colon> (r + s) = a \<Colon> r \<union> a \<Colon> s"
    by (simp add: module_def, transfer, simp)

  lemma mod_one [simp]: "a \<Colon> \<one> = a"
    by (simp add: module_def, transfer, simp)

  lemma mod_mult: "a \<Colon> (r \<cdot> s) = (a \<Colon> r) \<Colon> s"
    by (simp add: module_def, transfer, simp)

  lemma mod_star: "a \<union> b \<Colon> r \<subseteq> b \<Longrightarrow> a \<Colon> r\<^sup>\<star> \<subseteq> b"
    by (simp add: module_def subset_Un_eq, transfer, rule eval_mod3, blast)

  lemma mod_assign: "\<Delta> \<Colon> x := s = assigns D x s \<Delta>"
    apply (simp add: module_def)
    apply transfer
    apply simp
    done

  lemma mod_pred_expr: "\<Delta> \<Colon> pred_expr P = filter_set (eval_bexpr D P) \<Delta>"
    apply (simp add: module_def)
    apply transfer
    apply simp
    done

  lemma mod_eval: "\<Delta> \<Colon> \<lfloor>s\<rfloor> = eval_skat_expr D s \<Delta>"
  proof -
    have "eval_skat_expr D s \<Delta> = \<Delta> \<Colon> abs_skat s"
      by (simp add: module_def, transfer, auto)
    thus ?thesis
      by (metis unfold_is_abs)
  qed

  lemma mod_star_eval: "\<Delta> \<Colon> \<lfloor>s\<rfloor>\<^sup>\<star> = (\<Union>n. iter n (eval_skat_expr D s) \<Delta>)"
    by (subgoal_tac "\<lfloor>s\<rfloor>\<^sup>\<star> = \<lfloor>SKStar s\<rfloor>", simp only: mod_eval, transfer, auto)

  lemma mod_test_and:
    assumes b_test: "b \<in> carrier tests" shows "a \<Colon> b = a \<inter> UNIV \<Colon> b"
  proof -
    obtain B where b_def: "b = pred_expr B"
      by (metis b_test pred_exists)
    have "a \<Colon> pred_expr B = filter_set (eval_bexpr D B) a"
      by (simp add: mod_pred_expr)
    also have "... = a \<inter> filter_set (eval_bexpr D B) UNIV"
      by (rule filter_set_inter)
    also have "... = a \<inter> UNIV \<Colon> pred_expr B"
      by (simp add: mod_pred_expr)
    finally show ?thesis
      by (metis b_def)
  qed

  lemma module: "kat_module free_kat SET (op \<Colon>)"
  proof (auto simp add: kat_module_def kat_module'_def)
    show "kat free_kat"
      by (metis free_kat)

    show "complete_boolean_lattice SET"
      by (metis SET_cbl)

    show "(op \<Colon>) \<in> carrier SET \<rightarrow> carrier free_kat \<rightarrow> carrier SET"
      by (simp add: ftype_pred SET_def)

    show "kat_module_axioms free_kat SET (op \<Colon>)"
    proof (simp add: kat_module_axioms_def, intro conjI impI allI, simp_all add: SET_def free_kat_def)
      fix p q m n a P Q
      show "m \<Colon> (p + q) = m \<Colon> p \<union> m \<Colon> q"
        by (fact mod_plus)
      show "m \<Colon> (p ; q) = (m \<Colon> p) \<Colon> q"
        by (fact mod_mult)
      show "(P \<union> Q) \<Colon> p = P \<Colon> p \<union> Q \<Colon> p"
        by (fact mod_union)
      show "m \<subseteq> n \<and> n \<Colon> p \<subseteq> n \<Longrightarrow> m \<Colon> p\<^sup>\<star> \<subseteq> n"
        by (metis Un_least mod_star)
      show "a \<in> carrier tests \<Longrightarrow> m \<Colon> a = m \<inter> UNIV \<Colon> a"
        by (metis mod_test_and)
    qed
  qed

  definition hoare_triple :: "'b mems \<Rightarrow> 'a skat \<Rightarrow> 'b mems \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [54,54,54] 53) where
    "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace> \<equiv> P \<Colon> p \<subseteq> Q"

  lemma hoare_triple_mod: "kat_module.hoare_triple SET (op \<Colon>) P p Q = \<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
    by (simp add: kat_module.hoare_triple_def[OF module] hoare_triple_def) (simp add: SET_def)

  declare hoare_triple_mod[simp]
  declare SET_def[simp]
  declare free_kat_def[simp]

  lemmas hoare_composition = kat_module.hoare_composition[OF module, simplified]

  lemma hoare_weakening [consumes 1]: "\<lbrakk>\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>; P' \<subseteq> P; Q \<subseteq> Q'\<rbrakk> \<Longrightarrow> \<lbrace>P'\<rbrace> p \<lbrace>Q'\<rbrace>"
    by (metis hoare_triple_def interp.hoare_composition mod_one skd.mult_onel skd.mult_oner)

  lemma hoare_if:
    assumes b_test: "b \<in> carrier tests"
    and then_branch: "\<lbrace>P \<inter> (UNIV \<Colon> b)\<rbrace> p \<lbrace>Q\<rbrace>"
    and else_branch: "\<lbrace>P \<inter> (UNIV \<Colon> !b)\<rbrace> q \<lbrace>Q\<rbrace>"
    shows "\<lbrace>P\<rbrace> IF b THEN p ELSE q ENDIF \<lbrace>Q\<rbrace>"
  proof -
    obtain B where b_def: "b = pred_expr B"
      by (metis b_test pred_exists)
    hence "\<lbrace>P \<inter> (UNIV \<Colon> pred_expr B)\<rbrace> p \<lbrace>Q\<rbrace>" and "\<lbrace>P \<inter> (UNIV \<Colon> pred_expr (BNot B))\<rbrace> q \<lbrace>Q\<rbrace>"
      by (metis then_branch) (metis b_def else_branch pred_expr_not)
    hence "\<lbrace>P\<rbrace> IF pred_expr B THEN p ELSE q ENDIF \<lbrace>Q\<rbrace>"
      apply (simp add: if_then_else_def hoare_triple_def mod_plus mod_mult)
      by (metis (lifting) filter_set_inter mod_pred_expr)
    thus ?thesis
      by (metis b_def)
  qed

  abbreviation assigns_notation :: "'b mems \<Rightarrow> nat \<Rightarrow> 'a trm \<Rightarrow> 'b mems"
    ("_[_|_]" [100,100,100] 101) where
    "P[x|t] \<equiv> assigns D x t P"

  lemma hoare_assignment: "P[x|s] \<subseteq> Q \<Longrightarrow> \<lbrace>P\<rbrace> x := s \<lbrace>Q\<rbrace>"
    by (metis hoare_triple_def mod_assign)

  definition satisfies :: "nat \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b mems" where
    "satisfies x p \<equiv> {mem. p (mem x)}"

  lemma hoare_while:
    assumes b_test: "b \<in> carrier tests"
    and Q_def: "Q = P \<inter> (UNIV \<Colon> !b)"
    and loop_condition: "\<lbrace>P \<inter> (UNIV \<Colon> b)\<rbrace> p \<lbrace>P\<rbrace>"
    shows "\<lbrace>P\<rbrace> WHILE b DO p WEND \<lbrace>Q\<rbrace>"
  proof -
    have "P \<Colon> (b ; p)\<^sup>\<star> \<subseteq> P"
      by (rule mod_star, metis b_test hoare_triple_def interp.mod_mult interp.mod_test_and le_sup_iff loop_condition order_refl)
    hence "P \<Colon> (b ; p)\<^sup>\<star> \<inter> UNIV \<Colon> !b \<subseteq> P \<inter> UNIV \<Colon> !b"
      by (metis (lifting) Int_Un_distrib2 subset_Un_eq)
    hence "P \<Colon> (b ; p)\<^sup>\<star> \<inter> UNIV \<Colon> !b \<subseteq> Q"
      by (simp add: Q_def)
    hence "(P \<Colon> (b ; p)\<^sup>\<star>) \<Colon> !b \<subseteq> Q"
      by (metis b_test not_closed mod_test_and)
    hence "\<lbrace>P\<rbrace> (b;p)\<^sup>\<star>;!b \<lbrace>Q\<rbrace>"
      by (simp add: hoare_triple_def mod_mult)
    thus ?thesis
      by (simp add: while_def)
  qed

  definition while_inv :: "'a::ranked_alphabet skat \<Rightarrow> 'b mems \<Rightarrow> 'a skat \<Rightarrow> 'a skat" ("WHILE _ INVARIANT _ DO _ WEND" [64,64,64] 63) where
  "WHILE b INVARIANT i DO p WEND = (b\<cdot>p)\<^sup>\<star>\<cdot>!b"

  lemma while_inv_while: "WHILE b INVARIANT i DO p WEND = WHILE b DO p WEND"
    by (metis while_def while_inv_def)

  lemma hoare_while_inv:
    assumes b_test: "b \<in> carrier tests"
    and Pi: "P \<subseteq> i" and iQ: "i \<inter> (UNIV \<Colon> !b) \<subseteq> Q"
    and inv_loop: "\<lbrace>i \<inter> (UNIV \<Colon> b)\<rbrace> p \<lbrace>i\<rbrace>"
    shows "\<lbrace>P\<rbrace> WHILE b INVARIANT i DO p WEND \<lbrace>Q\<rbrace>"
    by (auto simp add: while_inv_while intro: hoare_weakening[OF _ Pi iQ] hoare_while[OF b_test _ inv_loop])

end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_05
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

(*to detect case-distinction, I have to detect things liks Nat.case_Nat.*)
fun count :: "Nat => Nat list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

theorem property0 :
  "((n = y) ==> ((S (count n xs)) = (count n (cons2 y xs))))"
  apply(induct y arbitrary: n xs)
   apply fastforce
  apply clarsimp
    (*Why "induct_tac xs"?
    *Because the pattern-matching of the innermost recursive constant (count) is complete
    *on the second argument (here xs), which is universally quantified with \<And>.*)
  apply(induct_tac xs)
   defer
   apply auto[1]
  apply(subgoal_tac "x y y")
   apply fastforce
  apply(thin_tac "\<not> x y y")
  apply(thin_tac "(\<And>n xs. n = y \<Longrightarrow> S (count y xs) = count y xs)")
  apply(induct_tac y)
   apply auto
  done

end


section \<open>Hoare Triples\<close>

theory Hoare
imports Statements
begin

text \<open>
A hoare triple for $p,q\in \mathit{State}\ \mathit{set}$, and
$S : \mathit{State}\ \mathit{set} \to \mathit{State}\ \mathit{set}$ is valid,
denoted $\models p \{|S|\} q$, if every execution of $S$ starting from state $s\in p$
always terminates, and if it terminates in state $s'$, then $s'\in q$. When $S$ is
modeled as a predicate transformer, this definition is equivalent to requiring that
$p$ is a subset of the initial states from which the execution of $S$ is guaranteed
to terminate in $q$, that is $p \subseteq S\ q$.

The formal definition of a valid hoare triple only assumes that $p$ (and also $S\ q$) ranges
over a complete lattice.
\<close>

definition
  Hoare :: "'a::complete_distrib_lattice \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool" ("\<Turnstile> (_){| _ |}(_)" [0,0,900] 900) where
  "\<Turnstile> p {|S|} q = (p \<le> (S q))"

theorem hoare_sequential:
  "mono S \<Longrightarrow> (\<Turnstile> p {| S o T |} r) = ( (\<exists> q. \<Turnstile> p {| S |} q \<and> \<Turnstile> q {| T |} r))"
  by (metis (no_types) Hoare_def monoD o_def order_refl order_trans)

theorem hoare_choice:
  "\<Turnstile> p {| S \<sqinter> T |} q = (\<Turnstile> p {| S |} q \<and> \<Turnstile> p {| T |} q)"
  by (simp_all add: Hoare_def inf_fun_def)

theorem hoare_assume:
  "(\<Turnstile> P {| [.R.] |} Q) = (P \<sqinter> R \<le> Q)"
  apply (simp add: Hoare_def assume_def)
  apply safe
  apply (case_tac "(inf P R) \<le> (inf (sup (- R) Q) R)")
  apply (simp add: inf_sup_distrib2)
  apply (simp add: le_infI1)
  apply (case_tac "(sup (-R) (inf P R)) \<le> sup (- R) Q")
  apply (simp add: sup_inf_distrib1)
  by (simp add: le_supI2)

theorem hoare_mono:
  "mono S \<Longrightarrow> Q \<le> R \<Longrightarrow> \<Turnstile> P {| S |} Q \<Longrightarrow> \<Turnstile> P {| S |} R"
  apply (simp add: mono_def Hoare_def)
  apply (rule_tac y = "S Q" in order_trans)
  by auto

theorem hoare_pre:
  "R \<le> P \<Longrightarrow> \<Turnstile> P {| S |} Q \<Longrightarrow> \<Turnstile> R {| S |} Q"
  by (simp add: Hoare_def)

theorem hoare_Sup:
  "(\<forall> p \<in> P . \<Turnstile> p {| S |} q) = \<Turnstile> Sup P {| S |} q"
  apply (simp add: Hoare_def, safe, simp add: Sup_least)
  apply (rule_tac y = "\<Squnion>P" in order_trans, simp_all)
  by (simp add: Sup_upper)

lemma hoare_magic [simp]: "\<Turnstile> P {| \<top> |} Q"
  by (simp add: Hoare_def top_fun_def)

lemma hoare_demonic: "\<Turnstile> P {| [:R:] |} Q = (\<forall> s . s \<in> P \<longrightarrow>  R s \<subseteq> Q)"
  apply (unfold Hoare_def demonic_def)
  by auto

lemma hoare_not_guard:
  "mono (S :: (_::order_bot) \<Rightarrow> _) \<Longrightarrow> \<Turnstile> p {| S |} q = \<Turnstile> (p \<squnion> (- grd S)) {| S |} q"
  apply (simp add: Hoare_def grd_def, safe)
  apply (drule monoD)
  by auto

subsection \<open>Hoare rule for recursive statements\<close>

text \<open>
A statement $S$ is refined by another statement $S'$ if $\models p \{| S' |\} q$
is true for all $p$ and $q$ such that  $\models p \{| S |\} q$ is true. This
is equivalent to $S \le S'$.

Next theorem can be used to prove refinement of a recursive program. A recursive
program is modeled as the least fixpoint of a monotonic mapping from predicate
transformers to predicate transformers.
\<close>

theorem lfp_wf_induction:
  "mono f \<Longrightarrow> (\<forall> w . (p w) \<le> f (Sup_less p w)) \<Longrightarrow> Sup (range p) \<le> lfp f"
 apply (rule fp_wf_induction, simp_all)
 by (drule lfp_unfold, simp)

definition
  "post_fun (p::'a::order) q = (if p \<le> q then \<top> else \<bottom>)"

lemma post_mono [simp]: "mono (post_fun p :: (_::{order_bot,order_top}))"
   apply (simp add: post_fun_def  mono_def, safe)
   apply (subgoal_tac "p \<le> y", simp)
   by (rule_tac y = x in order_trans, simp_all)

lemma post_refin [simp]: "mono S \<Longrightarrow> ((S p)::'a::bounded_lattice) \<sqinter> (post_fun p) x \<le> S x"
  apply (simp add: le_fun_def post_fun_def, safe)
  by (rule_tac f = S in monoD, simp_all)

text \<open>
Next theorem shows the equivalence between the validity of Hoare
triples and refinement statements. This theorem together with the
theorem for refinement of recursive programs will be used to prove
a Hoare rule for recursive programs.
\<close>

theorem hoare_refinement_post:
  "mono f \<Longrightarrow>  (\<Turnstile> x {| f |} y) = ({.x.} o (post_fun y) \<le> f)"
  apply safe
  apply (simp_all add: Hoare_def)
  apply (simp_all add: le_fun_def)
  apply (simp add: assert_def, safe)
  apply (rule_tac y = "f y \<sqinter> post_fun y xa" in order_trans, simp_all)
  apply (rule_tac y = "x" in order_trans, simp_all)
  apply (simp add: assert_def)
  by (drule_tac x = "y" in spec, simp)

text \<open>
Next theorem gives a Hoare rule for recursive programs. If we can prove correct the unfolding
of the recursive definition applid to a program $f$, $\models p\ w\ \{| F\  f |\}\  y$, assumming
that $f$ is correct when starting from $p\  v$, $v<w$, $\models SUP-L\  p\  w\  \{| f |\}\  y$, then
the recursive program is correct $\models SUP\ p\ \{| lfp\  F |\}\  y$
\<close>

lemma assert_Sup: "{.\<Squnion> (X::'a::complete_distrib_lattice set).} = \<Squnion> (assert ` X)"
  by (simp add: fun_eq_iff assert_def Sup_inf image_comp)

lemma assert_Sup_range: "{.\<Squnion> (range (p::'W \<Rightarrow> 'a::complete_distrib_lattice)).} = \<Squnion> (range (assert o p))"
  by (simp add: fun_eq_iff assert_def SUP_inf image_comp)

lemma Sup_range_comp: "(\<Squnion> range p) o S = \<Squnion> (range (\<lambda> w . ((p w) o S)))"
  by (simp add: fun_eq_iff image_comp)

lemma Sup_less_comp: "(Sup_less P) w o S = Sup_less (\<lambda> w . ((P w) o S)) w"
  apply (simp add: Sup_less_def fun_eq_iff, safe)
  apply (subgoal_tac "((\<lambda>f. f (S x)) ` {y. \<exists>v<w. \<forall>x. y x = P v x}) = ((\<lambda>f. f x) ` {y. \<exists>v<w. \<forall>x. y x = P v (S x)})")
  apply (auto cong del: SUP_cong_simp)
  done

lemma Sup_less_assert: "Sup_less (\<lambda>w. {. (p w)::'a::complete_distrib_lattice .}) w = {.Sup_less p w.}"
  apply (simp add: Sup_less_def assert_Sup image_def)
  apply (subgoal_tac "{y. \<exists>v<w. y = {. p v .}} = {y. \<exists>x. (\<exists>v<w. x = p v) \<and> y = {. x .}}")
  apply (auto simp add: image_def cong del: SUP_cong_simp)
  done

declare mono_comp[simp]

theorem hoare_fixpoint:
  "mono_mono F \<Longrightarrow>
   (!! w f . mono f \<and> \<Turnstile> Sup_less p w {| f |} y \<Longrightarrow> \<Turnstile> p w {| F f |} y) \<Longrightarrow> \<Turnstile> (Sup (range p)) {| lfp F |} y"
  apply (simp add: mono_mono_def hoare_refinement_post assert_Sup_range Sup_range_comp)
  apply (rule lfp_wf_induction)
  apply auto
  apply (simp add: Sup_less_comp [THEN sym])
  apply (simp add: Sup_less_assert)
  apply (drule_tac x = "{. Sup_less p w .} \<circ> post_fun y" in spec, safe)
  apply simp
  by (simp add: hoare_refinement_post)

theorem "(\<forall> t . \<Turnstile> ({s . t \<in> R s}) {|S|} q) \<Longrightarrow> \<Turnstile> ({:R:} p) {| S |} q"
  apply (simp add: Hoare_def angelic_def subset_eq)
  by auto

end


theory Algebra
imports Prelim
begin

fun is_times where "is_times a1 a2 a \<longleftrightarrow> a1 * a2 = a"
fun is_times1 where "is_times1 a1 a2 a \<longleftrightarrow> a1 * a2 = a"
fun is_plus where "is_plus a1 a2 a \<longleftrightarrow> a1 + a2 = a"
fun is_uminus where "is_uminus a b \<longleftrightarrow> - a = b"
fun is_zero where "is_zero a \<longleftrightarrow> a = 0"

lemmas is_defs = is_times.simps is_times1.simps is_plus.simps is_uminus.simps is_zero.simps

(* Sum of semigroups *)
nonfree_datatype ('a::semigroup_mult, 'b::semigroup_mult) ssum
  = Left 'a | Right 'b | Mult "('a, 'b) ssum" "('a, 'b) ssum"
where
  LeftPlus: "is_times a1 a2 a \<Longrightarrow> Mult (Left a1) (Left a2) = Left a"
 |RightPlus: "is_times1 b1 b2 b \<Longrightarrow> Mult (Right b1) (Right b2) = Right b"
 |Mult: "Mult (Mult x y) z = Mult x (Mult y z)"

instantiation ssum :: (semigroup_mult, semigroup_mult) semigroup_mult
begin
definition times_ssum where "x * y \<equiv> Mult x y"
instance apply default using Mult unfolding times_ssum_def by auto
end

(* Universal function for sums: *)
context
  fixes f :: "'a::semigroup_mult \<Rightarrow> 'c::semigroup_mult"
    and g :: "'b::semigroup_mult \<Rightarrow> 'c"
  assumes (* f and g are morphisms of semigroups *)
   f_times: "f (a1 * a2) = f a1 * f a2" and
   g_times: "g (b1 * b2) = g b1 * g b2"
begin

nonfree_primrec
suniv :: "('a, 'b) ssum \<Rightarrow> 'c"
where
  "suniv (Left a) = f a"
| "suniv (Right b) = g b"
| "suniv (Mult x y) = suniv x * suniv y"
by (auto simp: algebra_simps  f_times g_times)

end (* context *)

(* The ring of polynomials *)
nonfree_datatype ('a::comm_ring, 'b) poly
  = Sc 'a | Var 'b | Uminus "('a,'b) poly" |
    Plus "('a,'b) poly" "('a,'b) poly" | Times "('a,'b) poly" "('a,'b) poly"
where
  ScUminus: "is_uminus a b \<Longrightarrow> Uminus (Sc a) = Sc b"
 |ScPlus: "is_plus a1 a2 a \<Longrightarrow> Plus (Sc a1) (Sc a2) = Sc a"
 |ScTimes: "is_times a1 a2 a \<Longrightarrow> Times (Sc a1) (Sc a2) = Sc a"
 |PlusAssoc: "Plus (Plus P1 P2) P3 = Plus P1 (Plus P2 P3)"
 |PlusComm: "Plus P1 P2 = Plus P2 P1"
 |ZeroPlus: "is_zero a \<Longrightarrow> Plus (Sc a) P = P"
 |UminusPlus: "is_zero a \<Longrightarrow> Plus (Uminus P) P = Sc a"
 |TimesAssoc: "Times (Times P1 P2) P3 = Times P1 (Times P2 P3)"
 |TimesComm: "Times P1 P2 = Times P2 P1"
 |Distr: "Times (Plus P Q) R = Plus (Times P R) (Times Q R)"

lemmas poly_facts = ScUminus ScPlus ScTimes PlusAssoc PlusComm ZeroPlus UminusPlus TimesAssoc TimesComm Distr

(* Polynomials in the commutative-ring type class: *)
instantiation poly :: (comm_ring, type) comm_ring
begin
definition minus_poly where "P - Q = Plus P (Uminus Q)"
definition uminus_poly where "- P = Uminus P"
definition plus_poly where "P + Q = Plus P Q"
definition times_poly where "P * Q = Times P Q"
definition zero_poly where "0 = Sc 0"
instance apply default
unfolding minus_poly_def uminus_poly_def plus_poly_def times_poly_def zero_poly_def
by (metis poly_facts is_defs)+
end

(* Universal function for polynomials: *)
context
  fixes f :: "'a::comm_ring_1 \<Rightarrow>'c::comm_ring_1"
  and g :: "'b => 'c"
  assumes
   f_zero: "f 0 = 0" and
   f_one: "f 1 = 1" and
   f_uminus: "f (- a) = - f a" and
   f_plus: "f (a1 + a2) = f a1 + f a2" and
   f_times: "f (a1 * a2) = f a1 * f a2"
begin

nonfree_primrec
ext :: "('a,'b) poly \<Rightarrow> 'c"
where
  "ext (Sc a) = f a"
| "ext (Var b) = g b"
| "ext (Uminus P) = - ext P"
| "ext (Plus P Q) = ext P + ext Q"
| "ext (Times P Q) = ext P * ext Q"
by (auto simp: algebra_simps f_zero f_one f_uminus f_plus f_times)

end (* context *)

(* Polynomial valuation: *)
definition "pval \<equiv> ext id"

lemma pval_simps[simp]:
  "pval g (Sc a) = a"
  "pval g (Var b) = g b"
  "pval g (Uminus P) = - pval g P"
  "pval g (Plus P Q) = pval g P + pval g Q"
  "pval g (Times P Q) = pval g P * pval g Q"
unfolding pval_def by auto

end


(*
Authors:

  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk;
  Yijun He, University of Cambridge, yh403@cam.ac.uk
*)

theory More_Tensor
imports
  Quantum
  Tensor
  Jordan_Normal_Form.Matrix
  Basics
begin

lemma tensor_prod_2 [simp]:
"mult.vec_vec_Tensor (*) [x1::complex,x2] [x3, x4] = [x1 * x3, x1 * x4, x2 * x3, x2 * x4]"
proof -
  have "Matrix_Tensor.mult (1::complex) (*)"
    by (simp add: Matrix_Tensor.mult_def)
  thus "mult.vec_vec_Tensor (*) [x1::complex,x2] [x3,x4] = [x1*x3,x1*x4,x2*x3,x2*x4]"
    using mult.vec_vec_Tensor_def[of "(1::complex)" "(*)"] mult.times_def[of "(1::complex)" "(*)"] by simp
qed

lemma list_vec [simp]:
  assumes "v \<in> state_qbit 1"
  shows "list_of_vec v = [v $ 0, v $ 1]"
proof -
  have "Rep_vec v = (fst(Rep_vec v), snd(Rep_vec v))" by simp
  also have "\<dots> = (2, vec_index v)"
    by (metis (mono_tags, lifting) assms dim_vec.rep_eq mem_Collect_eq power_one_right state_qbit_def vec_index.rep_eq)
  moreover have "[0..<2::nat] = [0,1]"
    by(simp add: upt_rec)
  ultimately show ?thesis
    by(simp add: list_of_vec_def)
qed

lemma vec_tensor_prod_2 [simp]:
  assumes "v \<in> state_qbit 1" and "w \<in> state_qbit 1"
  shows "v \<otimes> w = vec_of_list [v $ 0 * w $ 0, v $ 0 * w $ 1, v $ 1 * w $ 0, v $ 1 * w $ 1]"
proof -
  have "list_of_vec v = [v $ 0, v $ 1]"
    using assms by simp
  moreover have "list_of_vec w = [w $ 0, w $ 1]"
    using assms by simp
  ultimately show "v \<otimes> w = vec_of_list [v $ 0 * w $ 0, v $ 0 * w $ 1, v $ 1 * w $ 0, v $ 1 * w $ 1]"
    by(simp add: tensor_vec_def)
qed

lemma vec_dim_of_vec_of_list [simp]:
  assumes "length l = n"
  shows "dim_vec (vec_of_list l) = n"
  using assms vec_of_list_def by simp

lemma vec_tensor_prod_2_bis [simp]:
  assumes "v \<in> state_qbit 1" and "w \<in> state_qbit 1"
  shows "v \<otimes> w = Matrix.vec 4 (\<lambda>i. if i = 0 then v $ 0 * w $ 0 else
                                      if i = 3 then v $ 1 * w $ 1 else
                                          if i = 1 then v $ 0 * w $ 1 else v $ 1 * w $ 0)"
proof
  define u where "u = Matrix.vec 4 (\<lambda>i. if i = 0 then v $ 0 * w $ 0 else
                                          if i = 3 then v $ 1 * w $ 1 else
                                            if i = 1 then v $ 0 * w $ 1 else v $ 1 * w $ 0)"
  then show f2:"dim_vec (v \<otimes> w) = dim_vec u"
    using assms by simp
  show "\<And>i. i < dim_vec u \<Longrightarrow> (v \<otimes> w) $ i = u $ i"
    apply (auto simp: u_def)
    using assms apply auto[3]
    apply (simp add: numeral_3_eq_3)
    using u_def vec_of_list_index vec_tensor_prod_2 index_is_2
    by (metis (no_types, lifting) One_nat_def assms nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
qed

lemma index_col_mat_of_cols_list [simp]:
  assumes "i < n" and "j < length l"
  shows "Matrix.col (mat_of_cols_list n l) j $ i = l ! j ! i"
  apply (auto simp: Matrix.col_def mat_of_cols_list_def)
  using assms less_le_trans by fastforce

lemma multTensor2 [simp]:
  assumes a1:"A = Matrix.mat 2 1 (\<lambda>(i,j). if i = 0 then a0 else a1)" and
          a2:"B = Matrix.mat 2 1 (\<lambda>(i,j). if i = 0 then b0 else b1)"
  shows "mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B) = [[a0*b0, a0*b1, a1*b0, a1*b1]]"
proof -
  have "mat_to_cols_list A = [[a0, a1]]"
    apply (auto simp: a1 mat_to_cols_list_def) by(simp add: numeral_2_eq_2)
  moreover have f2:"mat_to_cols_list B = [[b0, b1]]"
    apply (auto simp: a2 mat_to_cols_list_def) by(simp add: numeral_2_eq_2)
  ultimately have "mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B) =
                   mult.Tensor (*) [[a0,a1]] [[b0,b1]]" by simp
  thus ?thesis
    using mult.Tensor_def[of "(1::complex)" "(*)"] mult.times_def[of "(1::complex)" "(*)"]
    by (metis (mono_tags, lifting) append_self_conv list.simps(6) mult.Tensor.simps(2) mult.vec_mat_Tensor.simps(1)
mult.vec_mat_Tensor.simps(2) plus_mult_cpx plus_mult_def tensor_prod_2)
qed

lemma multTensor2_bis [simp]:
  assumes a1:"dim_row A = 2" and a2:"dim_col A = 1" and a3:"dim_row B = 2" and a4:"dim_col B = 1"
  shows "mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B) =
[[A $$ (0,0) * B $$ (0,0), A $$ (0,0) *  B $$ (1,0), A $$ (1,0) * B $$ (0,0), A $$ (1,0) * B $$ (1,0)]]"
proof -
  have "mat_to_cols_list A = [[A $$ (0,0), A $$ (1,0)]]"
    apply (auto simp: a1 a2 mat_to_cols_list_def) by(simp add: numeral_2_eq_2)
  moreover have f2:"mat_to_cols_list B = [[B $$ (0,0), B $$ (1,0)]]"
    apply (auto simp: a3 a4 mat_to_cols_list_def) by(simp add: numeral_2_eq_2)
  ultimately have "mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B) =
                   mult.Tensor (*) [[A $$ (0,0), A $$ (1,0)]] [[B $$ (0,0), B $$ (1,0)]]" by simp
  thus ?thesis
    using mult.Tensor_def[of "(1::complex)" "(*)"] mult.times_def[of "(1::complex)" "(*)"]
    by (smt append_self_conv list.simps(6) mult.Tensor.simps(2) mult.vec_mat_Tensor.simps(1)
mult.vec_mat_Tensor.simps(2) plus_mult_cpx plus_mult_def tensor_prod_2)
qed

lemma mat_tensor_prod_2_prelim [simp]:
  assumes "state 1 v" and "state 1 w"
  shows "v \<Otimes> w = mat_of_cols_list 4
[[v $$ (0,0) * w $$ (0,0), v $$ (0,0) * w $$ (1,0), v $$ (1,0) * w $$ (0,0), v $$ (1,0) * w $$ (1,0)]]"
proof
  define u where "u = mat_of_cols_list 4
[[v $$ (0,0) * w $$ (0,0), v $$ (0,0) * w $$ (1,0), v $$ (1,0) * w $$ (0,0), v $$ (1,0) * w $$ (1,0)]]"
  then show f1:"dim_row (v \<Otimes> w) = dim_row u"
    using assms state_def mat_of_cols_list_def tensor_mat_def by simp
  show f2:"dim_col (v \<Otimes> w) = dim_col u"
    using assms state_def mat_of_cols_list_def tensor_mat_def u_def by simp
  show "\<And>i j. i < dim_row u \<Longrightarrow> j < dim_col u \<Longrightarrow>  (v \<Otimes> w) $$ (i, j) = u $$ (i, j)"
      using u_def tensor_mat_def assms state_def by simp
qed

lemma mat_tensor_prod_2_col [simp]:
  assumes "state 1 v" and "state 1 w"
  shows "Matrix.col (v \<Otimes> w) 0 = Matrix.col v 0 \<otimes> Matrix.col w 0"
proof
  show f1:"dim_vec (Matrix.col (v \<Otimes> w) 0) = dim_vec (Matrix.col v 0 \<otimes> Matrix.col w 0)"
    using assms vec_tensor_prod_2_bis
    by (smt Tensor.mat_of_cols_list_def dim_col dim_row_mat(1) dim_vec mat_tensor_prod_2_prelim state.state_to_state_qbit)
next
  show "\<And>i. i<dim_vec (Matrix.col v 0 \<otimes> Matrix.col w 0) \<Longrightarrow> Matrix.col (v \<Otimes> w) 0 $ i = (Matrix.col v 0 \<otimes> Matrix.col w 0) $ i"
  proof -
    have "dim_vec (Matrix.col v 0 \<otimes> Matrix.col w 0) = 4"
      by (metis (no_types, lifting) assms(1) assms(2) dim_vec state.state_to_state_qbit vec_tensor_prod_2_bis)
    moreover have "(Matrix.col v 0 \<otimes> Matrix.col w 0) $ 0 = v $$ (0,0) * w $$ (0,0)"
      using assms vec_tensor_prod_2 state.state_to_state_qbit col_index_of_mat_col
      by (smt nth_Cons_0 power_one_right state_def vec_of_list_index zero_less_numeral)
    moreover have "\<dots> = Matrix.col (v \<Otimes> w) 0 $ 0"
      using assms by simp
    moreover have "(Matrix.col v 0 \<otimes> Matrix.col w 0) $ 1 = v $$ (0,0) * w $$ (1,0)"
      using assms vec_tensor_prod_2 state.state_to_state_qbit col_index_of_mat_col
      by (smt One_nat_def Suc_1 lessI nth_Cons_0 power_one_right state_def vec_index_vCons_Suc
vec_of_list_Cons vec_of_list_index zero_less_numeral)
    moreover have "\<dots> = Matrix.col (v \<Otimes> w) 0 $ 1"
      using assms by simp
    moreover have "(Matrix.col v 0 \<otimes> Matrix.col w 0) $ 2 = v $$ (1,0) * w $$ (0,0)"
      using assms vec_tensor_prod_2 state.state_to_state_qbit col_index_of_mat_col
      by (smt One_nat_def Suc_1 lessI nth_Cons_0 power_one_right state_def vec_index_vCons_Suc
vec_of_list_Cons vec_of_list_index zero_less_numeral)
    moreover have "\<dots> = Matrix.col (v \<Otimes> w) 0 $ 2"
      using assms by simp
    moreover have "(Matrix.col v 0 \<otimes> Matrix.col w 0) $ 3 = v $$ (1,0) * w $$ (1,0)"
      using assms vec_tensor_prod_2 state.state_to_state_qbit col_index_of_mat_col numeral_3_eq_3
  by (smt One_nat_def Suc_1 lessI nth_Cons_0 power_one_right state_def vec_index_vCons_Suc
vec_of_list_Cons vec_of_list_index zero_less_numeral)
    moreover have "\<dots> = Matrix.col (v \<Otimes> w) 0 $ 3"
      using assms by simp
    ultimately show "\<And>i. i<dim_vec (Matrix.col v 0 \<otimes> Matrix.col w 0) \<Longrightarrow> Matrix.col (v \<Otimes> w) 0 $ i = (Matrix.col v 0 \<otimes> Matrix.col w 0) $ i"
      using index_sl_four by auto
  qed
qed

lemma mat_tensor_prod_2 [simp]:
  assumes "state 1 v" and "state 1 w"
  shows "v \<Otimes> w = Matrix.mat 4 1 (\<lambda>(i,j). if i = 0 then v $$ (0,0) * w $$ (0,0) else
                                            if i = 3 then v $$ (1,0) * w $$ (1,0) else
                                              if i = 1 then v $$ (0,0) * w $$ (1,0) else
                                                v $$ (1,0) * w $$ (0,0))"
proof
  define u where "u = Matrix.mat 4 1 (\<lambda>(i,j). if i = 0 then v $$ (0,0) * w $$ (0,0) else
                                            if i = 3 then v $$ (1,0) * w $$ (1,0) else
                                              if i = 1 then v $$ (0,0) * w $$ (1,0) else
                                                v $$ (1,0) * w $$ (0,0))"
  then show "dim_row (v \<Otimes> w) = dim_row u"
    using assms tensor_mat_def state_def by(simp add: Tensor.mat_of_cols_list_def)
  also have "\<dots> = 4" by (simp add: u_def)
  show "dim_col (v \<Otimes> w) = dim_col u"
    using u_def assms tensor_mat_def state_def Tensor.mat_of_cols_list_def by simp
  moreover have "\<dots> = 1" by(simp add: u_def)
  ultimately show "\<And>i j. i < dim_row u \<Longrightarrow> j < dim_col u \<Longrightarrow> (v \<Otimes> w) $$ (i, j) = u $$ (i,j)"
  proof -
    fix i j::nat
    assume a1:"i < dim_row u" and a2:"j < dim_col u"
    then have "(v \<Otimes> w) $$ (i, j) = Matrix.col (v \<Otimes> w) 0 $ i"
      using Matrix.col_def u_def assms by simp
    then have f1:"(v \<Otimes> w) $$ (i, j) = (Matrix.col v 0 \<otimes> Matrix.col w 0) $ i"
      using assms mat_tensor_prod_2_col by simp
    have "(Matrix.col v 0 \<otimes> Matrix.col w 0) $ i =
 Matrix.vec 4 (\<lambda>i. if i = 0 then Matrix.col v 0 $ 0 * Matrix.col w 0 $ 0 else
                                      if i = 3 then Matrix.col v 0 $ 1 * Matrix.col w 0 $ 1 else
                                          if i = 1 then Matrix.col v 0 $ 0 * Matrix.col w 0 $ 1 else
                                            Matrix.col v 0 $ 1 * Matrix.col w 0 $ 0) $ i"
      using vec_tensor_prod_2_bis assms state.state_to_state_qbit by presburger
    thus "(v \<Otimes> w) $$ (i, j) = u $$ (i,j)"
      using u_def a1 a2 assms state_def by simp
  qed
qed

lemma mat_tensor_prod_2_bis:
  assumes "state 1 v" and "state 1 w"
  shows "v \<Otimes> w = |Matrix.vec 4 (\<lambda>i. if i = 0 then v $$ (0,0) * w $$ (0,0) else
                                          if i = 3 then v $$ (1,0) * w $$ (1,0) else
                                            if i = 1 then v $$ (0,0) * w $$ (1,0) else
                                              v $$ (1,0) * w $$ (0,0))\<rangle>"
  using assms ket_vec_def mat_tensor_prod_2 by(simp add: mat_eq_iff)

lemma eq_ket_vec:
  fixes u v:: "complex Matrix.vec"
  assumes "u = v"
  shows "|u\<rangle> = |v\<rangle>"
  using assms by simp

lemma mat_tensor_ket_vec:
  assumes "state 1 v" and "state 1 w"
  shows "v \<Otimes> w = |(Matrix.col v 0) \<otimes> (Matrix.col w 0)\<rangle>"
proof -
  have "v \<Otimes> w = |Matrix.col v 0\<rangle> \<Otimes> |Matrix.col w 0\<rangle>"
    using assms state_def by simp
  also have "\<dots> =
|Matrix.vec 4 (\<lambda>i. if i = 0 then |Matrix.col v 0\<rangle> $$ (0,0) * |Matrix.col w 0\<rangle> $$ (0,0) else
                                          if i = 3 then |Matrix.col v 0\<rangle> $$ (1,0) * |Matrix.col w 0\<rangle> $$ (1,0) else
                                            if i = 1 then |Matrix.col v 0\<rangle> $$ (0,0) * |Matrix.col w 0\<rangle> $$ (1,0) else
                                              |Matrix.col v 0\<rangle> $$ (1,0) * |Matrix.col w 0\<rangle> $$ (0,0))\<rangle>"
    using assms mat_tensor_prod_2_bis state_col_ket_vec by simp
  also have "\<dots> =
|Matrix.vec 4 (\<lambda>i. if i = 0 then v $$ (0,0) * w $$ (0,0) else
                                          if i = 3 then v $$ (1,0) * w $$ (1,0) else
                                            if i = 1 then v $$ (0,0) * w $$ (1,0) else
                                              v $$ (1,0) * w $$ (0,0))\<rangle>"
    using assms mat_tensor_prod_2_bis calculation by auto
  also have "\<dots> =
|Matrix.vec 4 (\<lambda>i. if i = 0 then Matrix.col v 0 $ 0 * Matrix.col w 0 $ 0 else
                                      if i = 3 then Matrix.col v 0 $ 1 * Matrix.col w 0 $ 1 else
                                          if i = 1 then Matrix.col v 0 $ 0 * Matrix.col w 0 $ 1 else
                                            Matrix.col v 0 $ 1 * Matrix.col w 0 $ 0)\<rangle>"
    apply(rule eq_ket_vec)
    apply (rule eq_vecI)
    using col_index_of_mat_col assms state_def apply auto[2].
  finally show ?thesis
    using vec_tensor_prod_2_bis assms state.state_to_state_qbit by presburger
qed

text \<open>The property of being a state (resp. a gate) is preserved by tensor product.\<close>

lemma tensor_state2 [simp]:
  assumes "state 1 u" and "state 1 v"
  shows "state 2 (u \<Otimes> v)"
proof
  show "dim_col (u \<Otimes> v) = 1"
    using assms dim_col_tensor_mat state.is_column by presburger
  show "dim_row (u \<Otimes> v) = 2\<^sup>2"
    using assms dim_row_tensor_mat state.dim_row
    by (metis (mono_tags, lifting) power2_eq_square power_one_right)
  show "\<parallel>Matrix.col (u \<Otimes> v) 0\<parallel> = 1"
  proof -
    define l where d0:"l = [u $$ (0,0) * v $$ (0,0), u $$ (0,0) * v $$ (1,0), u $$ (1,0) * v $$ (0,0), u $$ (1,0) * v $$ (1,0)]"
    then have f4:"length l = 4" by simp
    also have "u \<Otimes> v = mat_of_cols_list 4
[[u $$ (0,0) * v $$ (0,0), u $$ (0,0) * v $$ (1,0), u $$ (1,0) * v $$ (0,0), u $$ (1,0) * v $$ (1,0)]]"
      using assms by simp
    then have "Matrix.col (u \<Otimes> v) 0 = vec_of_list [u $$ (0,0) * v $$ (0,0), u $$ (0,0) * v $$ (1,0),
u $$ (1,0) * v $$ (0,0), u $$ (1,0) * v $$ (1,0)]"
      by (metis One_nat_def Suc_eq_plus1 add_Suc col_mat_of_cols_list list.size(3) list.size(4)
nth_Cons_0 numeral_2_eq_2 numeral_Bit0 plus_1_eq_Suc vec_of_list_Cons zero_less_one_class.zero_less_one)
    then have f5:"\<parallel>Matrix.col (u \<Otimes> v) 0\<parallel> = sqrt(\<Sum>i<4. (cmod (l ! i))\<^sup>2)"
      by (metis d0 f4 One_nat_def cpx_length_of_vec_of_list d0 vec_of_list_Cons)
    also have "\<dots> = sqrt ((cmod (u $$ (0,0) * v $$ (0,0)))\<^sup>2 + (cmod(u $$ (0,0) * v $$ (1,0)))\<^sup>2 +
(cmod(u $$ (1,0) * v $$ (0,0)))\<^sup>2 + (cmod(u $$ (1,0) * v $$ (1,0)))\<^sup>2)"
    proof -
      have "(\<Sum>i<4. (cmod (l ! i))\<^sup>2) = (cmod (l ! 0))\<^sup>2 + (cmod (l ! 1))\<^sup>2 + (cmod (l ! 2))\<^sup>2 +
(cmod (l ! 3))\<^sup>2"
        using sum_insert
        by (smt One_nat_def empty_iff finite.emptyI finite.insertI insertE lessThan_0 lessThan_Suc
numeral_2_eq_2 numeral_3_eq_3 numeral_plus_one one_plus_numeral_commute plus_1_eq_Suc semiring_norm(2)
semiring_norm(8) sum.empty)
      also have "\<dots> = (cmod (u $$ (0,0) * v $$ (0,0)))\<^sup>2 + (cmod(u $$ (0,0) * v $$ (1,0)))\<^sup>2 +
(cmod(u $$ (1,0) * v $$ (0,0)))\<^sup>2 + (cmod(u $$ (1,0) * v $$ (1,0)))\<^sup>2"
        using d0 by simp
      finally show ?thesis by(simp add: f5)
    qed
    moreover have "\<dots> =
sqrt ((cmod (u $$ (0,0)))\<^sup>2 * (cmod (v $$ (0,0)))\<^sup>2 + (cmod(u $$ (0,0)))\<^sup>2 * (cmod (v $$ (1,0)))\<^sup>2 +
(cmod(u $$ (1,0)))\<^sup>2 * (cmod (v $$ (0,0)))\<^sup>2 + (cmod(u $$ (1,0)))\<^sup>2 * (cmod(v $$ (1,0)))\<^sup>2)"
      by (simp add: norm_mult power_mult_distrib)
    moreover have "\<dots> = sqrt ((((cmod(u $$ (0,0)))\<^sup>2 + (cmod(u $$ (1,0)))\<^sup>2)) *
(((cmod(v $$ (0,0)))\<^sup>2 + (cmod(v $$ (1,0)))\<^sup>2)))"
      by (simp add: distrib_left mult.commute)
    ultimately have f6:"\<parallel>Matrix.col (u \<Otimes> v) 0\<parallel>\<^sup>2 = (((cmod(u $$ (0,0)))\<^sup>2 + (cmod(u $$ (1,0)))\<^sup>2)) *
(((cmod(v $$ (0,0)))\<^sup>2 + (cmod(v $$ (1,0)))\<^sup>2))"
      by (simp add: f4)
    also have f7:"\<dots> = (\<Sum>i< 2. (cmod (u $$ (i,0)))\<^sup>2) * (\<Sum>i<2. (cmod (v $$ (i,0)))\<^sup>2)"
      by (simp add: numeral_2_eq_2)
    also have f8:"\<dots> = (\<Sum>i< 2.(cmod (Matrix.col u 0 $ i))\<^sup>2) * (\<Sum>i<2.(cmod (Matrix.col v 0 $ i))\<^sup>2)"
      using assms index_col state_def by simp
    finally show ?thesis
    proof -
      have f1:"(\<Sum>i< 2.(cmod (Matrix.col u 0 $ i))\<^sup>2) = 1"
        using assms(1) state_def cpx_vec_length_def by auto
      have f2:"(\<Sum>i< 2.(cmod (Matrix.col v 0 $ i))\<^sup>2) = 1"
        using assms(2) state_def cpx_vec_length_def by auto
      thus ?thesis
        using f1 f8 f5 f6 f7
        by (simp add: \<open>sqrt (\<Sum>i<4. (cmod (l ! i))\<^sup>2) = sqrt ((cmod (u $$ (0, 0) * v $$ (0, 0)))\<^sup>2 +
(cmod (u $$ (0, 0) * v $$ (1, 0)))\<^sup>2 + (cmod (u $$ (1, 0) * v $$ (0, 0)))\<^sup>2 + (cmod (u $$ (1, 0) * v $$ (1, 0)))\<^sup>2)\<close>)
    qed
  qed
qed

lemma sum_prod:
  fixes f::"nat \<Rightarrow> complex" and g::"nat \<Rightarrow> complex"
  shows "(\<Sum>i<a*b. f(i div b) * g(i mod b)) = (\<Sum>i<a. f(i)) * (\<Sum>j<b. g(j))"
proof (induction a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  have "(\<Sum>i<(a+1)*b. f (i div b) * g (i mod b)) = (\<Sum>i<a*b. f (i div b) * g (i mod b)) +
(\<Sum>i\<in>{a*b..<(a+1)*b}. f (i div b) * g (i mod b))"
    apply (auto simp: algebra_simps)
    by (smt add.commute mult_Suc sum.lessThan_Suc sum.nat_group)
  also have "\<dots> = (\<Sum>i<a. f(i)) * (\<Sum>j<b. g(j)) + (\<Sum>i\<in>{a*b..<(a+1)*b}. f (i div b) * g (i mod b))"
    by (simp add: Suc.IH)
  also have "\<dots> = (\<Sum>i<a. f(i)) * (\<Sum>j<b. g(j)) + (\<Sum>i\<in>{a*b..<(a+1)*b}. f (a) * g(i-a*b))" by simp
  also have "\<dots> = (\<Sum>i<a. f(i)) * (\<Sum>j<b. g(j)) + f(a) * (\<Sum>i\<in>{a*b..<(a+1)*b}. g(i-a*b))"
    by(simp add: sum_distrib_left)
  also have "\<dots> = (\<Sum>i<a. f(i)) * (\<Sum>j<b. g(j)) + f(a) * (\<Sum>i\<in>{..<b}. g(i))"
    using sum_of_index_diff[of "g" "(a*b)" "b"] by (simp add: algebra_simps)
  ultimately show ?case  by (simp add: semiring_normalization_rules(1))
qed

lemma tensor_state [simp]:
  assumes "state m u" and "state n v"
  shows "state (m + n) (u \<Otimes> v)"
proof
  show c1:"dim_col (u \<Otimes> v) = 1"
    using assms dim_col_tensor_mat state.is_column by presburger
  show c2:"dim_row (u \<Otimes> v) = 2^(m + n)"
    using assms dim_row_tensor_mat state.dim_row by (metis power_add)
  have "(\<Sum>i<2^(m + n). (cmod (u $$ (i div 2 ^ n, 0) * v $$ (i mod 2 ^ n, 0)))\<^sup>2) =
(\<Sum>i<2^(m + n). (cmod (u $$ (i div 2 ^ n, 0)))\<^sup>2 * (cmod (v $$ (i mod 2 ^ n, 0)))\<^sup>2)"
    by (simp add: sqr_of_cmod_of_prod)
  also have "\<dots> = (\<Sum>i<2^m. (cmod (u $$ (i, 0)))\<^sup>2) * (\<Sum>i<2^n. (cmod (v $$ (i, 0)))\<^sup>2)"
  proof-
    have "\<dots> = (\<Sum>i<2^(m + n).complex_of_real((cmod (u $$ (i div 2^n,0)))\<^sup>2) * complex_of_real((cmod (v $$ (i mod 2^n,0)))\<^sup>2))"
      by simp
    moreover have "(\<Sum>i<2^m. (cmod (u $$ (i, 0)))\<^sup>2) = (\<Sum>i<2^m. complex_of_real ((cmod (u $$ (i,0)))\<^sup>2))" by simp
    moreover have "(\<Sum>i<2^n. (cmod (v $$ (i, 0)))\<^sup>2) = (\<Sum>i<2^n. complex_of_real ((cmod (v $$ (i, 0)))\<^sup>2))" by simp
    ultimately show ?thesis
      using sum_prod[of "\<lambda>i. (cmod (u $$ (i , 0)))\<^sup>2" "2^n" "\<lambda>i. (cmod (v $$ (i , 0)))\<^sup>2" "2^m"]
      by (smt of_real_eq_iff of_real_mult power_add)
  qed
  also have "\<dots> = 1"
  proof-
    have "(\<Sum>i<2^m. (cmod (u $$ (i, 0)))\<^sup>2) = 1"
      using assms(1) state_def cpx_vec_length_def by auto
    moreover have "(\<Sum>i<2^n. (cmod (v $$ (i, 0)))\<^sup>2) = 1"
      using assms(2) state_def cpx_vec_length_def by auto
    ultimately show ?thesis by simp
  qed
  ultimately show "\<parallel>Matrix.col (u \<Otimes> v) 0\<parallel> = 1"
    using c1 c2 assms state_def by (auto simp add: cpx_vec_length_def)
qed

lemma dim_row_of_tensor_gate:
  assumes "gate m G1" and "gate n G2"
  shows "dim_row (G1 \<Otimes> G2) = 2^(m+n)"
  using assms dim_row_tensor_mat gate.dim_row by (simp add: power_add)

lemma tensor_gate_sqr_mat:
  assumes "gate m G1" and "gate n G2"
  shows "square_mat (G1 \<Otimes> G2)"
  using assms gate.square_mat by simp

lemma dim_row_of_one_mat_less_pow:
  assumes "gate m G1" and "gate n G2" and "i < dim_row (1\<^sub>m(dim_col G1 * dim_col G2))"
  shows "i < 2^(m+n)"
  using assms gate_def by (simp add: power_add)

lemma dim_col_of_one_mat_less_pow:
  assumes "gate m G1" and "gate n G2" and "j < dim_col (1\<^sub>m(dim_col G1 * dim_col G2))"
  shows "j < 2^(m+n)"
  using assms gate_def by (simp add: power_add)

lemma index_tensor_gate_unitary1:
  assumes "gate m G1" and "gate n G2" and "i < dim_row (1\<^sub>m(dim_col G1 * dim_col G2))" and
"j < dim_col (1\<^sub>m(dim_col G1 * dim_col G2))"
  shows "((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) $$ (i, j) = 1\<^sub>m(dim_col G1 * dim_col G2) $$ (i, j)"
proof-
  have "\<And>k. k<2^(m+n) \<Longrightarrow> cnj((G1 \<Otimes> G2) $$ (k,i)) =
cnj(G1 $$ (k div 2^n, i div 2^n)) * cnj(G2 $$ (k mod 2^n, i mod 2^n))"
    using assms(1-3) by (simp add: gate_def power_add)
  moreover have "\<And>k. k<2^(m+n) \<Longrightarrow> (G1 \<Otimes> G2) $$ (k,j) =
                                   G1 $$ (k div 2^n, j div 2^n) * G2 $$ (k mod 2^n, j mod 2^n)"
    using assms(1,2,4) by (simp add: gate_def power_add)
  ultimately have "\<And>k. k<2^(m+n) \<Longrightarrow> cnj((G1 \<Otimes> G2) $$ (k,i)) * ((G1 \<Otimes> G2) $$ (k,j)) =
      cnj(G1 $$ (k div 2^n, i div 2^n)) * G1 $$ (k div 2^n, j div 2^n) *
      cnj(G2 $$ (k mod 2^n, i mod 2^n)) * G2 $$ (k mod 2^n, j mod 2^n)" by simp
  then have "(\<Sum>k<2^(m+n). cnj((G1 \<Otimes> G2) $$ (k,i)) * ((G1 \<Otimes> G2) $$ (k,j))) =
      (\<Sum>k<2^(m+n). cnj(G1 $$ (k div 2^n, i div 2^n)) * G1 $$ (k div 2^n, j div 2^n) *
                    cnj(G2 $$ (k mod 2^n, i mod 2^n)) * G2 $$ (k mod 2^n, j mod 2^n))" by simp
  also have "\<dots> =
             (\<Sum>k<2^m. cnj(G1 $$ (k, i div 2^n)) * G1 $$ (k, j div 2^n)) *
             (\<Sum>k<2^n. cnj(G2 $$ (k, i mod 2^n)) * G2 $$ (k, j mod 2^n))"
    using sum_prod[of "\<lambda>x. cnj(G1 $$ (x, i div 2^n)) * G1 $$ (x, j div 2^n)" "2^n"
"\<lambda>x. cnj(G2 $$ (x, i mod 2^n)) * G2 $$ (x, j mod 2^n)" "2^m"]
    by (metis (no_types, lifting) power_add semigroup_mult_class.mult.assoc sum.cong)
  also have "((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) $$ (i, j) = (\<Sum>k<2^(m+n).cnj((G1 \<Otimes> G2) $$ (k,i)) * ((G1 \<Otimes> G2) $$ (k,j)))"
    using assms index_matrix_prod[of "i" "(G1 \<Otimes> G2)\<^sup>\<dagger>" "j" "(G1 \<Otimes> G2)"] dagger_def
dim_row_of_tensor_gate tensor_gate_sqr_mat by simp
  ultimately have "((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) $$ (i,j) =
              (\<Sum>k1<2^m. cnj(G1 $$ (k1, i div 2^n)) * G1 $$ (k1, j div 2^n)) *
              (\<Sum>k2<2^n. cnj(G2 $$ (k2, i mod 2^n)) * G2 $$ (k2, j mod 2^n))" by simp
  moreover have "(\<Sum>k<2^m. cnj(G1 $$ (k, i div 2^n))* G1 $$ (k, j div 2^n)) = (G1\<^sup>\<dagger> * G1) $$ (i div 2^n, j div 2^n)"
      using assms gate_def dagger_def index_matrix_prod[of "i div 2^n" "G1\<^sup>\<dagger>" "j div 2^n" "G1"]
      by (simp add: less_mult_imp_div_less power_add)
  moreover have "\<dots> = 1\<^sub>m(2^m) $$ (i div 2^n, j div 2^n)"
    using assms(1,2) gate_def unitary_def by simp
  moreover have "(\<Sum>k<2^n. cnj(G2 $$ (k, i mod 2^n))* G2 $$ (k, j mod 2^n)) = (G2\<^sup>\<dagger> * G2) $$ (i mod 2^n, j mod 2^n)"
    using assms(1,2) gate_def dagger_def index_matrix_prod[of "i mod 2^n" "G2\<^sup>\<dagger>" "j mod 2^n" "G2"] by simp
  moreover have "\<dots> = 1\<^sub>m(2^n) $$ (i mod 2^n, j mod 2^n)"
    using assms(1,2) gate_def unitary_def by simp
  ultimately have "((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) $$ (i,j) = 1\<^sub>m (2^m) $$ (i div 2^n, j div 2^n) * 1\<^sub>m (2^n) $$ (i mod 2^n, j mod 2^n)"
    by simp
  thus ?thesis
    using assms assms(3,4) gate_def index_one_mat_div_mod[of "i" "m" "n" "j"] by(simp add: power_add)
qed

lemma tensor_gate_unitary1 [simp]:
  assumes "gate m G1" and "gate n G2"
  shows "(G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2) = 1\<^sub>m(dim_col G1 * dim_col G2)"
proof
  show "dim_row ((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) = dim_row (1\<^sub>m(dim_col G1 * dim_col G2))" by simp
  show "dim_col ((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) = dim_col (1\<^sub>m(dim_col G1 * dim_col G2))" by simp
  fix i j assume "i < dim_row (1\<^sub>m(dim_col G1 * dim_col G2))" and "j < dim_col (1\<^sub>m(dim_col G1 * dim_col G2))"
  thus "((G1 \<Otimes> G2)\<^sup>\<dagger> * (G1 \<Otimes> G2)) $$ (i, j) = 1\<^sub>m(dim_col G1 * dim_col G2) $$ (i, j)"
    using assms index_tensor_gate_unitary1 by simp
qed

lemma index_tensor_gate_unitary2 [simp]:
  assumes "gate m G1" and "gate n G2" and "i < dim_row (1\<^sub>m (dim_col G1 * dim_col G2))" and
"j < dim_col (1\<^sub>m (dim_col G1 * dim_col G2))"
  shows "((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) $$ (i, j) = 1\<^sub>m(dim_col G1 * dim_col G2) $$ (i, j)"
proof-
  have "\<And>k. k<2^(m+n) \<Longrightarrow> (G1 \<Otimes> G2) $$ (i,k) =
G1 $$ (i div 2^n, k div 2^n) * G2 $$ (i mod 2^n, k mod 2^n)"
    using assms(1-3) by (simp add: gate_def power_add)
  moreover have "\<And>k. k<2^(m+n) \<Longrightarrow> cnj((G1 \<Otimes> G2) $$ (j,k)) =
cnj(G1 $$ (j div 2^n, k div 2^n)) * cnj(G2 $$ (j mod 2^n, k mod 2^n))"
    using assms(1,2,4) by (simp add: gate_def power_add)
  ultimately have "\<And>k. k\<in>{..<2^(m+n)} \<Longrightarrow> (G1 \<Otimes> G2) $$ (i,k) * cnj((G1 \<Otimes> G2) $$ (j,k)) =
                         G1 $$ (i div 2^n, k div 2^n) * cnj(G1 $$ (j div 2^n, k div 2^n)) *
                         G2 $$ (i mod 2^n, k mod 2^n) * cnj(G2 $$ (j mod 2^n, k mod 2^n))" by simp
  then have "(\<Sum>k<2^(m+n). (G1 \<Otimes> G2) $$ (i,k) * cnj((G1 \<Otimes> G2) $$ (j,k))) =
      (\<Sum>k<2^(m+n). G1 $$ (i div 2^n, k div 2^n) * cnj(G1 $$ (j div 2^n, k div 2^n)) *
      G2 $$ (i mod 2^n, k mod 2^n) * cnj(G2 $$ (j mod 2^n, k mod 2^n)))" by simp
  also have "\<dots> =
             (\<Sum>k<2^m. G1 $$ (i div 2^n, k) * cnj(G1 $$ (j div 2^n, k))) *
             (\<Sum>k<2^n. G2 $$ (i mod 2^n, k) * cnj(G2 $$ (j mod 2^n, k)))"
    using sum_prod[of "\<lambda>k. G1 $$ (i div 2^n, k) * cnj(G1 $$ (j div 2^n, k))" "2^n"
                        "\<lambda>k. G2 $$ (i mod 2^n, k) * cnj(G2 $$ (j mod 2^n, k))" "2^m"]
    by (metis (no_types, lifting) power_add semigroup_mult_class.mult.assoc sum.cong)
  also have "((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) $$ (i, j) = (\<Sum>k<2^(m+n). (G1 \<Otimes> G2) $$ (i,k) * cnj((G1 \<Otimes> G2) $$ (j,k)))"
    using assms index_matrix_prod[of "i" "(G1 \<Otimes> G2)" "j" "(G1 \<Otimes> G2)\<^sup>\<dagger>"] dagger_def
dim_row_of_tensor_gate tensor_gate_sqr_mat by simp
  ultimately have "((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) $$ (i,j) =
             (\<Sum>k<2^m. G1 $$ (i div 2^n, k) * cnj(G1 $$ (j div 2^n, k))) *
             (\<Sum>k<2^n. G2 $$ (i mod 2^n, k) * cnj(G2 $$ (j mod 2^n, k)))" by simp
  moreover have "(\<Sum>k<2^m. G1 $$ (i div 2^n, k) * cnj(G1 $$ (j div 2^n, k))) = (G1 * (G1\<^sup>\<dagger>)) $$ (i div 2^n, j div 2^n)"
    using assms gate_def dagger_def index_matrix_prod[of "i div 2^n" "G1" "j div 2^n" "G1\<^sup>\<dagger>"]
    by (simp add: less_mult_imp_div_less power_add)
  moreover have "\<dots> = 1\<^sub>m(2^m) $$ (i div 2^n, j div 2^n)"
    using assms(1,2) gate_def unitary_def by simp
  moreover have "(\<Sum>k<2^n. G2 $$ (i mod 2^n, k) * cnj(G2 $$ (j mod 2^n, k))) = (G2 * (G2\<^sup>\<dagger>)) $$ (i mod 2^n, j mod 2^n)"
    using assms(1,2) gate_def dagger_def index_matrix_prod[of "i mod 2^n" "G2" "j mod 2^n" "G2\<^sup>\<dagger>"] by simp
  moreover have "\<dots> = 1\<^sub>m(2^n) $$ (i mod 2^n, j mod 2^n)"
    using assms(1,2) gate_def unitary_def by simp
  ultimately have "((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) $$ (i,j) = 1\<^sub>m(2^m) $$ (i div 2^n, j div 2^n) * 1\<^sub>m(2^n) $$ (i mod 2^n, j mod 2^n)"
    by simp
  thus ?thesis
    using assms gate_def index_one_mat_div_mod[of "i" "m" "n" "j"] by(simp add: power_add)
qed

lemma tensor_gate_unitary2 [simp]:
  assumes "gate m G1" and "gate n G2"
  shows "(G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>) = 1\<^sub>m(dim_col G1 * dim_col G2)"
proof
  show "dim_row ((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) = dim_row(1\<^sub>m (dim_col G1 * dim_col G2))"
    using assms gate_def by simp
  show "dim_col ((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) = dim_col (1\<^sub>m(dim_col G1 * dim_col G2))"
    using assms gate_def by simp
  fix i j assume "i < dim_row (1\<^sub>m (dim_col G1 * dim_col G2))" and "j < dim_col (1\<^sub>m (dim_col G1 * dim_col G2))"
  thus "((G1 \<Otimes> G2) * ((G1 \<Otimes> G2)\<^sup>\<dagger>)) $$ (i, j) = 1\<^sub>m(dim_col G1 * dim_col G2) $$ (i, j)"
    using assms index_tensor_gate_unitary2 by simp
qed

end


(*  Title:       Computing Square Roots using the Babylonian Method
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
section \<open>Auxiliary lemmas which might be moved into the Isabelle distribution.\<close>

theory Sqrt_Babylonian_Auxiliary
imports
  Complex_Main
begin

lemma mod_div_equality_int: "(n :: int) div x * x = n - n mod x"
  using div_mult_mod_eq[of n x] by arith

lemma div_is_floor_divide_rat: "n div y = \<lfloor>rat_of_int n / rat_of_int y\<rfloor>"
  unfolding Fract_of_int_quotient[symmetric] floor_Fract by simp

lemma div_is_floor_divide_real: "n div y = \<lfloor>real_of_int n / of_int y\<rfloor>"
  unfolding div_is_floor_divide_rat[of n y]
  by (metis Ratreal_def of_rat_divide of_rat_of_int_eq real_floor_code)

lemma floor_div_pos_int:
  fixes r :: "'a :: floor_ceiling"
  assumes n: "n > 0"
  shows "\<lfloor>r / of_int n\<rfloor> = \<lfloor>r\<rfloor> div n" (is "?l = ?r")
proof -
  let ?of_int = "of_int :: int \<Rightarrow> 'a"
  define rhs where "rhs = \<lfloor>r\<rfloor> div n"
  let ?n = "?of_int n"
  define m where "m = \<lfloor>r\<rfloor> mod n"
  let ?m = "?of_int m"
  from div_mult_mod_eq[of "floor r" n] have dm: "rhs * n + m = \<lfloor>r\<rfloor>" unfolding rhs_def m_def by simp
  have mn: "m < n" and m0: "m \<ge> 0" using n m_def by auto
  define e where "e = r - ?of_int \<lfloor>r\<rfloor>"
  have e0: "e \<ge> 0" unfolding e_def
    by (metis diff_self eq_iff floor_diff_of_int zero_le_floor)
  have e1: "e < 1" unfolding e_def
    by (metis diff_self dual_order.refl floor_diff_of_int floor_le_zero)
  have "r = ?of_int \<lfloor>r\<rfloor> + e" unfolding e_def by simp
  also have "\<lfloor>r\<rfloor> = rhs * n + m" using dm by simp
  finally have "r = ?of_int (rhs * n + m) + e" .
  hence "r / ?n = ?of_int (rhs * n) / ?n + (e + ?m) / ?n" using n by (simp add: field_simps)
  also have "?of_int (rhs * n) / ?n = ?of_int rhs" using n by auto
  finally have *: "r / ?of_int n = (e + ?of_int m) / ?of_int n + ?of_int rhs" by simp
  have "?l = rhs + floor ((e + ?m) / ?n)" unfolding * by simp
  also have "floor ((e + ?m) / ?n) = 0"
  proof (rule floor_unique)
    show "?of_int 0 \<le> (e + ?m) / ?n" using e0 m0 n
      by (metis add_increasing2 divide_nonneg_pos of_int_0 of_int_0_le_iff of_int_0_less_iff)
    show "(e + ?m) / ?n < ?of_int 0 + 1"
    proof (rule ccontr)
      from n have n': "?n > 0" "?n \<ge> 0" by simp_all
      assume "\<not> ?thesis"
      hence "(e + ?m) / ?n \<ge> 1" by auto
      from mult_right_mono[OF this n'(2)]
      have "?n \<le> e + ?m" using n'(1) by simp
      also have "?m \<le> ?n - 1" using mn
        by (metis of_int_1 of_int_diff of_int_le_iff zle_diff1_eq)
      finally have "?n \<le> e + ?n - 1" by auto
      with e1 show False by arith
    qed
  qed
  finally show ?thesis unfolding rhs_def by simp
qed

lemma floor_div_neg_int:
  fixes r :: "'a :: floor_ceiling"
  assumes n: "n < 0"
  shows "\<lfloor>r / of_int n\<rfloor> = \<lceil>r\<rceil> div n"
proof -
  from n have n': "- n > 0" by auto
  have "\<lfloor>r / of_int n\<rfloor> = \<lfloor> - r / of_int (- n)\<rfloor>" using n
    by (metis floor_of_int floor_zero less_int_code(1) minus_divide_left minus_minus nonzero_minus_divide_right of_int_minus)
  also have "\<dots> = \<lfloor> - r \<rfloor> div (- n)" by (rule floor_div_pos_int[OF n'])
  also have "\<dots> = \<lceil> r \<rceil> div n" using n
  by (metis ceiling_def div_minus_right)
  finally show ?thesis .
qed

lemma divide_less_floor1: "n / y < of_int (floor (n / y)) + 1"
  by (metis floor_less_iff less_add_one of_int_1 of_int_add)

context linordered_idom
begin

lemma sgn_int_pow_if [simp]:
  "sgn x ^ p = (if even p then 1 else sgn x)" if "x \<noteq> 0"
  using that by (induct p) simp_all

lemma compare_pow_le_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p \<le> y ^ p) = (x \<le> y)"
  by (metis eq_iff linear power_eq_imp_eq_base power_mono)

lemma compare_pow_less_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p < y ^ p) = (x < y)"
  by (metis power_less_imp_less_base power_strict_mono)

end

lemma quotient_of_int[simp]: "quotient_of (of_int i) = (i,1)"
  by (metis Rat.of_int_def quotient_of_int)

lemma quotient_of_nat[simp]: "quotient_of (of_nat i) = (int i,1)"
  by (metis Rat.of_int_def Rat.quotient_of_int of_int_of_nat_eq)

lemma square_lesseq_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x \<le> y * y) = (x \<le> y)"
  by (metis mult_mono mult_strict_mono' not_less)

lemma square_less_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x < y * y) = (x < y)"
  by (metis mult_mono mult_strict_mono' not_less)

lemma sqrt_sqrt[simp]: "x \<ge> 0 \<Longrightarrow> sqrt x * sqrt x = x"
  by (metis real_sqrt_pow2 power2_eq_square)

lemma abs_lesseq_square: "abs (x :: real) \<le> abs y \<longleftrightarrow> x * x \<le> y * y"
  using square_lesseq_square[of "abs x" "abs y"] by auto

end