(*  Title:      HOL/Decision_Procs/Rat_Pair.thy
    Author:     Amine Chaieb
*)

section \<open>Rational numbers as pairs\<close>

theory Rat_Pair
imports Complex_Main
begin

type_synonym Num = "int \<times> int"

abbreviation Num0_syn :: Num  ("0\<^sub>N")
  where "0\<^sub>N \<equiv> (0, 0)"

abbreviation Numi_syn :: "int \<Rightarrow> Num"  ("'((_)')\<^sub>N")
  where "(i)\<^sub>N \<equiv> (i, 1)"

definition isnormNum :: "Num \<Rightarrow> bool"
  where "isnormNum = (\<lambda>(a, b). if a = 0 then b = 0 else b > 0 \<and> gcd a b = 1)"

definition normNum :: "Num \<Rightarrow> Num"
where
  "normNum = (\<lambda>(a,b).
    (if a = 0 \<or> b = 0 then (0, 0)
     else
      (let g = gcd a b
       in if b > 0 then (a div g, b div g) else (- (a div g), - (b div g)))))"

declare gcd_dvd1[presburger] gcd_dvd2[presburger]

lemma normNum_isnormNum [simp]: "isnormNum (normNum x)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  consider "a = 0 \<or> b = 0" | "a \<noteq> 0" "b \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (simp add: x normNum_def isnormNum_def)
  next
    case ab: 2
    let ?g = "gcd a b"
    let ?a' = "a div ?g"
    let ?b' = "b div ?g"
    let ?g' = "gcd ?a' ?b'"
    from ab have "?g \<noteq> 0" by simp
    with gcd_ge_0_int[of a b] have gpos: "?g > 0" by arith
    have gdvd: "?g dvd a" "?g dvd b" by arith+
    from dvd_mult_div_cancel[OF gdvd(1)] dvd_mult_div_cancel[OF gdvd(2)] ab
    have nz': "?a' \<noteq> 0" "?b' \<noteq> 0" by - (rule notI, simp)+
    from ab have stupid: "a \<noteq> 0 \<or> b \<noteq> 0" by arith
    from div_gcd_coprime[OF stupid] have gp1: "?g' = 1" .
    from ab consider "b < 0" | "b > 0" by arith
    then show ?thesis
    proof cases
      case b: 1
      have False if b': "?b' \<ge> 0"
      proof -
        from gpos have th: "?g \<ge> 0" by arith
        from mult_nonneg_nonneg[OF th b'] dvd_mult_div_cancel[OF gdvd(2)]
        show ?thesis using b by arith
      qed
      then have b': "?b' < 0" by (presburger add: linorder_not_le[symmetric])
      from ab(1) nz' b b' gp1 show ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def)
    next
      case b: 2
      then have "?b' \<ge> 0"
        by (presburger add: pos_imp_zdiv_nonneg_iff[OF gpos])
      with nz' have b': "?b' > 0" by arith
      from b b' ab(1) nz' gp1 show ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def)
    qed
  qed
qed

text \<open>Arithmetic over Num\<close>

definition Nadd :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "+\<^sub>N" 60)
where
  "Nadd = (\<lambda>(a, b) (a', b').
    if a = 0 \<or> b = 0 then normNum (a', b')
    else if a' = 0 \<or> b' = 0 then normNum (a, b)
    else normNum (a * b' + b * a', b * b'))"

definition Nmul :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "*\<^sub>N" 60)
where
  "Nmul = (\<lambda>(a, b) (a', b').
    let g = gcd (a * a') (b * b')
    in (a * a' div g, b * b' div g))"

definition Nneg :: "Num \<Rightarrow> Num" ("~\<^sub>N")
  where "Nneg = (\<lambda>(a, b). (- a, b))"

definition Nsub :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "-\<^sub>N" 60)
  where "Nsub = (\<lambda>a b. a +\<^sub>N ~\<^sub>N b)"

definition Ninv :: "Num \<Rightarrow> Num"
  where "Ninv = (\<lambda>(a, b). if a < 0 then (- b, \<bar>a\<bar>) else (b, a))"

definition Ndiv :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "\<div>\<^sub>N" 60)
  where "Ndiv = (\<lambda>a b. a *\<^sub>N Ninv b)"

lemma Nneg_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (~\<^sub>N x)"
  by (simp add: isnormNum_def Nneg_def split_def)

lemma Nadd_normN[simp]: "isnormNum (x +\<^sub>N y)"
  by (simp add: Nadd_def split_def)

lemma Nsub_normN[simp]: "isnormNum y \<Longrightarrow> isnormNum (x -\<^sub>N y)"
  by (simp add: Nsub_def split_def)

lemma Nmul_normN[simp]:
  assumes xn: "isnormNum x"
    and yn: "isnormNum y"
  shows "isnormNum (x *\<^sub>N y)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0" | "a' = 0" | "a \<noteq> 0" "a' \<noteq> 0" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      using xn x y by (simp add: isnormNum_def Let_def Nmul_def split_def)
  next
    case 2
    then show ?thesis
      using yn x y by (simp add: isnormNum_def Let_def Nmul_def split_def)
  next
    case aa': 3
    then have bp: "b > 0" "b' > 0"
      using xn yn x y by (simp_all add: isnormNum_def)
    from bp have "x *\<^sub>N y = normNum (a * a', b * b')"
      using x y aa' bp by (simp add: Nmul_def Let_def split_def normNum_def)
    then show ?thesis by simp
  qed
qed

lemma Ninv_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (Ninv x)"
  apply (simp add: Ninv_def isnormNum_def split_def)
  apply (cases "fst x = 0")
  apply (auto simp add: gcd.commute)
  done

lemma isnormNum_int[simp]: "isnormNum 0\<^sub>N" "isnormNum ((1::int)\<^sub>N)" "i \<noteq> 0 \<Longrightarrow> isnormNum (i)\<^sub>N"
  by (simp_all add: isnormNum_def)

text \<open>Relations over Num\<close>

definition Nlt0:: "Num \<Rightarrow> bool"  ("0>\<^sub>N")
  where "Nlt0 = (\<lambda>(a, b). a < 0)"

definition Nle0:: "Num \<Rightarrow> bool"  ("0\<ge>\<^sub>N")
  where "Nle0 = (\<lambda>(a, b). a \<le> 0)"

definition Ngt0:: "Num \<Rightarrow> bool"  ("0<\<^sub>N")
  where "Ngt0 = (\<lambda>(a, b). a > 0)"

definition Nge0:: "Num \<Rightarrow> bool"  ("0\<le>\<^sub>N")
  where "Nge0 = (\<lambda>(a, b). a \<ge> 0)"

definition Nlt :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix "<\<^sub>N" 55)
  where "Nlt = (\<lambda>a b. 0>\<^sub>N (a -\<^sub>N b))"

definition Nle :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix "\<le>\<^sub>N" 55)
  where "Nle = (\<lambda>a b. 0\<ge>\<^sub>N (a -\<^sub>N b))"

definition "INum = (\<lambda>(a, b). of_int a / of_int b)"

lemma INum_int [simp]: "INum (i)\<^sub>N = (of_int i ::'a::field)" "INum 0\<^sub>N = (0::'a::field)"
  by (simp_all add: INum_def)

lemma isnormNum_unique[simp]:
  assumes na: "isnormNum x"
    and nb: "isnormNum y"
  shows "(INum x ::'a::{field_char_0,field}) = INum y \<longleftrightarrow> x = y"
  (is "?lhs = ?rhs")
proof
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0" | "a \<noteq> 0" "b \<noteq> 0" "a' \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?rhs if H: ?lhs
  proof cases
    case 1
    then show ?thesis
      using na nb H by (simp add: x y INum_def split_def isnormNum_def split: if_split_asm)
  next
    case 2
    with na nb have pos: "b > 0" "b' > 0"
      by (simp_all add: x y isnormNum_def)
    from H \<open>b \<noteq> 0\<close> \<open>b' \<noteq> 0\<close> have eq: "a * b' = a' * b"
      by (simp add: x y INum_def eq_divide_eq divide_eq_eq of_int_mult[symmetric] del: of_int_mult)
    from \<open>a \<noteq> 0\<close> \<open>a' \<noteq> 0\<close> na nb
    have gcd1: "gcd a b = 1" "gcd b a = 1" "gcd a' b' = 1" "gcd b' a' = 1"
      by (simp_all add: x y isnormNum_def add: gcd.commute)
    from eq have raw_dvd: "a dvd a' * b" "b dvd b' * a" "a' dvd a * b'" "b' dvd b * a'"
      apply -
      apply algebra
      apply algebra
      apply simp
      apply algebra
      done
    from zdvd_antisym_abs[OF coprime_dvd_mult[OF gcd1(2) raw_dvd(2)]
        coprime_dvd_mult[OF gcd1(4) raw_dvd(4)]]
      have eq1: "b = b'" using pos by arith
      with eq have "a = a'" using pos by simp
      with eq1 show ?thesis by (simp add: x y)
  qed
  show ?lhs if ?rhs
    using that by simp
qed

lemma isnormNum0[simp]: "isnormNum x \<Longrightarrow> INum x = (0::'a::{field_char_0,field}) \<longleftrightarrow> x = 0\<^sub>N"
  unfolding INum_int(2)[symmetric]
  by (rule isnormNum_unique) simp_all

lemma of_int_div_aux:
  assumes "d \<noteq> 0"
  shows "(of_int x ::'a::field_char_0) / of_int d =
    of_int (x div d) + (of_int (x mod d)) / of_int d"
proof -
  let ?t = "of_int (x div d) * (of_int d ::'a) + of_int (x mod d)"
  let ?f = "\<lambda>x. x / of_int d"
  have "x = (x div d) * d + x mod d"
    by auto
  then have eq: "of_int x = ?t"
    by (simp only: of_int_mult[symmetric] of_int_add [symmetric])
  then have "of_int x / of_int d = ?t / of_int d"
    using cong[OF refl[of ?f] eq] by simp
  then show ?thesis
    by (simp add: add_divide_distrib algebra_simps \<open>d \<noteq> 0\<close>)
qed

lemma of_int_div:
  fixes d :: int
  assumes "d \<noteq> 0" "d dvd n"
  shows "(of_int (n div d) ::'a::field_char_0) = of_int n / of_int d"
  using assms of_int_div_aux [of d n, where ?'a = 'a] by simp

lemma normNum[simp]: "INum (normNum x) = (INum x :: 'a::{field_char_0,field})"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  consider "a = 0 \<or> b = 0" | "a \<noteq> 0" "b \<noteq> 0" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (simp add: x INum_def normNum_def split_def Let_def)
  next
    case ab: 2
    let ?g = "gcd a b"
    from ab have g: "?g \<noteq> 0"by simp
    from of_int_div[OF g, where ?'a = 'a] show ?thesis
      by (auto simp add: x INum_def normNum_def split_def Let_def)
  qed
qed

lemma INum_normNum_iff: "(INum x ::'a::{field_char_0,field}) = INum y \<longleftrightarrow> normNum x = normNum y"
  (is "?lhs \<longleftrightarrow> _")
proof -
  have "normNum x = normNum y \<longleftrightarrow> (INum (normNum x) :: 'a) = INum (normNum y)"
    by (simp del: normNum)
  also have "\<dots> = ?lhs" by simp
  finally show ?thesis by simp
qed

lemma Nadd[simp]: "INum (x +\<^sub>N y) = INum x + (INum y :: 'a :: {field_char_0,field})"
proof -
  let ?z = "0::'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> a'= 0 \<or> b =0 \<or> b' = 0" | "a \<noteq> 0" "a'\<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      apply (cases "a = 0")
      apply (simp_all add: x y Nadd_def)
      apply (cases "b = 0")
      apply (simp_all add: INum_def)
      apply (cases "a'= 0")
      apply simp_all
      apply (cases "b'= 0")
      apply simp_all
      done
  next
    case neq: 2
    show ?thesis
    proof (cases "a * b' + b * a' = 0")
      case True
      then have "of_int (a * b' + b * a') / (of_int b * of_int b') = ?z"
        by simp
      then have "of_int b' * of_int a / (of_int b * of_int b') +
          of_int b * of_int a' / (of_int b * of_int b') = ?z"
        by (simp add: add_divide_distrib)
      then have th: "of_int a / of_int b + of_int a' / of_int b' = ?z"
        using neq by simp
      from True neq show ?thesis
        by (simp add: x y th Nadd_def normNum_def INum_def split_def)
    next
      case False
      let ?g = "gcd (a * b' + b * a') (b * b')"
      have gz: "?g \<noteq> 0"
        using False by simp
      show ?thesis
        using neq False gz
          of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * b' + b * a'" "b * b'"]]
          of_int_div [where ?'a = 'a, OF gz gcd_dvd2 [of "a * b' + b * a'" "b * b'"]]
        by (simp add: x y Nadd_def INum_def normNum_def Let_def) (simp add: field_simps)
    qed
  qed
qed

lemma Nmul[simp]: "INum (x *\<^sub>N y) = INum x * (INum y:: 'a::{field_char_0,field})"
proof -
  let ?z = "0::'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  consider "a = 0 \<or> a' = 0 \<or> b = 0 \<or> b' = 0" | "a \<noteq> 0" "a' \<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (auto simp add: x y Nmul_def INum_def)
  next
    case neq: 2
    let ?g = "gcd (a * a') (b * b')"
    have gz: "?g \<noteq> 0"
      using neq by simp
    from neq of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * a'" "b * b'"]]
      of_int_div [where ?'a = 'a , OF gz gcd_dvd2 [of "a * a'" "b * b'"]]
    show ?thesis
      by (simp add: Nmul_def x y Let_def INum_def)
  qed
qed

lemma Nneg[simp]: "INum (~\<^sub>N x) = - (INum x :: 'a::field)"
  by (simp add: Nneg_def split_def INum_def)

lemma Nsub[simp]: "INum (x -\<^sub>N y) = INum x - (INum y:: 'a::{field_char_0,field})"
  by (simp add: Nsub_def split_def)

lemma Ninv[simp]: "INum (Ninv x) = (1 :: 'a::field) / INum x"
  by (simp add: Ninv_def INum_def split_def)

lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y :: 'a::{field_char_0,field})"
  by (simp add: Ndiv_def)

lemma Nlt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) < 0) = 0>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nlt0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_less_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nlt0_def INum_def)
  qed
qed

lemma Nle0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) \<le> 0) = 0\<ge>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nle0_def INum_def)
  next
    case False
    then have b: "(of_int b :: 'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_le_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nle0_def INum_def)
  qed
qed

lemma Ngt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) > 0) = 0<\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Ngt0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_less_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Ngt0_def INum_def)
  qed
qed

lemma Nge0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "(INum x :: 'a::{field_char_0,linordered_field}) \<ge> 0 \<longleftrightarrow> 0\<le>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  show ?thesis
  proof (cases "a = 0")
    case True
    then show ?thesis
      by (simp add: x Nge0_def INum_def)
  next
    case False
    then have b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_le_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    show ?thesis
      by (simp add: x Nge0_def INum_def)
  qed
qed

lemma Nlt_iff[simp]:
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) < INum y) \<longleftrightarrow> x <\<^sub>N y"
proof -
  let ?z = "0::'a"
  have "((INum x ::'a) < INum y) \<longleftrightarrow> INum (x -\<^sub>N y) < ?z"
    using nx ny by simp
  also have "\<dots> \<longleftrightarrow> 0>\<^sub>N (x -\<^sub>N y)"
    using Nlt0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis
    by (simp add: Nlt_def)
qed

lemma Nle_iff[simp]:
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "((INum x :: 'a::{field_char_0,linordered_field}) \<le> INum y) \<longleftrightarrow> x \<le>\<^sub>N y"
proof -
  have "((INum x ::'a) \<le> INum y) \<longleftrightarrow> INum (x -\<^sub>N y) \<le> (0::'a)"
    using nx ny by simp
  also have "\<dots> \<longleftrightarrow> 0\<ge>\<^sub>N (x -\<^sub>N y)"
    using Nle0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis
    by (simp add: Nle_def)
qed

lemma Nadd_commute:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "x +\<^sub>N y = y +\<^sub>N x"
proof -
  have n: "isnormNum (x +\<^sub>N y)" "isnormNum (y +\<^sub>N x)"
    by simp_all
  have "(INum (x +\<^sub>N y)::'a) = INum (y +\<^sub>N x)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma normNum_nilpotent_aux[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  assumes nx: "isnormNum x"
  shows "normNum x = x"
proof -
  let ?a = "normNum x"
  have n: "isnormNum ?a" by simp
  have th: "INum ?a = (INum x ::'a)" by simp
  with isnormNum_unique[OF n nx] show ?thesis by simp
qed

lemma normNum_nilpotent[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "normNum (normNum x) = normNum x"
  by simp

lemma normNum0[simp]: "normNum (0, b) = 0\<^sub>N" "normNum (a, 0) = 0\<^sub>N"
  by (simp_all add: normNum_def)

lemma normNum_Nadd:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "normNum (x +\<^sub>N y) = x +\<^sub>N y"
  by simp

lemma Nadd_normNum1[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "normNum x +\<^sub>N y = x +\<^sub>N y"
proof -
  have n: "isnormNum (normNum x +\<^sub>N y)" "isnormNum (x +\<^sub>N y)"
    by simp_all
  have "INum (normNum x +\<^sub>N y) = INum x + (INum y :: 'a)"
    by simp
  also have "\<dots> = INum (x +\<^sub>N y)"
    by simp
  finally show ?thesis
    using isnormNum_unique[OF n] by simp
qed

lemma Nadd_normNum2[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "x +\<^sub>N normNum y = x +\<^sub>N y"
proof -
  have n: "isnormNum (x +\<^sub>N normNum y)" "isnormNum (x +\<^sub>N y)"
    by simp_all
  have "INum (x +\<^sub>N normNum y) = INum x + (INum y :: 'a)"
    by simp
  also have "\<dots> = INum (x +\<^sub>N y)"
    by simp
  finally show ?thesis
    using isnormNum_unique[OF n] by simp
qed

lemma Nadd_assoc:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  shows "x +\<^sub>N y +\<^sub>N z = x +\<^sub>N (y +\<^sub>N z)"
proof -
  have n: "isnormNum (x +\<^sub>N y +\<^sub>N z)" "isnormNum (x +\<^sub>N (y +\<^sub>N z))"
    by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma Nmul_commute: "isnormNum x \<Longrightarrow> isnormNum y \<Longrightarrow> x *\<^sub>N y = y *\<^sub>N x"
  by (simp add: Nmul_def split_def Let_def gcd.commute mult.commute)

lemma Nmul_assoc:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
    and nz: "isnormNum z"
  shows "x *\<^sub>N y *\<^sub>N z = x *\<^sub>N (y *\<^sub>N z)"
proof -
  from nx ny nz have n: "isnormNum (x *\<^sub>N y *\<^sub>N z)" "isnormNum (x *\<^sub>N (y *\<^sub>N z))"
    by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)"
    by simp
  with isnormNum_unique[OF n] show ?thesis
    by simp
qed

lemma Nsub0:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  assumes x: "isnormNum x"
    and y: "isnormNum y"
  shows "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = y"
proof -
  from isnormNum_unique[where 'a = 'a, OF Nsub_normN[OF y], where y="0\<^sub>N"]
  have "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> INum (x -\<^sub>N y) = (INum 0\<^sub>N :: 'a)"
    by simp
  also have "\<dots> \<longleftrightarrow> INum x = (INum y :: 'a)"
    by simp
  also have "\<dots> \<longleftrightarrow> x = y"
    using x y by simp
  finally show ?thesis .
qed

lemma Nmul0[simp]: "c *\<^sub>N 0\<^sub>N = 0\<^sub>N" " 0\<^sub>N *\<^sub>N c = 0\<^sub>N"
  by (simp_all add: Nmul_def Let_def split_def)

lemma Nmul_eq0[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0,field})"
  assumes nx: "isnormNum x"
    and ny: "isnormNum y"
  shows "x*\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = 0\<^sub>N \<or> y = 0\<^sub>N"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  have n0: "isnormNum 0\<^sub>N" by simp
  show ?thesis using nx ny
    apply (simp only: isnormNum_unique[where ?'a = 'a, OF  Nmul_normN[OF nx ny] n0, symmetric]
      Nmul[where ?'a = 'a])
    apply (simp add: x y INum_def split_def isnormNum_def split: if_split_asm)
    done
qed

lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
  by (simp add: Nneg_def split_def)

lemma Nmul1[simp]: "isnormNum c \<Longrightarrow> (1)\<^sub>N *\<^sub>N c = c" "isnormNum c \<Longrightarrow> c *\<^sub>N (1)\<^sub>N = c"
  apply (simp_all add: Nmul_def Let_def split_def isnormNum_def)
  apply (cases "fst c = 0", simp_all, cases c, simp_all)+
  done

end


(*  Title:      HOL/ex/Intuitionistic.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

Taken from FOL/ex/int.ML
*)

section {* Higher-Order Logic: Intuitionistic predicate calculus problems *}

theory Intuitionistic imports Main begin

(*Metatheorem (for PROPOSITIONAL formulae...):
  P is classically provable iff ~~P is intuitionistically provable.
  Therefore ~P is classically provable iff it is intuitionistically provable.

Proof: Let Q be the conjuction of the propositions A|~A, one for each atom A
in P.  Now ~~Q is intuitionistically provable because ~~(A|~A) is and because
~~ distributes over &.  If P is provable classically, then clearly Q-->P is
provable intuitionistically, so ~~(Q-->P) is also provable intuitionistically.
The latter is intuitionistically equivalent to ~~Q-->~~P, hence to ~~P, since
~~Q is intuitionistically provable.  Finally, if P is a negation then ~~P is
intuitionstically equivalent to P.  [Andy Pitts] *)

lemma "(~~(P&Q)) = ((~~P) & (~~Q))"
  by iprover

lemma "~~ ((~P --> Q) --> (~P --> ~Q) --> P)"
  by iprover

(* ~~ does NOT distribute over | *)

lemma "(~~(P-->Q))  = (~~P --> ~~Q)"
  by iprover

lemma "(~~~P) = (~P)"
  by iprover

lemma "~~((P --> Q | R)  -->  (P-->Q) | (P-->R))"
  by iprover

lemma "(P=Q) = (Q=P)"
  by iprover

lemma "((P --> (Q | (Q-->R))) --> R) --> R"
  by iprover

lemma "(((G-->A) --> J) --> D --> E) --> (((H-->B)-->I)-->C-->J)
      --> (A-->H) --> F --> G --> (((C-->B)-->I)-->D)-->(A-->C)
      --> (((F-->A)-->B) --> I) --> E"
  by iprover

(* Lemmas for the propositional double-negation translation *)

lemma "P --> ~~P"
  by iprover

lemma "~~(~~P --> P)"
  by iprover

lemma "~~P & ~~(P --> Q) --> ~~Q"
  by iprover

(* de Bruijn formulae *)

(*de Bruijn formula with three predicates*)
lemma "((P=Q) --> P&Q&R) &
       ((Q=R) --> P&Q&R) &
       ((R=P) --> P&Q&R) --> P&Q&R"
  by iprover

(*de Bruijn formula with five predicates*)
lemma "((P=Q) --> P&Q&R&S&T) &
       ((Q=R) --> P&Q&R&S&T) &
       ((R=S) --> P&Q&R&S&T) &
       ((S=T) --> P&Q&R&S&T) &
       ((T=P) --> P&Q&R&S&T) --> P&Q&R&S&T"
  by iprover

(*** Problems from Sahlin, Franzen and Haridi,
     An Intuitionistic Predicate Logic Theorem Prover.
     J. Logic and Comp. 2 (5), October 1992, 619-656.
***)

(*Problem 1.1*)
lemma "(ALL x. EX y. ALL z. p(x) & q(y) & r(z)) =
       (ALL z. EX y. ALL x. p(x) & q(y) & r(z))"
  by (iprover del: allE elim 2: allE')

(*Problem 3.1*)
lemma "~ (EX x. ALL y. p y x = (~ p x x))"
  by iprover

(* Intuitionistic FOL: propositional problems based on Pelletier. *)

(* Problem ~~1 *)
lemma "~~((P-->Q)  =  (~Q --> ~P))"
  by iprover

(* Problem ~~2 *)
lemma "~~(~~P  =  P)"
  by iprover

(* Problem 3 *)
lemma "~(P-->Q) --> (Q-->P)"
  by iprover

(* Problem ~~4 *)
lemma "~~((~P-->Q)  =  (~Q --> P))"
  by iprover

(* Problem ~~5 *)
lemma "~~((P|Q-->P|R) --> P|(Q-->R))"
  by iprover

(* Problem ~~6 *)
lemma "~~(P | ~P)"
  by iprover

(* Problem ~~7 *)
lemma "~~(P | ~~~P)"
  by iprover

(* Problem ~~8.  Peirce's law *)
lemma "~~(((P-->Q) --> P)  -->  P)"
  by iprover

(* Problem 9 *)
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by iprover

(* Problem 10 *)
lemma "(Q-->R) --> (R-->P&Q) --> (P-->(Q|R)) --> (P=Q)"
  by iprover

(* 11.  Proved in each direction (incorrectly, says Pelletier!!) *)
lemma "P=P"
  by iprover

(* Problem ~~12.  Dijkstra's law *)
lemma "~~(((P = Q) = R)  =  (P = (Q = R)))"
  by iprover

lemma "((P = Q) = R)  -->  ~~(P = (Q = R))"
  by iprover

(* Problem 13.  Distributive law *)
lemma "(P | (Q & R))  = ((P | Q) & (P | R))"
  by iprover

(* Problem ~~14 *)
lemma "~~((P = Q) = ((Q | ~P) & (~Q|P)))"
  by iprover

(* Problem ~~15 *)
lemma "~~((P --> Q) = (~P | Q))"
  by iprover

(* Problem ~~16 *)
lemma "~~((P-->Q) | (Q-->P))"
by iprover

(* Problem ~~17 *)
lemma "~~(((P & (Q-->R))-->S) = ((~P | Q | S) & (~P | ~R | S)))"
  oops

(*Dijkstra's "Golden Rule"*)
lemma "(P&Q) = (P = (Q = (P|Q)))"
  by iprover

(****Examples with quantifiers****)

(* The converse is classical in the following implications... *)

lemma "(EX x. P(x)-->Q)  -->  (ALL x. P(x)) --> Q"
  by iprover

lemma "((ALL x. P(x))-->Q) --> ~ (ALL x. P(x) & ~Q)"
  by iprover

lemma "((ALL x. ~P(x))-->Q)  -->  ~ (ALL x. ~ (P(x)|Q))"
  by iprover

lemma "(ALL x. P(x)) | Q  -->  (ALL x. P(x) | Q)"
  by iprover

lemma "(EX x. P --> Q(x)) --> (P --> (EX x. Q(x)))"
  by iprover

(* Hard examples with quantifiers *)

(*The ones that have not been proved are not known to be valid!
  Some will require quantifier duplication -- not currently available*)

(* Problem ~~19 *)
lemma "~~(EX x. ALL y z. (P(y)-->Q(z)) --> (P(x)-->Q(x)))"
  by iprover

(* Problem 20 *)
lemma "(ALL x y. EX z. ALL w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (EX x y. P(x) & Q(y)) --> (EX z. R(z))"
  by iprover

(* Problem 21 *)
lemma "(EX x. P-->Q(x)) & (EX x. Q(x)-->P) --> ~~(EX x. P=Q(x))"
  by iprover

(* Problem 22 *)
lemma "(ALL x. P = Q(x))  -->  (P = (ALL x. Q(x)))"
  by iprover

(* Problem ~~23 *)
lemma "~~ ((ALL x. P | Q(x))  =  (P | (ALL x. Q(x))))"
  by iprover

(* Problem 25 *)
lemma "(EX x. P(x)) &
       (ALL x. L(x) --> ~ (M(x) & R(x))) &
       (ALL x. P(x) --> (M(x) & L(x))) &
       ((ALL x. P(x)-->Q(x)) | (EX x. P(x)&R(x)))
   --> (EX x. Q(x)&P(x))"
  by iprover

(* Problem 27 *)
lemma "(EX x. P(x) & ~Q(x)) &
             (ALL x. P(x) --> R(x)) &
             (ALL x. M(x) & L(x) --> P(x)) &
             ((EX x. R(x) & ~ Q(x)) --> (ALL x. L(x) --> ~ R(x)))
         --> (ALL x. M(x) --> ~L(x))"
  by iprover

(* Problem ~~28.  AMENDED *)
lemma "(ALL x. P(x) --> (ALL x. Q(x))) &
       (~~(ALL x. Q(x)|R(x)) --> (EX x. Q(x)&S(x))) &
       (~~(EX x. S(x)) --> (ALL x. L(x) --> M(x)))
   --> (ALL x. P(x) & L(x) --> M(x))"
  by iprover

(* Problem 29.  Essentially the same as Principia Mathematica *11.71 *)
lemma "(((EX x. P(x)) & (EX y. Q(y))) -->
   (((ALL x. (P(x) --> R(x))) & (ALL y. (Q(y) --> S(y)))) =
    (ALL x y. ((P(x) & Q(y)) --> (R(x) & S(y))))))"
  by iprover

(* Problem ~~30 *)
lemma "(ALL x. (P(x) | Q(x)) --> ~ R(x)) &
       (ALL x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
   --> (ALL x. ~~S(x))"
  by iprover

(* Problem 31 *)
lemma "~(EX x. P(x) & (Q(x) | R(x))) &
        (EX x. L(x) & P(x)) &
        (ALL x. ~ R(x) --> M(x))
    --> (EX x. L(x) & M(x))"
  by iprover

(* Problem 32 *)
lemma "(ALL x. P(x) & (Q(x)|R(x))-->S(x)) &
       (ALL x. S(x) & R(x) --> L(x)) &
       (ALL x. M(x) --> R(x))
   --> (ALL x. P(x) & M(x) --> L(x))"
  by iprover

(* Problem ~~33 *)
lemma "(ALL x. ~~(P(a) & (P(x)-->P(b))-->P(c)))  =
       (ALL x. ~~((~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c))))"
  oops

(* Problem 36 *)
lemma
     "(ALL x. EX y. J x y) &
      (ALL x. EX y. G x y) &
      (ALL x y. J x y | G x y --> (ALL z. J y z | G y z --> H x z))
  --> (ALL x. EX y. H x y)"
  by iprover

(* Problem 39 *)
lemma "~ (EX x. ALL y. F y x = (~F y y))"
  by iprover

(* Problem 40.  AMENDED *)
lemma "(EX y. ALL x. F x y = F x x) -->
             ~(ALL x. EX y. ALL z. F z y = (~ F z x))"
  by iprover

(* Problem 44 *)
lemma "(ALL x. f(x) -->
             (EX y. g(y) & h x y & (EX y. g(y) & ~ h x y)))  &
             (EX x. j(x) & (ALL y. g(y) --> h x y))
             --> (EX x. j(x) & ~f(x))"
  by iprover

(* Problem 48 *)
lemma "(a=b | c=d) & (a=c | b=d) --> a=d | b=c"
  by iprover

(* Problem 51 *)
lemma "((EX z w. (ALL x y. (P x y = ((x = z) & (y = w))))) -->
  (EX z. (ALL x. (EX w. ((ALL y. (P x y = (y = w))) = (x = z))))))"
  by iprover

(* Problem 52 *)
(*Almost the same as 51. *)
lemma "((EX z w. (ALL x y. (P x y = ((x = z) & (y = w))))) -->
   (EX w. (ALL y. (EX z. ((ALL x. (P x y = (x = z))) = (y = w))))))"
  by iprover

(* Problem 56 *)
lemma "(ALL x. (EX y. P(y) & x=f(y)) --> P(x)) = (ALL x. P(x) --> P(f(x)))"
  by iprover

(* Problem 57 *)
lemma "P (f a b) (f b c) & P (f b c) (f a c) &
     (ALL x y z. P x y & P y z --> P x z) --> P (f a b) (f a c)"
  by iprover

(* Problem 60 *)
lemma "ALL x. P x (f x) = (EX y. (ALL z. P z y --> P z (f x)) & P x y)"
  by iprover

end


theory quantum_hoare_logic
imports Main  basic
begin

(*The datatype for representing syntax of quantum programs*)
datatype
com=SKIP
|Init "nat list" "number"
|Utrans "Mat" "number"
|Seq "com" "com"          ("(_;/ _)"   [61,59] 60  )
|Cond "(Mat * com * Mat) list"
|While "Mat" "Mat" "com" "Mat"
|While_n "Mat" "Mat" "com" "Mat" "nat"

primrec M_sum::"(Mat*com*Mat) list\<Rightarrow>Mat"where
"M_sum [] =zero"|
"M_sum (a#M) =mat_add (mat_mult (dag (fst a) ) (fst a)) (M_sum M )"
primrec sum::"nat list\<Rightarrow>nT\<Rightarrow>Mat\<Rightarrow>Mat" where
"sum [] f1 p=p"|
"sum (b#nl) f1 p = mat_add (mat_mult (mat_mult (f1 b) p) (dag (f1 b)) ) (sum nl f1 p )"
primrec sum_t::"nat list\<Rightarrow>nT\<Rightarrow>Mat\<Rightarrow>Mat"where
"sum_t [] f1 p=p"|
"sum_t (b#nl) f1 p = mat_add (mat_mult (mat_mult (dag (f1 b)) p)  (f1 b) ) (sum_t nl f1 p )"
primrec sum_1::"nat list\<Rightarrow>nT\<Rightarrow>Mat" where
"sum_1 [] f1 =I"|
"sum_1 (b#nl) f1 =mat_add (mat_mult (f1 b) (dag (f1 b))) (sum_1 nl f1)"
primrec sum_2::"nat list\<Rightarrow>nT\<Rightarrow>Mat" where
"sum_2 [] f1 =I"|
"sum_2 (b#nl) f1 =mat_add (mat_mult (dag (f1 b))  (f1 b)   ) (sum_2 nl f1)"

(*u a b =ab(dag a) *)
definition u::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"u a b= mat_mult (mat_mult a b) (dag a)"
(*u a b =(dag a)ba *)
definition uu::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"uu a b= mat_mult (mat_mult (dag a) b)  a"

 (*the rank function that defined for the denoFun*)
fun rank :: "com\<Rightarrow>nat" where
"rank SKIP =1"|
"rank (Utrans U n) =1"|
"rank (Init m n) =1"|
"rank (s1;s2) =1+ rank s2 + (rank s1 )"|
"rank (Cond mcl) =  (case mcl of [] \<Rightarrow> 1
  | mc # mcr \<Rightarrow> 1+rank (fst (snd mc)) + rank (Cond mcr)) "|
"rank (While_n m0 m1 s Q n)=  1 + n * rank (s)" |
"rank  (While  m0 m1 s Q )= 1"

lemma rank_pos : " rank ss > 0"
apply (induct ss, auto)
by (smt One_nat_def Suc_less_eq le_imp_less_Suc list.case(1) list.case(2) list.exhaust monoid_add_class.add.left_neutral monoid_add_class.add.right_neutral not_le order_refl plus_nat.simps(2) rank.simps(5) trans_le_add1 trans_le_add2)

(*definition of fixpoint*)
definition fixpoint::"Mat\<Rightarrow>Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"fixpoint m0 m1 s Q p=fixPoint"
definition fixpoint_wlp::"Mat\<Rightarrow>Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"fixpoint_wlp  m0 m1 s Q p=fixPoint_wlp"

(*the denotational semantics of quantum programs  *)
function denoFun::"com\<Rightarrow>Mat\<Rightarrow>Mat" where
"denoFun SKIP p=p"|
"denoFun (Utrans U n) p=mat_mult (mat_mult U p) (dag U)"|
"denoFun (Init m n) p=sum m f p "|
"denoFun (s1;s2) p= denoFun s2 (denoFun s1  p )"|
"denoFun (Cond mcl) p=  (case mcl of [] \<Rightarrow> zero
  | mc # mcr \<Rightarrow> mat_add (denoFun((fst (snd mc))) (u (fst mc) p) ) (denoFun (Cond mcr) p)) "|
"denoFun (While_n m0 m1 s Q n) p= (case n of 0\<Rightarrow>zero
                               | Suc m\<Rightarrow>
mat_add (u m0 p)  (denoFun (While_n m0 m1 s Q m) ( denoFun s (u m1 p))   ) )"
|"denoFun (While m0 m1 s Q) p= fixpoint  m0 m1 s Q  p"
by  pat_completeness auto
termination
 apply (relation "measure (\<lambda>(c,m).rank c)", auto )
by (metis rank_pos)

lemma rho: "a\<in>rhoMat\<Longrightarrow>(u m a) \<in>rhoMat"
by (metis a less3 rho_zero u_def)

fun rankf :: "com\<Rightarrow>nat" where
"rankf SKIP =1"|
"rankf (Utrans U n) =1"|
"rankf (Init m n) =1"|
"rankf (s1;s2) =1+ rankf s2 + (rankf s1 )"|
"rankf (Cond mcl) =  (case mcl of [] \<Rightarrow> 1
  | mc # mcr \<Rightarrow> 1+rankf (fst (snd mc)) + rankf (Cond mcr)) "|
"rankf (While_n m0 m1 s Q n)=  1 + rankf (s)" |
"rankf  (While  m0 m1 s Q )= 1 + rankf s"

lemma wellDefined_aux: "(x, xa, xb) \<in> set mcl \<Longrightarrow>
       (xc, xd) \<in> Basic_BNFs.snds (x, xa, xb) \<Longrightarrow>
       xe \<in> Basic_BNFs.fsts (xc, xd) \<Longrightarrow> rankf xe < (case mcl of [] \<Rightarrow> 1 | mc # mcr \<Rightarrow> 1 + rankf (fst (snd mc)) + rankf (Cond mcr))"
apply (induct mcl, auto)
by (metis fst_conv fsts.cases not_add_less1 not_less_eq sndI snds.cases)

(*the conditions that the commands should meet iff they are well-defined  *)
function wellDefined :: "com\<Rightarrow>bool" where
"wellDefined SKIP =True"|
"wellDefined (Utrans a n) = (a \<in> uMat)"|
"wellDefined (Init m n) =((sum_1 m f =I)\<and>(sum_2 m f=I))"|
"wellDefined (s1;s2) = (wellDefined (s1) & wellDefined (s2))"|
"wellDefined (Cond mcl) = ((M_sum mcl=I) \<and>
(\<forall>a aa b aaa ba xaaa. (a, aa, b) \<in> set mcl \<longrightarrow>
       (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
       xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa))"|
"wellDefined (While_n m0 m1 s Q n)= ((mat_add (mat_mult (dag m0) m0)  (mat_mult (dag m1) m1) =I) \<and> (wellDefined s) )" |
"wellDefined  (While  m0 m1 s Q )=((mat_add (mat_mult (dag m0) m0)  (mat_mult (dag m1) m1) =I)  \<and> (wellDefined s)  )  "
by  pat_completeness auto
termination
apply (relation "measure (\<lambda>(c).rankf c)", auto)
apply (rule wellDefined_aux, auto)
done

lemma au:" denoFun s1 a \<in> rhoMat \<Longrightarrow>\<forall>a. a \<in> rhoMat\<longrightarrow> denoFun s2 a \<in> rhoMat \<Longrightarrow> a \<in> rhoMat \<longrightarrow>denoFun s2 (denoFun s1 a) \<in> rhoMat"
apply auto
done

lemma init_rho: " a \<in> rhoMat \<Longrightarrow> sum list f a \<in> rhoMat"
apply(induct list,auto)
by (metis a less3 less6 rho_zero zero_add)

lemma while_rho:" \<forall>a. a \<in> rhoMat \<longrightarrow> denoFun s a \<in> rhoMat \<Longrightarrow>\<forall>a. a \<in> rhoMat\<longrightarrow>
    (case na of 0 \<Rightarrow> zero | Suc m \<Rightarrow> mat_add (u Mat1 a) (denoFun (While_n Mat1 Mat2 s Mat3 m) (denoFun s (u Mat2 a)))) \<in> rhoMat"
apply(induct na,auto)
apply (metis rho u_def zero_mult_l)
apply(subgoal_tac "(u Mat2 a)\<in>rhoMat")
prefer 2
apply (metis rho)
apply(subgoal_tac " (denoFun s (u Mat2 a))\<in>rhoMat")
prefer 2
apply metis
apply(drule_tac x="(denoFun s (u Mat2 a))" in spec)
by (metis a less3 less6 rho_zero u_def zero_add)
lemma rho1_aux:"\<forall>a. a \<in> rhoMat \<longrightarrow>less zero (fixpoint x1 x2 s x4 a) \<Longrightarrow>\<forall>a. a \<in> rhoMat \<longrightarrow> fixpoint x1 x2 s x4 a \<in> rhoMat"
by (simp add: a)
lemma rho2_aux:" \<forall>a. a \<in> rhoMat \<longrightarrow> denoFun s a \<in> rhoMat  \<Longrightarrow>\<forall>a. a \<in> rhoMat\<longrightarrow>
           basic.less zero (case n of 0 \<Rightarrow> zero | Suc m \<Rightarrow> mat_add (u x1 a)
         (denoFun (While_n x1 x2 s x4 m) (denoFun s (u x2 a))))"
apply(induct n,auto)
apply (metis I_zero less3 zero_mult_l)
apply(subgoal_tac "(u x2 a)\<in>rhoMat")
prefer 2
apply (metis rho)
apply(subgoal_tac " (denoFun s (u x2 a))\<in>rhoMat")
prefer 2
apply metis
apply(drule_tac x="(denoFun s (u x2 a))" in spec)
by (metis denoFun.simps(6) old.nat.simps(5) rho_zero while_rho)

(*fixpoint theory   [while_n]\<le>[while_n+1] \<Longrightarrow>0\<le>[while_n] \<Longrightarrow>fixpoint\<ge>0                        *)
axiomatization where
fixpoint_rho_lemma:"a\<in>rhoMat\<Longrightarrow>\<forall>n. less (denoFun (While_n x1 x2 s x4 n) a) (denoFun (While_n x1 x2 s x4 n) a) \<Longrightarrow>
\<forall>n. less zero (denoFun (While_n x1 x2 s x4 n) a) \<Longrightarrow>less zero(fixpoint x1 x2 s x4 a)" and
(*  Tr p*[while_n] \<le>Tr p*[while_n+1] \<Longrightarrow> Tr p*[while_n] \<le>x\<Longrightarrow>Tr p*fixpoint\<le>x                  *)
 fixpoint_lemma:" \<rho>\<in>rhoMat\<Longrightarrow>\<forall>n. Tr (mat_mult p (denoFun (While_n m0 m1 s Q n) \<rho>)) \<le> Tr (mat_mult p (denoFun (While_n m0 m1 s Q (Suc n) ) \<rho>)) \<Longrightarrow>
                 \<forall> n.  Tr (mat_mult p (denoFun (While_n m0 m1 s Q n) \<rho>) ) \<le> x \<Longrightarrow>
             Tr (mat_mult p (fixpoint  m0 m1 s Q \<rho>) )\<le>x"

lemma while_rho1_aux:" \<forall>a. a \<in> rhoMat \<longrightarrow> denoFun s a \<in> rhoMat \<Longrightarrow>
        \<forall>a. a \<in> rhoMat \<longrightarrow> basic.less (denoFun (While_n x1 x2 s x4 n) a) (denoFun (While_n x1 x2 s x4 n) a)"
apply(induct n,auto)
apply (metis I_zero less3 zero_mult_l)
apply(rule less1)
by (simp add: rho)

lemma while_rho1:"\<forall>a. a \<in> rhoMat \<longrightarrow> denoFun s a \<in> rhoMat \<Longrightarrow>\<forall>a. a \<in> rhoMat \<longrightarrow> fixpoint x1 x2 s x4 a \<in> rhoMat"
apply(rule rho1_aux,auto)
apply(rule fixpoint_rho_lemma)
apply simp
apply(rule allI)
apply(cut_tac while_rho1_aux,auto)
apply(simp add:rho2_aux)
done

lemma cond_rho_aux1:"\<forall>ab. ab\<in>rhoMat\<longrightarrow> denoFun aa ab \<in> rhoMat
\<Longrightarrow>\<forall>ab. ab\<in>rhoMat\<longrightarrow> denoFun aa (u a ab) \<in> rhoMat"
apply auto
apply(subgoal_tac "(u a ab)\<in>rhoMat")
prefer 2
using rho apply auto[1]
apply(drule_tac x="u a ab" in spec)
apply auto
done

lemma cond_rho_aux:"(denoFun aa (u a ab))\<in>rhoMat \<Longrightarrow>
 (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) ab)) (denoFun (Cond mcr) ab)) \<in> rhoMat
 \<Longrightarrow>mat_add (denoFun aa (u a ab))
        (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) ab)) (denoFun (Cond mcr) ab))
       \<in> rhoMat"
by (metis (lifting) a less6 rho_zero zero_add)

lemma cond_rho:" (\<forall>a aa b aaa ba xaaa.
\<forall>a. a \<in> rhoMat \<longrightarrow> (a, aa, b) \<in> set x \<longrightarrow>  (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
               xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> denoFun xaaa a \<in> rhoMat) \<Longrightarrow> \<forall>a. a \<in> rhoMat \<longrightarrow>
           (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) a)) (denoFun (Cond mcr) a)) \<in> rhoMat"
apply(induct x,auto)
apply (metis Nitpick.case_nat_unfold denoFun.simps(1) while_rho)
apply(drule_tac x="ab"in spec,auto)
apply(rule cond_rho_aux,auto)
apply(cut_tac cond_rho_aux1,auto)
proof -
  fix a :: Mat and aa :: com and b :: Mat and xa :: "(Mat \<times> com \<times> Mat) list" and ab :: Mat and aba :: Mat
  assume "aba \<in> rhoMat"
  have f1: "\<forall>b ba. \<not> ba \<or> b \<or> \<not> ba \<le> b \<or> b"
    by simp
  have "\<forall>p. (p zero\<Colon>bool) \<le> p I"
    by (metis (no_types) I_zero Ident a less2 zero_mult_l)
  hence "I = zero"
    using f1 by (meson insertCI singletonD)
  thus "denoFun aa aba \<in> rhoMat"
    by (metis (full_types) I_zero Ident a zero_mult_l)
qed

(* a\<in>rhoMat\<Longrightarrow>denoFun s a \<in>rhoMat      *)
lemma bb:"\<forall>a. a\<in>rhoMat\<longrightarrow>(denoFun s a) \<in>rhoMat"
apply(induct s,auto)
apply(rule init_rho,auto)
apply (metis rho u_def)
prefer 3
apply(cut_tac while_rho,auto)
prefer 2
apply(cut_tac while_rho1,auto)
apply(cut_tac cond_rho,auto)
done

lemma b:"a\<in>rhoMat\<Longrightarrow>(denoFun s a) \<in>rhoMat"
apply(simp add:bb)
done

(*the ascending  order of denotational semantics of while_n *)
lemma ascend:"\<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow> less  (denoFun (While_n m0 m1 s Q n) \<rho>)   (denoFun (While_n m0 m1 s Q (Suc n) ) \<rho>) "
apply(induct n,auto)
apply (metis less3 rho_zero u_def zero_add)
apply(rule less1)
by (metis Nitpick.case_nat_unfold b rho)

lemma ascend1:"less P I\<Longrightarrow>\<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow>Tr (mat_mult (mat_sub I P) (denoFun (While_n m0 m1 s Q n) \<rho>)) \<le>
   Tr (mat_mult (mat_sub I P)  (denoFun (While_n m0 m1 s Q (Suc n) ) \<rho>))"
apply(induct n,auto)
apply (metis less4 less5 rho rho_zero sub_self zero_add zero_mult_r zero_tr)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(subgoal_tac "(denoFun s (u m1 \<rho>))\<in>rhoMat")
prefer 2
apply (metis b rho)
apply(drule_tac x="(denoFun s (u m1 \<rho>))"in spec,auto)
done

(*the definition of valid *)
definition valid::"Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>bool" where
"  valid P S Q= (\<forall>\<rho>. \<rho> \<in> rhoMat\<longrightarrow> Tr (mat_mult P \<rho>)<= Tr (mat_mult Q (denoFun S \<rho>))+Tr \<rho>-Tr (denoFun S \<rho>)   )"
(*svalid is equal to valid ,just for simplication*)
definition svalid::"Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>bool"where
"svalid P S Q=(\<forall> \<rho> .\<rho>\<in>rhoMat\<longrightarrow> Tr (mat_mult (mat_sub I Q) (denoFun S \<rho>)) <= Tr (mat_mult (mat_sub I P) \<rho>) )"
lemma eq_valid:"svalid P S Q  \<Longrightarrow>valid P S Q"
apply(simp add:valid_def)
apply(simp add:svalid_def)
apply(simp add:mult_sub_allo1)
apply(simp add:tr_allo1)
apply(simp add:Ident)
apply auto
done

lemma eq_valid2:"valid P S Q\<Longrightarrow>svalid P S Q"
apply(simp add:valid_def)
apply(simp add:svalid_def)
apply(simp add:mult_sub_allo1)
apply(simp add:tr_allo1)
apply(simp add:Ident)
apply auto
done

lemma b1:" (mat_mult (mat_mult (mat_mult a b) c) d) =mat_mult (mat_mult a b) (mat_mult c d)"
apply (simp add:mult_exchange)
done

lemma b2:" (mat_mult (mat_mult b d) (mat_mult a c)) =mat_mult (mat_mult (mat_mult b d) a) c"
apply (simp add:mult_exchange)
done

lemma b3:" Tr (mat_mult (mat_mult (mat_mult e  b) d) c)=Tr (mat_mult b (mat_mult (mat_mult d c) e ))"
apply(simp add:b1)
apply(simp add:exchange)
apply(simp add:b2)
apply(simp add:exchange)
done

lemma b4:"mat_mult (dag U) (mat_mult U \<rho>) =mat_mult(mat_mult (dag U) U) \<rho>"
apply(simp add:mult_exchange)
done

lemma temp:"Tr (sum m f \<rho> ) =Tr  (mat_mult \<rho> (sum_2 m  f) ) "
apply(induct m)
apply auto
apply (metis Ident exchange)
by (metis exchange mult_allo2 mult_exchange tr_allo)

lemma m_init:"sum_1 m  f=I\<Longrightarrow>sum_2 m  f=I\<Longrightarrow>Tr (sum m f \<rho> ) =Tr \<rho>"
apply(simp add:temp)
apply(subgoal_tac " Tr (mat_mult \<rho> I) = Tr (mat_mult I \<rho> ) ")
apply(simp add:Ident)
apply(simp add:exchange)
done

lemma neq:"(b::real)\<le>(d::real)\<Longrightarrow>a+d\<le>(c::real)\<Longrightarrow>a+b\<le>c"
apply auto
done

lemma While_n:" mat_add (mat_mult (dag m0) m0) (mat_mult (dag m1) m1) = I \<Longrightarrow>
        less (mat_add (uu m0 P) (uu m1 Q)) I\<Longrightarrow>
         valid Q S (mat_add (uu m0 P) (uu m1 Q)) \<Longrightarrow>
    \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) (denoFun S \<rho>)) \<le> Tr (mat_mult (mat_sub I Q) \<rho>) \<Longrightarrow>
        \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow>
   Tr (mat_mult (mat_sub I P) (denoFun (While_n m0 m1 S Q n) \<rho>)) \<le> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) \<rho>) "
apply(induct n,auto)
defer
apply(subgoal_tac "(denoFun S (u m1 \<rho>)) \<in>rhoMat")
prefer 2
apply (metis b rho)
apply(drule_tac x=" (denoFun S (u m1 \<rho>))" in spec)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(cut_tac a="Tr (mat_mult (mat_sub I P) (u m0 \<rho>))" and c="Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) \<rho>)
"and b=" Tr (mat_mult (mat_sub I P)
                (case n of 0 \<Rightarrow> zero
                 | Suc m \<Rightarrow> mat_add (u m0 (denoFun S (u m1 \<rho>))) (denoFun (While_n m0 m1 S Q m) (denoFun S (u m1 (denoFun S (u m1 \<rho>)))))))"
and d=" Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) (denoFun S (u m1 \<rho>))) " in neq)
apply auto
apply(subgoal_tac "(u m1 \<rho>) \<in>rhoMat")
prefer 2
apply (metis rho)
apply(drule_tac x=" (u m1 \<rho>)" in spec)
apply(cut_tac a=" Tr (mat_mult (mat_sub I P) (u m0 \<rho>))" and c="Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) \<rho>)"
and b=" Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) (denoFun S (u m1 \<rho>)))"
and d=" Tr (mat_mult (mat_sub I Q) (u m1 \<rho>))" in neq)
apply auto
apply (smt Ident b3 mult_allo1 mult_exchange mult_sub_allo1 tr_allo tr_allo1 u_def uu_def)
apply(simp add:zero_mult_r)
by (metis less4 less5 rho_zero sub_self zero_tr)

primrec sum1::"(Mat*com*Mat) list\<Rightarrow>Mat"where
"sum1 []  =zero"|
"sum1  (a#M)  =  (mat_add (uu (fst a ) (snd (snd a)))  (sum1 M  ))  "
primrec sum4::"(Mat*com) list\<Rightarrow>Mat"where
"sum4 [] =zero"|
"sum4 (a#M)  =mat_add (mat_mult (dag (fst a) ) (fst a)) (sum4 M )"

primrec validlist :: "(Mat * com * Mat) list \<Rightarrow> Mat \<Rightarrow> bool" where
"validlist [] Q = True "
| "validlist (a # mcml) Q = ( (valid (snd (snd a)) (fst (snd a)) Q) \<and> (validlist  mcml Q) )"

lemma w4:"\<lbrakk>valid Q S (mat_add (uu m0 P) (uu m1 Q)) \<Longrightarrow>svalid Q S (mat_add (uu m0 P) (uu m1 Q));svalid Q S (mat_add (uu m0 P) (uu m1 Q))
 \<Longrightarrow>svalid (mat_add (uu m0 P) (uu m1 Q)) (While m0 m1 S Q ) P\<rbrakk>\<Longrightarrow>valid Q S (mat_add (uu m0 P) (uu m1 Q))
 \<Longrightarrow>svalid (mat_add (uu m0 P) (uu m1 Q))  (While m0 m1 S Q ) P"
apply auto
done
lemma o1:" Tr (mat_mult P \<rho>) <=Tr (mat_mult P1 \<rho>)\<Longrightarrow>
           ( Tr (mat_mult P1 \<rho>) <= Tr (mat_mult Q (denoFun S \<rho>)) + Tr \<rho> - Tr (denoFun S \<rho>) \<Longrightarrow>
         Tr (mat_mult P \<rho>) <= Tr (mat_mult Q (denoFun S \<rho>)) + Tr \<rho> - Tr (denoFun S \<rho>) ) "
apply(auto)
done
lemma Initfact: "\<rho> \<in> rhoMat \<Longrightarrow> Tr (mat_mult (sum_t m f P ) \<rho>) = Tr (mat_mult P (sum m f \<rho> ))"
apply (induct m,auto)
apply(simp add:mult_allo1)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(simp add:b3)
done
lemma mea_\<rho>:"wellDefined (Cond M) \<Longrightarrow>\<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q (denoFun (Cond M) \<rho>)) + Tr (mat_mult (M_sum M) \<rho>) - Tr (denoFun (Cond M) \<rho>)
\<Longrightarrow> \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q (denoFun (Cond M) \<rho>)) + Tr \<rho> - Tr (denoFun (Cond M) \<rho>)"
by (metis Ident wellDefined.simps(5))
lemma neq1:"(b::real)\<le>d\<Longrightarrow>a\<le>c\<Longrightarrow>(b+a)\<le>(d+c)"
apply auto
done

lemma neq3:"(a::real)\<le>b\<Longrightarrow>c\<le>a\<Longrightarrow>b\<le>d\<Longrightarrow>c\<le>d"
apply auto
done

lemma neq2:"(a::real)\<le>c\<Longrightarrow>c\<le>b\<Longrightarrow>a\<le>b"
by auto

lemma mea1:"validlist M Q \<Longrightarrow> \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow>
        Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q (denoFun (Cond M) \<rho>)) + Tr (mat_mult (M_sum M) \<rho>) - Tr (denoFun (Cond M) \<rho>)"
apply(induct M,auto)
apply (smt I_zero less4 rho_zero zero_mult_l zero_mult_r zero_tr)
apply(simp add:mult_allo1)
apply(simp add:tr_allo)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(cut_tac b="Tr (mat_mult (sum1 M) \<rho>)" and d="Tr (mat_mult Q
                   (case M of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))) +
              Tr (mat_mult (M_sum M) \<rho>) -
              Tr (case M of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))"
and a=" Tr (mat_mult (uu a b) \<rho>)" and c=" Tr (mat_mult Q (denoFun aa (u a \<rho>)))+ (Tr (mat_mult (mat_mult (dag a) a) \<rho>))-Tr (denoFun aa (u a \<rho>))"
in neq1,auto)
apply(simp add:valid_def)
apply(subgoal_tac "\<rho>\<in>rhoMat\<Longrightarrow>(u a \<rho>)\<in>rhoMat")
prefer 2
apply (metis rho)
apply(drule_tac x="(u a \<rho>)"in spec)
apply(drule_tac x="(u a \<rho>)"in spec,auto)
by (metis exchange mult_exchange u_def uu_def)

(*   six rules         *)
lemma Skip:"valid P SKIP P"
apply (simp add:valid_def)
done

lemma Utrans:"wellDefined (Utrans U n) \<Longrightarrow>valid  (mat_mult (mat_mult (dag U) P) U)  (Utrans U n) P"
apply(simp add:valid_def)
apply(simp add:b3)
apply(simp add:exchange)
apply(simp add:b4)
apply(simp add:U_dag)
apply(simp add:Ident)
done

lemma Init:"wellDefined (Init m n) \<Longrightarrow>valid (sum_t m f P)  (Init m n) P"
apply(simp add:valid_def, auto)
apply(simp add:m_init)
apply (simp add: Initfact)
done

lemma Seq:"valid P s1 Q\<Longrightarrow>valid Q s2 R\<Longrightarrow>valid P (s1;s2) R"
apply(simp add:valid_def,auto)
apply(drule_tac x=" \<rho>" in spec)
apply(subgoal_tac " \<rho> \<in> rhoMat\<Longrightarrow>denoFun s1 \<rho> \<in> rhoMat")
apply auto
by (metis b)

lemma Measure:"wellDefined (Cond M) \<Longrightarrow> validlist M Q \<Longrightarrow> valid (sum1 M) (Cond M ) Q"
unfolding valid_def
apply(rule mea_\<rho>)
apply(simp)
apply(rule mea1,auto)
done

lemma While:"wellDefined (While m0 m1 S Q) \<Longrightarrow> less (mat_add (uu m0 P) (uu m1 Q)) I\<Longrightarrow>less P I\<Longrightarrow>valid Q S (mat_add (uu m0 P) (uu m1 Q)) \<Longrightarrow>valid (mat_add (uu m0 P) (uu m1 Q))
          (While m0 m1 S Q ) P"
apply(rule eq_valid)
apply(rule w4,auto)
apply(simp add:eq_valid2)
apply(simp add:svalid_def,auto)
apply (rule fixpoint_lemma)
apply(simp)
apply (metis ascend1)
apply (rule allI)
apply(subgoal_tac "less zero (mat_sub I P)")
prefer 2
apply (metis less5 sub_self)
apply(cut_tac While_n, auto)
done

lemma order:"\<lbrakk>less P Pa;valid Pa S Q\<rbrakk>\<Longrightarrow>valid P S Q"
apply(simp add:valid_def)
apply(auto)
apply(drule_tac x=" \<rho>" in spec)
apply(rule o1,auto)
apply(simp add:less2)
done

lemma Order:"\<lbrakk>less P Pa;valid Pa S Qa;less Qa Q\<rbrakk>\<Longrightarrow>valid P S Q"
apply(simp add:valid_def,auto)
apply(drule_tac x=" \<rho>" in spec)
apply(rule o1,auto)
apply(cut_tac a=" Tr (mat_mult Pa \<rho>)"and b="Tr (mat_mult Qa (denoFun S \<rho>)) + Tr \<rho> - Tr (denoFun S \<rho>)"
and c=" Tr (mat_mult P \<rho>)" and d="Tr (mat_mult Q (denoFun S \<rho>)) + Tr \<rho> - Tr (denoFun S \<rho>)"in neq3,auto)
apply (metis less2)
by (metis b less2)

(*     about wlp          *)
definition matsum::"nat list\<Rightarrow>nat\<Rightarrow>Mat\<Rightarrow>Mat" where
"matsum m n P=(sum_t m f P )"
definition matUtrans::"Mat\<Rightarrow>nat\<Rightarrow>Mat\<Rightarrow>Mat"where
"matUtrans U n P =(mat_mult (mat_mult (dag U) P) U)"

function wlp::"Mat\<Rightarrow>com\<Rightarrow>Mat" where
"wlp P (SKIP) =P"|
"wlp P (Init m n) =matsum m n P"|
"wlp P (Utrans U n) =matUtrans U n P"|
"wlp P ( Seq c1 c2) =wlp (wlp P c2) c1"|
"wlp P (Cond mcl ) = (case mcl of [] \<Rightarrow> zero
  | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp P (fst (snd mc))))  (wlp P (Cond mcr)) ) "   |
"wlp P (While_n m0 m1 s Q n) = (case n of 0\<Rightarrow>I
                               | Suc m\<Rightarrow>
mat_add (uu m0 P)  (uu m1  (wlp (wlp P (While_n m0 m1 s Q m))  s) )     )"|
"wlp P (While m0 m1 s  Q ) = fixpoint_wlp m0 m1 s Q P"
by  pat_completeness auto
termination
 apply (relation "measure (\<lambda>(c,m).rank m)", auto )
by (metis rank_pos)

lemma while_n_aux:" Tr (mat_mult (uu Matb  (wlp (case num of 0 \<Rightarrow> I | Suc m \<Rightarrow>
    mat_add (uu Mata Q) (uu Matb (wlp (wlp Q (While_n Mata Matb com Matc m)) com))) com)   ) \<rho>) =
Tr (mat_mult (wlp (case num of 0 \<Rightarrow> I | Suc m \<Rightarrow>
    mat_add (uu Mata Q) (uu Matb (wlp (wlp Q (While_n Mata Matb com Matc m)) com))) com) (u Matb \<rho>))  "
by (metis b3 u_def uu_def)
lemma while_n_aux2:"Tr (mat_mult (uu Mata Q) \<rho>) =Tr (mat_mult Q (u Mata \<rho>))"
apply (metis b3 u_def uu_def)
done
(*fixpoint \<forall>n.  Tr ((wlp Q [while_n])+(I-Q)*[while_n]) =x \<Longrightarrow>  Tr (fixpoint1+(I-Q)fixpoint2) = x      *)
axiomatization where
 fixpoint_wlp_lemma:" \<rho>\<in>rhoMat  \<Longrightarrow>
 \<forall> n. Tr (mat_add (mat_mult (wlp Q (While_n Mata Matb com Matc n) ) \<rho>)
 (mat_mult (mat_sub I Q) (denoFun  (While_n Mata Matb com Matc n) \<rho>)) )  = x\<Longrightarrow>
      Tr (mat_add (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>) (mat_mult (mat_sub I Q) (fixpoint Mata Matb com Matc \<rho>))) =x"

lemma wlp_while_aux1:" \<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow>Tr (mat_mult (wlp Q (While_n Mata Matb com Matc num) ) \<rho>) =Tr (mat_mult Q  (denoFun  (While_n Mata Matb com Matc num) \<rho>))
+Tr \<rho>-Tr  (denoFun  (While_n Mata Matb com Matc num) \<rho>) \<Longrightarrow> \<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow>Tr (mat_mult (wlp Q (While_n Mata Matb com Matc num) ) \<rho>)+Tr (mat_mult (mat_sub I Q)
       (denoFun  (While_n Mata Matb com Matc num) \<rho>)) =Tr \<rho>"
by (smt Ident mult_sub_allo1 tr_allo1)

lemma wlp_while_aux:" wellDefined (While_n Mata Matb com Matc m) \<Longrightarrow>
 \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q com) \<rho>) = Tr (mat_mult Q (denoFun com \<rho>)) + Tr \<rho> - Tr (denoFun com \<rho>) \<Longrightarrow>
       \<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow>Tr (mat_mult (wlp Q (While_n Mata Matb com Matc num) ) \<rho>)+Tr (mat_mult (mat_sub I Q)
       (denoFun  (While_n Mata Matb com Matc num) \<rho>)) =Tr \<rho>"
apply(rule wlp_while_aux1,simp)
apply(induct num,auto)
apply (smt Ident zero_mult_r)
apply(simp add:mult_allo1)
apply(simp add:tr_allo)
apply(simp add:while_n_aux)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(subgoal_tac "(denoFun com (u Matb \<rho>))\<in>rhoMat")
prefer 2
apply (metis b rho)
apply(drule_tac x="(denoFun com (u Matb \<rho>))"in spec)
apply(drule_tac x="(case num of 0 \<Rightarrow> I | Suc m \<Rightarrow> mat_add (uu Mata Q) (uu Matb (wlp (wlp Q (While_n Mata Matb com Matc m)) com)))"in spec)
apply(subgoal_tac "(u Matb \<rho>)\<in>rhoMat")
prefer 2
apply (metis rho)
apply(drule_tac x="(u Matb \<rho>)"in spec)
apply(simp add:while_n_aux2)
apply(simp add:u_def)
apply(simp add:exchange)
by (smt Ident mult_allo1 mult_exchange tr_allo)

lemma aux:"Tr (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>)+Tr (mat_mult (mat_sub I Q) (fixpoint Mata Matb com Matc \<rho>))
 =Tr \<rho>
\<Longrightarrow> Tr (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>)
         =Tr (mat_mult Q (fixpoint Mata Matb com Matc \<rho>)) + Tr \<rho> - Tr (fixpoint Mata Matb com Matc \<rho>)"
by (smt Ident mult_sub_allo1 tr_allo1)

lemma aux1:"Tr (mat_add (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>) (mat_mult (mat_sub I Q) (fixpoint Mata Matb com Matc \<rho>))) =Tr \<rho>
\<Longrightarrow>Tr (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>) + Tr (mat_mult (mat_sub I Q) (fixpoint Mata Matb com Matc \<rho>)) = Tr \<rho>"
by (metis tr_allo)

(*wlp_init*)
lemma w_init:"\<rho>\<in>rhoMat\<Longrightarrow>wellDefined (Init m n) \<Longrightarrow>
\<forall>Q. Tr (mat_mult (wlp Q (Init m n)) \<rho>) =Tr (mat_mult Q (denoFun (Init m n) \<rho>)) +Tr \<rho>-Tr (denoFun (Init m n) \<rho>)"
apply(simp add:matsum_def)
apply(simp add:m_init)
apply(simp add:Initfact)
done

(*wlp_utrans*)
lemma w_utrans:"\<rho>\<in>rhoMat\<Longrightarrow>wellDefined (Utrans U n) \<Longrightarrow>
\<forall>Q. Tr (mat_mult (wlp Q (Utrans U n)) \<rho>) =Tr (mat_mult Q (denoFun (Utrans U n) \<rho>)) +Tr \<rho>-Tr (denoFun (Utrans U n) \<rho>)"
apply(simp add:matUtrans_def)
by (metis (no_types, hide_lams) Ident U_dag add.commute b3 diff_0 diff_add_cancel diff_diff_eq2 diff_minus_eq_add exchange minus_diff_eq mult_exchange mult_sub_allo1 tr_allo1 u_def uu_def)

(* wlp_seq *)
lemma w_seq:"\<rho>\<in>rhoMat\<Longrightarrow>wellDefined (Sa;Sb) \<Longrightarrow>
      \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q Sa) \<rho>) = Tr (mat_mult Q (denoFun Sa \<rho>)) + Tr \<rho> - Tr (denoFun Sa \<rho>) \<Longrightarrow>
       \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q Sb) \<rho>) = Tr (mat_mult Q (denoFun Sb \<rho>)) + Tr \<rho> - Tr (denoFun Sb \<rho>) \<Longrightarrow>
\<forall>Q. Tr (mat_mult (wlp Q (Sa;Sb)) \<rho>) =Tr (mat_mult Q (denoFun (Sa;Sb) \<rho>)) +Tr \<rho>-Tr (denoFun (Sa;Sb) \<rho>)"
apply auto
apply(drule_tac x="Q"in spec)
apply(drule_tac x="Q"in spec)
apply(drule_tac x="\<rho>"in spec)
apply(subgoal_tac "(denoFun Sa \<rho>)\<in>rhoMat")
prefer 2
apply (metis b)
apply(drule_tac x="(denoFun Sa \<rho>)"in spec,auto)
done

lemma cond_aux:" M_sum x = I \<Longrightarrow> \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow>
          Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>) =
          Tr (mat_mult Q (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))) +
          Tr (mat_mult (M_sum x) \<rho>) -
          Tr (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))\<Longrightarrow>
    \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow>
          Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>) =
          Tr (mat_mult Q (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))) +
          Tr \<rho> -
          Tr (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))"
by (simp add: Ident)
lemma cond_aux2:"\<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow>  Tr (mat_mult (wlp Q aa) \<rho>) = Tr (mat_mult Q (denoFun aa \<rho>)) + Tr \<rho> - Tr (denoFun aa \<rho>) \<Longrightarrow>
 \<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow> Tr (mat_mult (uu a (wlp Q aa)) \<rho>) = Tr (mat_mult Q (denoFun aa (u a \<rho>))) + (Tr (mat_mult (mat_mult (dag a) a) \<rho>) - Tr (denoFun aa (u a \<rho>)))"
apply auto
apply(subgoal_tac "(u a \<rho>)\<in>rhoMat")
prefer 2
apply (simp add: rho)
apply(drule_tac x="(u a \<rho>)"in spec)
apply(simp add:u_def)
apply(simp add:uu_def)
using b3 b4 exchange by auto

lemma cond_aux_1: "\<forall>a aa b aaa ba xaaa Q \<rho>. (a, aa, b) \<in> set x \<longrightarrow>
       (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
       xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa \<longrightarrow>
       \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q xaaa) \<rho>) = Tr (mat_mult Q (denoFun xaaa \<rho>)) + Tr \<rho> - Tr (denoFun xaaa \<rho>) \<Longrightarrow>
 \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow> (\<forall>aaa ba. (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow> (\<forall>xaaa. xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa)) \<Longrightarrow>
       \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow>
          Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>) =
          Tr (mat_mult Q (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))) + Tr (mat_mult (M_sum x) \<rho>) -
          Tr (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))"
apply auto
apply (induct x, auto)
using zero_mult_r apply auto[1]
apply(simp add:mult_allo1)
apply(simp add:tr_allo)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(cut_tac  cond_aux2,auto)
apply (drule_tac x="a" in spec)
apply (drule_tac x="aa" in spec)
apply (drule_tac x="b" in spec)
apply (drule_tac x="b" in spec)
apply (drule_tac x="aa" in spec)
apply (drule_tac x="b" in spec)
using fsts.intros snds.intros apply fastforce+
done

(*cond_wlp*)
lemma w_cond:"\<forall>a aa b aaa ba xaaa Q \<rho>. (a, aa, b) \<in> set x \<longrightarrow> (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
              xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa \<longrightarrow> \<rho> \<in> rhoMat \<longrightarrow>
     Tr (mat_mult (wlp Q xaaa) \<rho>) = Tr (mat_mult Q (denoFun xaaa \<rho>)) + Tr \<rho> - Tr (denoFun xaaa \<rho>) \<Longrightarrow>
     M_sum x = I \<Longrightarrow> \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow> (\<forall>aaa ba. (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
   (\<forall>xaaa. xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa)) \<Longrightarrow> \<forall>Q \<rho>.  \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (case x of [] \<Rightarrow> zero
      | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr)))  \<rho>) =
      Tr (mat_mult Q (case x of [] \<Rightarrow> zero  | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))) +
     Tr \<rho> - Tr (case x of [] \<Rightarrow> zero
        | mc # mcr \<Rightarrow> mat_add (denoFun (fst (snd mc)) (u (fst mc) \<rho>)) (denoFun (Cond mcr) \<rho>))"
apply(rule cond_aux)
apply simp
apply(cut_tac x=x in cond_aux_1,auto)
done

(*while_wlp *)
lemma w_while_n:" wellDefined (While_n Mata Matb com Matc m) \<Longrightarrow>
 \<forall>Q.\<forall> \<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q com) \<rho>) = Tr (mat_mult Q (denoFun com \<rho>)) + Tr \<rho> - Tr (denoFun com \<rho>)  \<Longrightarrow>
 \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow>
       Tr (mat_mult (case num of 0 \<Rightarrow> I | Suc m \<Rightarrow> mat_add (uu Mata Q) (uu Matb (wlp (wlp Q (While_n Mata Matb com Matc m)) com))) \<rho>) =
       Tr (mat_mult Q
            (case num of 0 \<Rightarrow> zero | Suc m \<Rightarrow> mat_add (u Mata \<rho>) (denoFun (While_n Mata Matb com Matc m) (denoFun com (u Matb \<rho>))))) +
       Tr \<rho> -
       Tr (case num of 0 \<Rightarrow> zero | Suc m \<Rightarrow> mat_add (u Mata \<rho>) (denoFun (While_n Mata Matb com Matc m) (denoFun com (u Matb \<rho>))))"
apply(induct num,auto)
apply (smt Ident zero_mult_r)
apply(simp add:mult_allo1)
apply(simp add:tr_allo)
apply(simp add:while_n_aux)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(subgoal_tac "(denoFun com (u Matb \<rho>))\<in>rhoMat")
prefer 2
apply (metis b rho)
apply(drule_tac x="(denoFun com (u Matb \<rho>))"in spec)
apply(drule_tac x="(case num of 0 \<Rightarrow> I | Suc m \<Rightarrow> mat_add (uu Mata Q) (uu Matb (wlp (wlp Q (While_n Mata Matb com Matc m)) com)))"in spec)
apply(subgoal_tac "(u Matb \<rho>)\<in>rhoMat")
prefer 2
apply (metis rho)
apply(drule_tac x="(u Matb \<rho>)"in spec)
apply(simp add:while_n_aux2)
apply(simp add:u_def)
apply(simp add:exchange)
by (smt Ident mult_allo1 mult_exchange tr_allo)

(*  while_wlp   *)
lemma w_while:" wellDefined (While Mata Matb com Matc ) \<Longrightarrow>
 \<forall>Q \<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (wlp Q com) \<rho>) = Tr (mat_mult Q (denoFun com \<rho>)) + Tr \<rho> - Tr (denoFun com \<rho>) \<Longrightarrow>
    \<forall>\<rho>. \<rho> \<in> rhoMat \<longrightarrow> Tr (mat_mult (fixpoint_wlp Mata Matb com Matc Q) \<rho>)
      = Tr (mat_mult Q (fixpoint Mata Matb com Matc \<rho>)) + Tr \<rho> - Tr (fixpoint Mata Matb com Matc \<rho>)"
apply auto
apply(rule aux)
apply(rule aux1)
apply(rule fixpoint_wlp_lemma,auto)
apply(simp add:tr_allo)
apply(cut_tac wlp_while_aux,auto)
done

(*\<forall> \<rho>,Q\<longrightarrow>Tr (wlp Q S)*\<rho>=Tr Q*[S](\<rho>)+ Tr \<rho>-Tr [S](\<rho>)          *)
lemma eq:"wellDefined S\<Longrightarrow>\<forall>Q. \<forall>\<rho>. \<rho>\<in>rhoMat\<longrightarrow> Tr (mat_mult (wlp Q S) \<rho>) =Tr (mat_mult Q (denoFun S \<rho>)) +Tr \<rho>-Tr (denoFun S \<rho>)"
apply(induct S,auto)
apply(cut_tac w_init,auto)
apply(cut_tac w_utrans,auto)
apply(cut_tac Sa="S1"and Sb="S2" in w_seq,auto)
prefer 3
apply(cut_tac Mata="x1" and Matb="x2" and Matc="x4" and com="S" and Q="Q" in w_while_n,auto)
defer
apply(cut_tac w_while,auto)
apply(cut_tac w_cond,auto)
done

lemma soundwp1: "wellDefined S \<Longrightarrow>\<forall> Q. valid (wlp Q S) S  Q"
apply(simp add:valid_def)
apply(simp add:eq)
done

lemma WLPsound:"Q\<in>predMat\<Longrightarrow>wellDefined S\<Longrightarrow>valid (wlp Q S) S Q"
apply(simp add: soundwp1)
done

lemma ord_wlp:"Q\<in>predMat\<Longrightarrow>P\<in>predMat\<Longrightarrow>wellDefined S\<Longrightarrow>less P (wlp Q S)\<Longrightarrow>valid P S Q"
apply(rule_tac Pa="wlp Q S" in order,auto)
apply(rule WLPsound)
apply auto
done

declare uu_def[simp]
ML_file "Quantum_Hoare_tac.ML"
method_setup vcg = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (quantum_hoare_tac ctxt (K all_tac))) *}
method_setup vcg_simp = {*
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (quantum_hoare_tac ctxt (asm_full_simp_tac ctxt))) *}
end


(*  Title:      Sequents/T.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory T
imports Modal0
begin

axiomatization where
(* Definition of the star operation using a set of Horn clauses *)
(* For system T:  gamma * == {P | []P : gamma}                  *)
(*                delta * == {P | <>P : delta}                  *)

  lstar0:         "|L>" and
  lstar1:         "$G |L> $H \<Longrightarrow> []P, $G |L> P, $H" and
  lstar2:         "$G |L> $H \<Longrightarrow>   P, $G |L>    $H" and
  rstar0:         "|R>" and
  rstar1:         "$G |R> $H \<Longrightarrow> <>P, $G |R> P, $H" and
  rstar2:         "$G |R> $H \<Longrightarrow>   P, $G |R>    $H" and

(* Rules for [] and <> *)

  boxR:
   "\<lbrakk>$E |L> $E';  $F |R> $F';  $G |R> $G';
               $E'        \<turnstile> $F', P, $G'\<rbrakk> \<Longrightarrow> $E          \<turnstile> $F, []P, $G" and
  boxL:     "$E, P, $F  \<turnstile>         $G    \<Longrightarrow> $E, []P, $F \<turnstile>          $G" and
  diaR:     "$E         \<turnstile> $F, P,  $G    \<Longrightarrow> $E          \<turnstile> $F, <>P, $G" and
  diaL:
   "\<lbrakk>$E |L> $E';  $F |L> $F';  $G |R> $G';
               $E', P, $F'\<turnstile>         $G'\<rbrakk> \<Longrightarrow> $E, <>P, $F \<turnstile>          $G"

ML \<open>
structure T_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm boxR}, @{thm diaL}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}]
)
\<close>

method_setup T_solve = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD (T_Prover.solve_tac ctxt 2))\<close>

(* Theorems of system T from Hughes and Cresswell and Hailpern, LNCS 129 *)

lemma "\<turnstile> []P \<longrightarrow> P" by T_solve
lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> ([]P \<longrightarrow> []Q)" by T_solve   (* normality*)
lemma "\<turnstile> (P --< Q) \<longrightarrow> []P \<longrightarrow> []Q" by T_solve
lemma "\<turnstile> P \<longrightarrow> <>P" by T_solve

lemma "\<turnstile>  [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by T_solve
lemma "\<turnstile>  <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by T_solve
lemma "\<turnstile>  [](P \<longleftrightarrow> Q) \<longleftrightarrow> (P >-< Q)" by T_solve
lemma "\<turnstile>  <>(P \<longrightarrow> Q) \<longleftrightarrow> ([]P \<longrightarrow> <>Q)" by T_solve
lemma "\<turnstile>        []P \<longleftrightarrow> \<not> <>(\<not> P)" by T_solve
lemma "\<turnstile>     [](\<not> P) \<longleftrightarrow> \<not> <>P" by T_solve
lemma "\<turnstile>       \<not> []P \<longleftrightarrow> <>(\<not> P)" by T_solve
lemma "\<turnstile>      [][]P \<longleftrightarrow> \<not> <><>(\<not> P)" by T_solve
lemma "\<turnstile> \<not> <>(P \<or> Q) \<longleftrightarrow> \<not> <>P \<and> \<not> <>Q" by T_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by T_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by T_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by T_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by T_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by T_solve
lemma "\<turnstile> <>(P \<longrightarrow> (Q \<and> R)) \<longrightarrow> ([]P \<longrightarrow> <>Q) \<and> ([]P \<longrightarrow> <>R)" by T_solve
lemma "\<turnstile> (P --< Q) \<and> (Q --< R ) \<longrightarrow> (P --< R)" by T_solve
lemma "\<turnstile> []P \<longrightarrow> <>Q \<longrightarrow> <>(P \<and> Q)" by T_solve

end


theory Geometric_Random_Walk imports Infinite_Coin_Toss_Space

begin

section \<open>Geometric random walk\<close>
text \<open>A geometric random walk is a stochastic process that can, at each time, move upwards or downwards,
depending on the outcome of a coin toss.\<close>

fun (in infinite_coin_toss_space) geom_rand_walk:: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (nat \<Rightarrow> bool stream \<Rightarrow> real)" where
  base: "(geom_rand_walk u d v) 0 = (\<lambda>w. v)"|
  step: "(geom_rand_walk u d v) (Suc n)  = (\<lambda>w. ((\<lambda>True \<Rightarrow> u | False \<Rightarrow> d) (snth w n)) * (geom_rand_walk u d v) n w)"

locale prob_grw = infinite_coin_toss_space +
  fixes geom_proc::"nat \<Rightarrow> bool stream \<Rightarrow> real" and u::real and d::real and init::real
  assumes geometric_process:"geom_proc = geom_rand_walk u d init"

lemma (in prob_grw) geom_rand_walk_borel_measurable:
shows "(geom_proc n) \<in> borel_measurable M"
proof (induct n)
case (Suc n)
  thus "geom_proc (Suc n) \<in> borel_measurable M"
  proof -
    have "geom_rand_walk u d init n \<in> borel_measurable M" using Suc geometric_process by simp
    moreover have "(\<lambda>w. ((\<lambda>True \<Rightarrow> u | False \<Rightarrow> d) (snth w n))) \<in> borel_measurable M"
    proof -
      have "(\<lambda>w. snth w n) \<in> measurable M (measure_pmf (bernoulli_pmf p))" by (simp add: bernoulli measurable_snth_count_space)
      moreover have "(\<lambda>True \<Rightarrow> u | False \<Rightarrow> d) \<in> borel_measurable (measure_pmf (bernoulli_pmf p))" by simp
      ultimately show ?thesis by (simp add: measurable_comp)
    qed
    ultimately show ?thesis by (simp add:borel_measurable_times geometric_process)
  qed
  next
  show "random_variable borel (geom_proc 0)" using geometric_process by simp
qed

lemma (in prob_grw) geom_rand_walk_pseudo_proj_True:
shows "geom_proc n = geom_proc n \<circ> pseudo_proj_True n"
proof (induct n)
case (Suc n)
  let ?tf = "(\<lambda>True \<Rightarrow> u | False \<Rightarrow> d)"
  {
    fix w
    have "geom_proc (Suc n) w  =  ?tf  (snth w n) * geom_proc n w"
      using geom_rand_walk.simps(2) geometric_process by simp
    also have "... = ?tf (snth (pseudo_proj_True (Suc n) w) n) * geom_proc n w"
      by (metis  lessI pseudo_proj_True_stake stake_nth)
    also have "... = ?tf (snth (pseudo_proj_True (Suc n) w) n) * geom_proc n (pseudo_proj_True n w)"
      using Suc geometric_process by (metis comp_apply)
    also have "... = ?tf (snth (pseudo_proj_True (Suc n) w) n) * geom_proc n (pseudo_proj_True (Suc n) w)"
      using geometric_process by (metis Suc.hyps comp_apply pseudo_proj_True_proj_Suc)
    also have "... = geom_proc (Suc n) (pseudo_proj_True (Suc n) w)" using geometric_process by simp
    finally have "geom_proc (Suc n) w  = geom_proc (Suc n) (pseudo_proj_True (Suc n) w)" .
  }
  thus "geom_proc (Suc n) = geom_proc (Suc n) \<circ> (pseudo_proj_True  (Suc n))" using geometric_process by auto
next
  show "geom_proc 0 = geom_proc 0 \<circ> pseudo_proj_True 0" using geometric_process by auto
qed

lemma (in prob_grw) geom_rand_walk_pseudo_proj_False:
shows "geom_proc n = geom_proc n \<circ> pseudo_proj_False n"
proof (induct n)
case (Suc n)
  let ?tf = "(\<lambda>True \<Rightarrow> u | False \<Rightarrow> d)"
  {
    fix w
    have "geom_proc (Suc n) w  =  ?tf  (snth w n) * geom_proc n w"
      using geom_rand_walk.simps(2) geometric_process by simp
    also have "... = ?tf (snth (pseudo_proj_False (Suc n) w) n) * geom_proc n w"
      by (metis  lessI pseudo_proj_False_stake stake_nth)
    also have "... = ?tf (snth (pseudo_proj_False (Suc n) w) n) * geom_proc n (pseudo_proj_False n w)"
      using Suc geometric_process by (metis comp_apply)
    also have "... = ?tf (snth (pseudo_proj_False (Suc n) w) n) * geom_proc n (pseudo_proj_True n (pseudo_proj_False n w))"
      using  geometric_process by (metis geom_rand_walk_pseudo_proj_True o_apply)
    also have "... = ?tf (snth (pseudo_proj_False (Suc n) w) n) * geom_proc n (pseudo_proj_True n (pseudo_proj_False (Suc n) w))"
      unfolding pseudo_proj_True_def pseudo_proj_False_def
      by (metis pseudo_proj_False_def pseudo_proj_False_stake pseudo_proj_True_def pseudo_proj_True_proj_Suc)
    also have "... = ?tf (snth (pseudo_proj_False (Suc n) w) n) * geom_proc n (pseudo_proj_False (Suc n) w)"
      using geometric_process by (metis geom_rand_walk_pseudo_proj_True o_apply)
    also have "... = geom_proc (Suc n) (pseudo_proj_False (Suc n) w)" using geometric_process by simp
    finally have "geom_proc (Suc n) w  = geom_proc (Suc n) (pseudo_proj_False (Suc n) w)" .
  }
  thus "geom_proc (Suc n) = geom_proc (Suc n) \<circ> (pseudo_proj_False  (Suc n))" using geometric_process by auto
next
  show "geom_proc 0 = geom_proc 0 \<circ> pseudo_proj_False 0" using geometric_process by auto
qed

lemma (in prob_grw) geom_rand_walk_borel_adapted:
  shows "borel_adapt_stoch_proc nat_filtration geom_proc"
unfolding adapt_stoch_proc_def
proof (auto simp add:nat_discrete_filtration)
  fix n
  show "geom_proc n \<in> borel_measurable (nat_filtration n)"
  proof -
    have "geom_proc n \<in> borel_measurable (nat_filtration n)"
    proof (rule nat_filtration_comp_measurable)
      show "geom_proc n \<in> borel_measurable M"
        by (simp add: geom_rand_walk_borel_measurable)
      show "geom_proc n \<circ> pseudo_proj_True n = geom_proc n"
        using geom_rand_walk_pseudo_proj_True  by simp
    qed
    then show ?thesis by simp
  qed
qed

lemma (in prob_grw) grw_succ_img:
  assumes "(geom_proc n) -` {x} \<noteq> {}"
  shows "(geom_proc (Suc n)) ` ((geom_proc n) -` {x}) = {u*x, d*x}"
proof
  have "\<exists> w. geom_proc n w = x" using assms by auto
  from this obtain w where "geom_proc n w = x" by auto
  let ?wT = "spick w n True"
  let ?wF = "spick w n False"
  have bel: "(?wT \<in> (geom_proc n) -` {x}) \<and> (?wF \<in> (geom_proc n) -` {x})"
    by (metis \<open>geom_proc n w = x\<close> geom_rand_walk_pseudo_proj_True o_def
        pseudo_proj_True_stake_image spickI vimage_singleton_eq)
  have "geom_proc (Suc n) ?wT = u*x"
  proof -
    have "x = geom_rand_walk u d init n (spick w n True)"
      by (metis \<open>geom_proc n w = x\<close> comp_apply geom_rand_walk_pseudo_proj_True geometric_process pseudo_proj_True_stake_image spickI)
    then show ?thesis
      by (simp add: geometric_process spickI)
  qed
  moreover have "geom_proc (Suc n) ?wF = d*x"
  proof -
    have "x = geom_rand_walk u d init n (spick w n False)"
      by (metis \<open>geom_proc n w = x\<close> comp_apply geom_rand_walk_pseudo_proj_True geometric_process pseudo_proj_True_stake_image spickI)
    then show ?thesis
      by (simp add: geometric_process spickI)
  qed
  ultimately show "{u*x, d*x} \<subseteq> (geom_proc (Suc n)) ` ((geom_proc n) -` {x})" using bel
    by (metis empty_subsetI insert_subset rev_image_eqI)
  have "\<forall>w \<in> (geom_proc n) -` {x}. geom_proc (Suc n) w \<in> {u*x, d*x}"
  proof
    fix w
    assume "w \<in> (geom_proc n) -` {x}"
    have dis: "((snth w (Suc n)) = True) \<or> (snth w (Suc n) = False)" by simp
    show "geom_proc (Suc n) w \<in> {u*x, d*x}"
    proof -
      have "geom_proc n w = x"
        by (metis \<open>w \<in> geom_proc n -` {x}\<close> vimage_singleton_eq)
      then have "geom_rand_walk u d init n w = x"
        using geometric_process by blast
      then show ?thesis
        by (simp add: case_bool_if geometric_process)
    qed
  qed
  thus "(geom_proc (Suc n)) ` ((geom_proc n) -` {x}) \<subseteq> {u*x, d*x}" by auto
qed

lemma (in prob_grw) geom_rand_walk_strictly_positive:
  assumes "0 < init"
  and "0 < d"
  and "d < u"
  shows "\<forall> n w. 0 < geom_proc n w"
proof (intro allI)
  fix n
  fix w
  show "0 < geom_proc n w"
  proof (induct n)
  case 0 thus ?case using assms geometric_process by simp
  next
  case (Suc n)
    thus ?case
    proof (cases "snth w n")
    case True
      hence "geom_proc (Suc n) w = u * geom_proc n w" using geom_rand_walk.simps geometric_process by simp
      also have "... > 0" using Suc assms  by simp
      finally show ?thesis .
    next
    case False
      hence "geom_proc (Suc n) w = d * geom_proc n w" using geom_rand_walk.simps geometric_process by simp
      also have "... > 0" using Suc assms by simp
      finally show ?thesis .
    qed
  qed
qed

lemma (in prob_grw) geom_rand_walk_diff_induct:
  shows "\<And>w. (geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) = (geom_proc n w * (u - d))"
proof -
  fix w
  have "geom_proc (Suc n) (spick w n True) = u * geom_proc n w"
  proof -
    have "snth (spick w n True) n = True" by (simp add: spickI)
    hence "(\<lambda>w. (case w !! n of True \<Rightarrow> u | False \<Rightarrow> d)) (spick w n True) = u" by simp
    thus ?thesis using geometric_process geom_rand_walk.simps(2)[of u d init n]
      by (metis comp_apply geom_rand_walk_pseudo_proj_True pseudo_proj_True_def spickI)
  qed
  moreover have "geom_proc (Suc n) (spick w n False) = d * geom_proc n w"
  proof -
    have "snth (spick w n False) n = False" by (simp add: spickI)
    hence "(\<lambda>w. (case w !! n of True \<Rightarrow> u | False \<Rightarrow> d)) (spick w n False) = d" by simp
    thus ?thesis using geometric_process geom_rand_walk.simps(2)[of u d init n]
      by (metis comp_apply geom_rand_walk_pseudo_proj_True pseudo_proj_True_def spickI)
  qed
  ultimately show "(geom_proc (Suc n) (spick w n True) - geom_proc (Suc n) (spick w n False)) = (geom_proc n w * (u - d))"
    by (simp add:field_simps)
qed

end