\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
chapter "PGCL with explicit state"
theory PGCL_With_State
imports PGCL_Misc
begin

paragraph \<open>Summary\<close>

text \<open>This theory formalizes the basics needed to formalize the new proof rule for expected
    running time transformer ERT for f-iid loops. We follow the exposition of @{cite batzESOP18}.

    We build upon the definitions of @{term ert} and @{term wp} for the general pGCL.\<close>

paragraph \<open>Main definitions\<close>

text \<open>
  \<^item> we define the language spGCL that comes with a state. in contrast to pGCL it does not have
      Empty and Halt.
  \<^item> compile: compiles a spGCL into a general pGCL program\<close>

section \<open>The type spGCL\<close>

type_synonym vname = string
type_synonym val = nat
type_synonym state = "vname \<Rightarrow> val"

datatype spgcl = (* Empty *)
                  Skip
                (* | Halt *)
                 | Assign vname "state \<Rightarrow> val pmf"
                 | Seq (left: "spgcl") (right: "spgcl") ("_;;/ _"  [60, 61] 60)
                 | Par (left: "spgcl") (right: "spgcl")
                 | If "state \<Rightarrow> bool" (left: "spgcl") (right: "spgcl")
                 | While "state \<Rightarrow> bool" "spgcl" ("(WHILE _/ DO _)"  [0, 61] 61)

fun compile :: "spgcl \<Rightarrow> state pgcl" where
 "compile Skip = PGCL.Skip"
(* |  "compile Empty = PGCL.Empty"
| "compile Halt = PGCL.Halt" *)
| "compile (Assign v f) = PGCL.Assign (\<lambda>s. map_pmf (\<lambda>r. s(v:=r)) (f s))"
| "compile (Seq c1 c2) = PGCL.Seq (compile c1) (compile c2)"
| "compile (Par c1 c2) = PGCL.Par (compile c1) (compile c2)"
| "compile (If b c1 c2) = PGCL.If b (compile c1) (compile c2)"
| "compile (While b c) = PGCL.While b (compile c)"

text  \<open>The name might be confusing. It signifies, that no non-deterministic choice is involved,
    only deterministic programs, with probabilistic choice.\<close>

fun deter :: "spgcl \<Rightarrow> bool" where
 "deter Skip = True"
(* |  "compile Empty = PGCL.Empty"
| "compile Halt = PGCL.Halt" *)
| "deter (Assign v f) = True"
| "deter (Seq c1 c2) = (deter c1 \<and> deter c2)"
| "deter (Par c1 c2) = False"
| "deter (If b c1 c2) = (deter c1 \<and> deter c2)"
| "deter (While b c) = deter c"

lemma awp_is_wp_if_deter: "deter C \<Longrightarrow> awp (compile C) f = wp (compile C) f"
  apply(induct C arbitrary: f) apply auto by presburger

(* conjecture *)
lemma "fully_probabilistic (compile p) \<longleftrightarrow> deter p"
  oops

type_synonym exp = "(state \<Rightarrow> ennreal)"

lemma bot0: "(\<bottom>::exp) = 0"
  by (metis bot.not_eq_extremum gr_implies_not_zero)

subsection "syntax"

definition lift2 :: "(state \<Rightarrow> bool) \<Rightarrow> state \<Rightarrow> ennreal" ("\<lbrakk>_\<rbrakk>") where
  "lift2 b = (\<lambda>s. if b s then 1 else 0)"

lemma lift2_fold: "(\<lambda>s. if b s then f s else 0) = lift2 b * f"
        unfolding lift2_def by auto

abbreviation NOT :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" ("\<^bold>\<not>") where
  "NOT b \<equiv> (\<lambda>a. \<not> b a)"

subsection "wp and ert Orbits"

definition chara where
  "chara b C f W  = (\<lambda>s::state. if b s then wp (compile C) W s else f s)"

lemma fixes i j
  shows chara_mono: "i\<le>j \<Longrightarrow> (chara b C f ^^ i) \<bottom> s \<le> (chara b C f ^^ j) \<bottom> s"
proof(induct arbitrary: s rule: diff_induct)
  case (1 x)
  then show ?case by auto
next
  case (2 y)
  show ?case
    apply(induct y) by auto
next
  case (3 x y)
  have *: "\<And>f g s. f \<le> g \<Longrightarrow>  wp (compile C) f s \<le> wp (compile C) g s"
    by (simp add: mono_wp[unfolded mono_def] le_funD)

  from 3 show ?case apply auto unfolding chara_def apply auto
    apply(subst *) apply auto
    using le_funI by blast
qed

lemma chara_alt: "chara b C f W = (lift2 b) * wp (compile C) W + (lift2 (\<lambda>s. ~ b s)) * f"
  unfolding chara_def lift2_def by auto

definition charaErt where
  "charaErt b C f W  = (\<lambda>s::state. 1 + (if b s then ert (compile C) W s else f s) )"

lemma fixes i j
  shows charaErt_mono: "i\<le>j \<Longrightarrow> (charaErt b C f ^^ i) \<bottom> s \<le> (charaErt b C f ^^ j) \<bottom> s"
proof(induct arbitrary: s rule: diff_induct)
  case (1 x)
  then show ?case by auto
next
  case (2 y)
  show ?case
    apply(induct y) by auto
next
  case (3 x y)
  have *: "\<And>f g s. f \<le> g \<Longrightarrow>  ert (compile C) f s \<le> ert (compile C) g s"
    by (simp add: mono_ert[unfolded mono_def] le_funD)

  from 3 show ?case apply auto unfolding charaErt_def apply auto
    apply(subst *) apply auto
    using le_funI by blast
qed

lemma charaErt_alt: "charaErt b C f W = 1 + (lift2 b) * ert (compile C) W + (lift2 (\<lambda>s. ~ b s)) * f"
  unfolding charaErt_def lift2_def by auto

lemma wp_sup: "wp (compile (While b C)) f  = (\<Squnion>i. ((chara b C f) ^^ i) \<bottom>)"
  unfolding chara_def apply simp
  apply(rule sup_continuous_lfp)
  by (auto intro!: order_continuous_intros simp add:   sup_continuous_wp sup_continuous_applyD)

lemma ert_sup: "ert (compile (While b C)) f = (\<Squnion>i. ((charaErt b C f) ^^ i) \<bottom>)"
  unfolding charaErt_def apply simp
  apply(rule sup_continuous_lfp)
  by (auto intro!: order_continuous_intros simp add:   sup_continuous_ert sup_continuous_applyD)

subsection "Decompose ert into wp and ert"

text \<open>The following lemma only works for deterministic spgcl programs.
        It is lemma A.15 from @{cite olmedo2016}. \<close>

lemma
  decompose_wpert:
  "deter C \<Longrightarrow> ert (compile C) (f+g) =  ert (compile C) f + wp (compile C) g"
proof (induct C arbitrary: f g)
  case (Seq C1 C2)
  then have "deter C1" "deter C2" by auto
  have "ert (compile (C1;; C2)) (f+g) = ert (compile C1) (ert (compile C2) (f+g))" by auto
  also have "\<dots> = ert (compile C1) (ert (compile C2) f + wp (compile C2) g)" apply(subst Seq(2)) apply fact by simp
  also have "\<dots> = ert (compile C1) (ert (compile C2) f) + wp (compile C1) (wp (compile C2) g)"
    apply (subst Seq(1)) apply fact by simp
  also have "\<dots> = ert (compile (C1;; C2)) f + wp (compile (C1;; C2)) g" by auto
  finally show ?case .
next
  case (If x1 C1 C2)
  then have If': "\<And>f g. ert (compile C1) (f + g) = ert (compile C1) f + wp (compile C1) g"
        "\<And>f g. ert (compile C2) (f + g) = ert (compile C2) f + wp (compile C2) g"
    by fastforce+
  have t: "(\<lambda>a. f a + g a) = f+g" by auto
  show ?case by (auto simp: If' t )
next
  case (While b C)
  then have While': "\<And>f g. ert (compile C) (f + g) = ert (compile C) f + wp (compile C) g"
    by fastforce
  let ?C ="charaErt b C"
  let ?W ="chara b C"

  { fix i
    have i: "(?C (f+g) ^^ i) \<bottom> = (?C f ^^ i) \<bottom> + (?W g ^^ i) \<bottom>"
    proof(induct i)
      case (Suc i)
      have "(?C (f+g) ^^ Suc i) \<bottom> = ?C (f+g) ((?C (f+g) ^^ i) \<bottom>)" by auto
      also have "\<dots> = ?C f ((?C f ^^ i) \<bottom>) + ?W g ((?W g ^^ i) \<bottom>)"
        apply(subst charaErt_def)
        apply(subst charaErt_def)
        apply(subst chara_def) apply(rule) apply auto
        apply(subst Suc) by(auto simp: While')
      also have "\<dots> = (?C f ^^ Suc i) \<bottom> + (?W g ^^ Suc i) \<bottom>" by auto
      finally show ?case .
    qed auto
  } note 1=this

  have "ert (compile (WHILE b DO C)) (f+g) = (\<Squnion>i. (?C (f+g) ^^ i) \<bottom>)" by(rule ert_sup)
  also have "\<dots> = (\<Squnion>i. (?C f ^^ i) \<bottom> + (?W g ^^ i) \<bottom>)" by(simp only: 1)
  also have "\<dots> = (\<Squnion>i. (?C f ^^ i) \<bottom>) + (\<Squnion>i. (?W g ^^ i) \<bottom>)"
    apply(auto simp: SUP_image intro!: ext SUP_add_directed_ennreal)
    subgoal for s i j apply (rule exI[where x="max i j"])  by(auto simp add: chara_mono charaErt_mono add_mono)
    done
  also have "\<dots> = ert (compile (WHILE b DO C)) f + wp (compile (WHILE b DO C)) g"
    by(simp only: ert_sup wp_sup)

  finally show ?case .
qed (auto simp: nn_integral_add)

corollary decompose_ert: "deter C \<Longrightarrow> ert (compile C) f =  ert (compile C) 0 + wp (compile C) f"
  using decompose_wpert[where f=0 and g=f] by auto

corollary decompose_ert': "deter C \<Longrightarrow> ert (compile C) (f+g) s =  ert (compile C) f s + wp (compile C) g s"
  using decompose_wpert[where f=f and g=g] by auto

subsection "Linearity of wp"

lemma wp_linear:
  assumes "deter C" "a < \<infinity>"
  shows "wp (compile C) ((\<lambda>s. a * f1 s) + f2)
           = (\<lambda>s. (a::ennreal) * wp (compile C) f1 s) + wp (compile C) f2"
  (is "?P C f1 f2 a")
  using assms
proof (induct C arbitrary: f1 f2 a)
  case (Assign x1 x2)
  then show ?case   by (auto simp add: nn_integral_add  nn_integral_cmult)
next
  case (Seq C1 C2)
  then have Seq': "\<And>f1 f2. wp (compile C1) ((\<lambda>s. a * f1 s) + f2)
                = (\<lambda>s. a * wp (compile C1) f1 s) + wp (compile C1) f2"
 "\<And>f1 f2. wp (compile C2) ((\<lambda>s. a * f1 s) + f2)
                = (\<lambda>s. a * wp (compile C2) f1 s) + wp (compile C2) f2"
    by fastforce+

  show ?case by (simp only: compile.simps wp.simps Seq')
next
  case (While b C)
  then have While': "\<And>f1 f2. ?P C f1 f2 a" by force
  {
    fix i
    let ?C ="chara b C"
    have "(?C ((\<lambda>s. a * f1 s) + f2) ^^ i) \<bottom> = (%s. a * ((?C f1 ^^ i) \<bottom> s))  + (?C f2 ^^ i) \<bottom>"
    proof (induct i)
      case 0
      then show ?case by (auto simp: bot0)
    next
      case (Suc i)
      have "(?C ((\<lambda>s. a * f1 s) + f2) ^^ Suc i) \<bottom> = ?C ((\<lambda>s. a * f1 s) + f2) ((?C ((\<lambda>s. a * f1 s) + f2) ^^ i) \<bottom>)" by auto
      also have "\<dots> = (\<lambda>s. a * ?C f1 ((?C f1 ^^ i) \<bottom>) s) + ?C f2 ((?C f2 ^^ i) \<bottom>)"
        apply(subst Suc)
        apply(subst chara_def) apply(subst chara_def) apply(subst chara_def) apply(rule)
        apply(subst While')
        using While(2) by auto
      also have "\<dots> = (\<lambda>s. a * (chara b C f1 ^^ Suc i) \<bottom> s) + (?C f2 ^^ Suc i) \<bottom>" by auto
      finally show ?case .
    qed
  } note 1=this

  have *: "(\<lambda>s. a * (\<Squnion>i. (chara b C f1 ^^ i) \<bottom>) s) = (\<Squnion>i. (\<lambda>s. a * ((chara b C f1 ^^ i) \<bottom> s)) )"
    by (auto simp: SUP_image SUP_mult_left_ennreal)
  have "wp (compile (WHILE b DO C)) ((\<lambda>s. a * f1 s) + f2)
      = (\<Squnion>i. (chara b C ((\<lambda>s. a * f1 s) + f2) ^^ i) \<bottom>)" by(rule wp_sup)
  also have "\<dots> = (\<Squnion>i. (\<lambda>s. a * ((chara b C f1 ^^ i) \<bottom> s))  + (chara b C f2 ^^ i) \<bottom>)"
    by(simp only: 1)
  also have "\<dots> = (\<Squnion>i. (\<lambda>s. a * ((chara b C f1 ^^ i) \<bottom> s)) ) + (\<Squnion>i. (chara b C f2 ^^ i) \<bottom>)"
    proof -
    show ?thesis apply (auto simp: SUP_image intro!: ext SUP_add_directed_ennreal)
      subgoal for s i j apply (rule exI[where x="max i j"])
        by (simp add: chara_mono mult_left_mono add_mono)
      done
  qed
  also have "\<dots> = (\<lambda>s. a * (\<Squnion>i. (chara b C f1 ^^ i) \<bottom>) s) + (\<Squnion>i. (chara b C f2 ^^ i) \<bottom>)"
    by(simp only: *)
  also have "\<dots> = (\<lambda>s. a * wp (compile (WHILE b DO C)) f1 s) + wp (compile (WHILE b DO C)) f2"
    by(simp only: wp_sup)
  finally show ?case .
qed auto

lemma wp_linear': "deter C \<Longrightarrow> wp (compile C) ((f1::exp) + f2) =  wp (compile C) f1 + wp (compile C) f2"
  using wp_linear[where a=1] by auto

lemma wp0: "wp (compile C) (0::exp) = (0::exp)"
proof (induct C)
  case (While b C)
  {
    fix i
    from While have "(chara b C 0 ^^ i) \<bottom> = 0"
      by (induct i) (auto simp: chara_def bot_ennreal)
  }
  then show ?case apply(subst wp_sup) by(auto simp add: wp_sup  )
qed auto

lemma wp_linearSum:
  fixes f :: "nat \<Rightarrow> state \<Rightarrow> ennreal"
  shows "deter C \<Longrightarrow> wp (compile C) (\<lambda>s. sum (\<lambda>i. f i s) {0..<n::nat}) = (\<lambda>s. sum (\<lambda>i. wp (compile C) (f i) s) {0..<n})"
proof (induct n)
  case 0
  have t: "(\<lambda>s. 0) = 0" by auto
  show ?case by (auto simp: wp0 t)
next
  case (Suc n)
  have i: "(\<lambda>s. (\<Sum>i = 0..<n. f i s) + f n s) = ((\<lambda>s. (\<Sum>i = 0..<n. f i s)) + f n)" by auto
  thus ?case by (auto simp: wp_linear' Suc)
qed

lemma wp_le1:  "(\<And>s. f s \<le> 1) \<Longrightarrow> wp (compile C) f s \<le> 1"
proof (induct C arbitrary: f s)
  case (Assign x)
  then show ?case by (auto simp add: measure_pmf.nn_integral_le_const)
next
  case (While b C)
  { fix i
    from While have "(chara b C f ^^ i) \<bottom> \<le> 1"
      by (induct i) (auto simp: chara_def le_fun_def bot_ennreal)
  } note n=this
  then show ?case by(subst wp_sup) (auto simp: le_fun_def SUP_le_iff)
qed (auto simp: le_infI2)

lemma awp_le1:  "(\<And>s. f s \<le> 1) \<Longrightarrow> awp (compile C) f s \<le> 1"
proof (induct C arbitrary: f s)
  case (Assign x)
  then show ?case by (auto simp add: measure_pmf.nn_integral_le_const)
next
  case (While b C)
  then have t: "\<And>s. awp (compile C) f s \<le> 1" by auto
  have "awp (compile (WHILE b DO C)) f \<le> 1" apply simp
  proof (induct rule: lfp_induct)
    case 1
    then show ?case using mono_awp
      by (smt eq_iff le_funD le_funI mono_def)
  next
    case 2
    then show ?case using t While(2)
      by (simp add: While.hyps le_funI)
  qed
  then show ?case by (auto dest: le_funD)
qed (auto simp: le_infI2)

end


(*  Title:      RSAPSS/Wordarith.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

header "Extensions to the Word theory required for PSS"

theory Wordarith
imports WordOperations "~~/src/HOL/Number_Theory/Primes"
begin

definition
  nat_to_bv_length :: "nat \<Rightarrow> nat \<Rightarrow>  bv" where
    (* nat_to_bv_length converts nat (if 0 \<le> nat \<and> nat < 2^nat) nato a bit string of length l *)
  nat_to_bv_length:
  "nat_to_bv_length n l = (if length(nat_to_bv n) \<le> l then bv_extend l \<zero> (nat_to_bv n) else [])"

lemma length_nat_to_bv_length:
  "nat_to_bv_length x y \<noteq> [] \<Longrightarrow> length (nat_to_bv_length x y) = y"
  unfolding nat_to_bv_length by auto

lemma bv_to_nat_nat_to_bv_length:
  "nat_to_bv_length x y \<noteq> [] \<Longrightarrow> bv_to_nat (nat_to_bv_length x y) = x"
  unfolding nat_to_bv_length by auto

definition
  roundup :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  roundup: "roundup x y = (if (x mod y = 0) then (x div y) else (x div y) + 1)"

lemma rnddvd: "b dvd a \<Longrightarrow> roundup a b * b = a"
  by (auto simp add: roundup dvd_eq_mod_eq_0)

lemma bv_to_nat_zero_prepend: "bv_to_nat a = bv_to_nat (\<zero>#a)"
  by auto

primrec remzero:: "bv \<Rightarrow> bv" where
  "remzero [] = []"
| "remzero (a#b) = (if a = \<one> then (a#b) else remzero b)"

lemma remzeroeq: "bv_to_nat a = bv_to_nat (remzero a)"
proof (induct a)
  show "bv_to_nat [] = bv_to_nat (remzero [])" by (simp add: remzero.simps)
next
  case (Cons a1 a2)
  show "bv_to_nat a2 = bv_to_nat (remzero a2) \<Longrightarrow>
       bv_to_nat (a1 # a2) = bv_to_nat (remzero (a1 # a2))"
  proof (cases a1)
    assume a: "a1=\<zero>" then have "bv_to_nat (a1#a2) = bv_to_nat a2"
      using bv_to_nat_zero_prepend by simp
    moreover have "remzero (a1 # a2) = remzero a2" using a by simp
    ultimately show ?thesis using Cons by simp
  next
    assume "a1=\<one>" then show ?thesis by simp
  qed
qed

lemma len_nat_to_bv_pos: assumes x: "1 < a" shows "0< length (nat_to_bv a)"
proof (auto)
  assume b: "nat_to_bv a = []"
  have a: "bv_to_nat [] = 0" by simp
  have c: "bv_to_nat (nat_to_bv a) = 0" using a and b by simp
  from x have d: "bv_to_nat (nat_to_bv a) = a" by simp
  from d and c have "a=0" by simp
  then show False using x by simp
qed

lemma remzero_replicate: "remzero ((replicate n \<zero>)@l) = remzero l"
by (induct n, auto)

lemma length_bvxor_bound: "a <= length l \<Longrightarrow> a <= length (bvxor l l2)"
proof (induct a)
  case 0
  then show ?case by simp
next
  case (Suc a)
  have a: "Suc a \<le> length l" by fact
  with Suc.hyps have b: "a \<le> length (bvxor l l2)" by simp
  show "Suc a \<le> length (bvxor l l2)"
  proof cases
    assume c: "a = length (bvxor l l2)"
    show "Suc a \<le> length (bvxor l l2)"
    proof (simp add: bvxor)
      have "length l <= max (length l) (length l2)" by simp
      then show "Suc a \<le> max (length l) (length l2)" using a by simp
    qed
  next
    assume "a \<noteq> length (bvxor l l2)"
    then have "a < length (bvxor l l2)" using b by simp
    then show ?thesis by simp
  qed
qed

lemma nat_to_bv_helper_legacy_induct:
  "(\<And>n. n \<noteq> (0::nat) \<longrightarrow> P (n div 2) \<Longrightarrow> P n) \<Longrightarrow> P x"
unfolding atomize_imp[symmetric]
by (induction_schema, simp, lexicographic_order)

lemma len_lower_bound:
  assumes "0 < n"
  shows "2^(length (nat_to_bv n) - Suc 0) \<le> n"
proof (cases "1<n")
  assume l1: "1<n"
  then show ?thesis
  proof (simp add: nat_to_bv_def, induct n rule: nat_to_bv_helper_legacy_induct, auto)
    fix n
    assume a: "Suc 0 < (n::nat)" and b: "~Suc 0<n div 2"
    then have "n=2 \<or> n=3"
    proof (cases "n<=3")
      assume "n<=3" and "Suc 0<n"
      then show "n=2 \<or> n=3" by auto
    next
      assume "~n<=3" then have "3<n" by simp
      then have "1 < n div 2" by arith
      then show "n=2 \<or> n=3" using b by simp
    qed
    then show "2 ^ (length (nat_to_bv_helper n []) - Suc 0) \<le> n"
    proof (cases "n=2")
      assume a: "n=2" then have "nat_to_bv_helper n [] = [\<one>, \<zero>]"
      proof -
        have "nat_to_bv_helper n [] = nat_to_bv n" using b by (simp add: nat_to_bv_def)
        then show ?thesis using a by (simp add: nat_to_bv_non0)
      qed
      then show "2 ^ (length (nat_to_bv_helper n []) - Suc 0) \<le> n" using a by simp
    next
      assume "n=2 \<or> n=3" and "n~=2"
      then have a: "n=3" by simp
      then have "nat_to_bv_helper n [] = [\<one>, \<one>]"
      proof -
        have "nat_to_bv_helper n [] = nat_to_bv n" using a by (simp add: nat_to_bv_def)
        then show ?thesis using a by (simp add: nat_to_bv_non0)
      qed
      then show "2^(length (nat_to_bv_helper n []) - Suc 0) <=n" using a by simp
    qed
  next
    fix n
    assume a: "Suc 0<n" and
      b: "2 ^ (length (nat_to_bv_helper (n div 2) []) - Suc 0) \<le> n div 2"
    have "(2::nat) ^ (length (nat_to_bv_helper n []) - Suc 0) =
      2^(length (nat_to_bv_helper (n div 2) []) + 1 - Suc 0)"
    proof -
      have "length (nat_to_bv n) = length (nat_to_bv (n div 2)) + 1"
        using a by (simp add: nat_to_bv_non0)
      then show ?thesis by (simp add: nat_to_bv_def)
    qed
    moreover have "(2::nat)^(length (nat_to_bv_helper (n div 2) []) + 1 - Suc 0) =
      2^(length (nat_to_bv_helper (n div 2) []) - Suc 0) * 2"
    proof auto
      have "(2::nat)^(length (nat_to_bv_helper (n div 2) []) -Suc 0)*2 =
        2^(length (nat_to_bv_helper (n div 2) []) - Suc 0 + 1)" by simp
      moreover have "(2::nat)^(length (nat_to_bv_helper (n div 2) []) - Suc 0 + 1) =
        2^(length (nat_to_bv_helper (n div 2) []))"
      proof -
        have "0<n div 2" using a by arith
        then have "0<length (nat_to_bv (n div 2))" by (simp add: nat_to_bv_non0)
        then have "0< length (nat_to_bv_helper (n div 2) [])" using a by (simp add: nat_to_bv_def)
        then show ?thesis by simp
      qed
      ultimately show "(2::nat) ^ length (nat_to_bv_helper (n div 2) []) =
        2 ^ (length (nat_to_bv_helper (n div 2) []) - Suc 0) * 2" by simp
    qed
    ultimately show  "2 ^ (length (nat_to_bv_helper n []) - Suc 0) <= n"
      using b by (simp add: nat_to_bv_def) arith
  qed
next
  assume c: "~1<n"
  show ?thesis
  proof (cases "n=1")
    assume a: "n=1" then have "nat_to_bv n = [\<one>]" by (simp add: nat_to_bv_non0)
    then show "2^(length (nat_to_bv n) - Suc 0) <= n" using a by simp
  next
    assume "n~=1"
    with `0 < n` show "2^(length (nat_to_bv n) - Suc 0) <= n" using c by simp
  qed
qed

lemma length_lower: assumes a: "length a < length b" and b: "(hd b) ~= \<zero>" shows "bv_to_nat a < bv_to_nat b"
proof -
  have ha: "bv_to_nat a < 2^length a" by (simp add: bv_to_nat_upper_range)
  have "b ~= []" using a by auto
  then have "b=(hd b)#(tl b)" by simp
  then have "bv_to_nat b = bitval (hd b) * 2^(length (tl b)) + bv_to_nat (tl b)" using bv_to_nat_helper[of "hd b" "tl b"] by simp
  moreover have "bitval (hd b) = 1"
  proof (cases "hd b")
    assume "hd b = \<zero> "
    then show  "bitval (hd b) = 1" using b by simp
  next
    assume "hd b = \<one>"
    then show "bitval (hd b) = 1" by simp
  qed
  ultimately have hb: "2^length (tl b) <= bv_to_nat b" by simp
  have "2^(length a) <= (2::nat)^length (tl b)" using a by auto
  then show ?thesis using hb and ha by arith
qed

lemma nat_to_bv_non_empty: assumes a: "0<n" shows "nat_to_bv n ~= []"
proof -
  from nat_to_bv_non0[of n] have "EX x. nat_to_bv n = x@[if n mod 2 = 0 then \<zero> else \<one>]" using a by simp
  then show ?thesis by auto
qed

lemma hd_append: "x ~= [] \<Longrightarrow> hd (x @ xs) = hd x"
  by (induct x) auto

lemma hd_one: "0<n \<Longrightarrow> hd (nat_to_bv_helper n []) = \<one>"
proof (induct n rule: nat_to_bv_helper_legacy_induct)
  fix n
  assume *: "n \<noteq> 0 \<longrightarrow> 0 < n div 2 \<longrightarrow> hd (nat_to_bv_helper (n div 2) []) = \<one>"
    and "0 < n"
  show "hd (nat_to_bv_helper n []) = \<one>"
  proof (cases "1<n")
    assume a: "1<n"
    with * have b: "0 < n div 2 \<longrightarrow> hd (nat_to_bv_helper (n div 2) []) = \<one>" by simp
    from a have c: "0<n div 2" by arith
    then have d: "hd (nat_to_bv_helper (n div 2) []) = \<one>" using b by simp
    also from a have "0<n" by simp
    then have "hd (nat_to_bv_helper n []) =
        hd (nat_to_bv (n div 2) @ [if n mod 2 = 0 then \<zero> else \<one>])"
      using nat_to_bv_def and nat_to_bv_non0[of n] by auto
    then have "hd (nat_to_bv_helper n []) =
        hd (nat_to_bv (n div 2))"
      using nat_to_bv_non0[of "n div 2"] and c and
        nat_to_bv_non_empty[of "n div 2"] and hd_append[of " nat_to_bv (n div 2)"] by auto
    then have "hd (nat_to_bv_helper n []) = hd (nat_to_bv_helper (n div 2) [])"
      using nat_to_bv_def by simp
    then show "hd (nat_to_bv_helper n []) = \<one>" using b and c by simp
  next
    assume "~1 < n" with `0<n` have c: "n=1" by simp
    have "nat_to_bv_helper 1 [] = [\<one>]" by (simp add: nat_to_bv_helper.simps)
    then show "hd (nat_to_bv_helper n []) = \<one>" using c by simp
  qed
qed

lemma prime_hd_non_zero:
  fixes p::nat assumes a: "prime p" and b: "prime q" shows "hd (nat_to_bv (p*q)) ~= \<zero>"
proof -
  have "0 < p*q"
    by (metis a b mult_is_0 neq0_conv zero_not_prime_nat)
  then show ?thesis using hd_one[of "p*q"] and nat_to_bv_def by auto
qed

lemma primerew: fixes p::nat shows  "\<lbrakk>m dvd p; m~=1; m~=p\<rbrakk> \<Longrightarrow> ~ prime p"
  by (auto simp add: prime_nat_def)

lemma two_dvd_exp: "0<x \<Longrightarrow> (2::nat) dvd 2^x"
  by (induct x) auto

lemma exp_prod1: "\<lbrakk>1<b;2^x=2*(b::nat)\<rbrakk> \<Longrightarrow> 2 dvd b"
proof -
  assume a: "1<b" and b: "2^x=2*(b::nat)"
  have s1: "1<x"
  proof (cases "1<x")
    assume "1<x" then show ?thesis by simp
  next
   assume x: "~1 < x" then have "2^x <= (2::nat)" using b
   proof (cases "x=0")
      assume "x=0" then show "2^x <= (2::nat)" by simp
    next
      assume "x~=0" then have "x=1" using x by simp
      then show "2^x <= (2::nat)" by simp
    qed
    then have "b<=1" using b by simp
    then show ?thesis using a by simp
  qed
  have s2: "2^(x-(1::nat)) = b"
  proof -
    from s1 b have "2^((x-Suc 0)+1) = 2*b" by simp
    then have "2*2^(x-Suc 0) = 2*b" by simp
    then show "2^(x-(1::nat)) = b" by simp
  qed
  from s1 and s2 show ?thesis using two_dvd_exp[of "x-(1::nat)"] by simp
qed

lemma exp_prod2: "\<lbrakk>1<a; 2^x=a*2\<rbrakk> \<Longrightarrow> (2::nat) dvd a"
proof -
  assume "2^x=a*2"
  then have "2^x=2*a" by simp
  moreover assume "1<a"
  ultimately show "2 dvd a" using exp_prod1 by simp
qed

lemma odd_mul_odd: "\<lbrakk>~(2::nat) dvd p; ~2 dvd q\<rbrakk> \<Longrightarrow> ~2 dvd p*q"
  apply (simp add: dvd_eq_mod_eq_0)
  apply (simp add: mod_mult_right_eq)
  done

lemma prime_equal: fixes p::nat shows "\<lbrakk>prime p; prime q; 2^x=p*q\<rbrakk> \<Longrightarrow> (p=q)"
proof -
  assume a: "prime p" and b: "prime q" and c: "2^x=p*q"
  from a have d: "1 < p" by (simp add: prime_nat_def)
  moreover from b have e: "1<q" by (simp add: prime_nat_def)
  show "p=q"
  proof (cases "p=2")
    assume p: "p=2" then have "2 dvd q" using c and exp_prod1[of q x] and e by simp
    then have "2=q" using primerew[of 2 q] and b by auto
    then show ?thesis using p by simp
  next
    assume p: "p~=2" show "p=q"
    proof (cases "q=2")
      assume q: "q=2" then have "2 dvd p" using c and exp_prod1[of p x] and d by simp
      then have "2=p" using primerew[of 2 p] and a by auto
      then show ?thesis using p by simp
    next
      assume q: "q~=2" show "p=q"
      proof -
        from p have "~ 2 dvd p" using primerew and a by auto
        moreover from q have "~2 dvd q" using primerew and b by auto
        ultimately have "~2 dvd p*q" by (simp add: odd_mul_odd)
        then have "odd ((2 :: nat) ^ x)" by (simp only: c) simp
        moreover have "(2::nat) dvd 2^x"
        proof (cases "x=0")
          assume "x=0" then have "(2::nat)^x=1" by simp
          then show ?thesis using c and d and e by simp
        next
          assume "x~=0" then have "0<x" by simp
          then show ?thesis using two_dvd_exp by simp
        qed
        ultimately show ?thesis by simp
      qed
    qed
  qed
qed

lemma nat_to_bv_length_bv_to_nat:
  "length xs = n \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> nat_to_bv_length (bv_to_nat xs) n = xs"
  apply (simp only: nat_to_bv_length)
  apply (auto)
  apply (simp add: bv_extend_norm_unsigned)
  done

end


theory examples_total_correctness
  imports "../../../hoare/HoareLogic/TotalCorrectness/Abrupt/utp_hoare_total"
begin

section Examples

text \<open>In this section we provide a set of examples for the use of Hoare logic
      for total correctness based on a theory of UTP and lenses. The combination of
      relational algebra, ie. UTP, and lens algebra allows for a semantic based
      framework for the specification of programming languages and their features. It also
      allows a powerful proof tactics for the framework such as @{method rel_auto},
      @{method pred_auto}, etc.\<close>

text \<open>In the following examples:
      \begin{itemize}
         \<^item> The formal notation @{term "\<lbrace>Pre\<rbrace>prog\<lbrace>Post\<rbrace>\<^sub>A\<^sub>B\<^sub>R"} represent a hoare triple for total
            correctness.
         \<^item> All variables are represented by lenses and have the type @{typ "'v \<Longrightarrow> 's"}:
           where  @{typ "'v"} is the view type of the lens and @{typ "'s"} is the type of the state.
         \<^item> Lens properties such as @{term "weak_lens"}, @{term "mwb_lens"}, @{term "wb_lens"},
           @{term "vwb_lens"}, @{term "ief_lens"}, @{term "bij_lens"}
           are used to semantically express what does not change in the state space. For example
           applying the property @{term "id_lens"}.
            Informally this means that any change on x will appear on all
           other variables in the state space.The property @{term "ief_lens"} is just the opposite
           of @{term "id_lens"}.
         \<^item> The formal notation @{term "x \<sharp>\<sharp> P"} is a syntactic sugar for
            @{term "unrest_relation x P"}:
           informally it is used to semantically express that the variable x does not occur
           in the program P.
         \<^item> The formal notation @{term "x \<Midarrow> v"} is a lifting of @{term "x :== v"} to the theory
            of designs: informally it represent an assignment of a value v to a variable x.
         \<^item> The formal notation @{term "&x"} is a syntactic sugar for @{term "\<langle>id\<rangle>\<^sub>s x"}:
           informally it represent the content of a variable x.
         \<^item> The formal notation @{term "\<guillemotleft>l\<guillemotright>"} is a syntactic sugar for @{term "lit l"}:
            informally it represent a lifting of an HOL literal l to a utp expression.
         \<^item> The formal notation @{term "x \<bowtie> y"} is a syntactic sugar for @{term "lens_indep x y"}:
           informally it is a semantic representation that uses two variables
           to characterise independence between two state space regions.
         \<^item> The tactics @{method rel_auto}, @{method pred_auto}, @{method rel_simp},
           @{method pred_simp}, @{method rel_blast}, @{method pred_blast} are used
           to discharge proofs related to UTP-relations and UTP-predicates.
     \end{itemize}\<close>

subsection \<open>Swap variables program\<close>

lemma swap_test_manual:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows
  "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
    z \<Midarrow> &x;;
    x \<Midarrow> &y;;
    y \<Midarrow> &z
   \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   defer
   apply (rule seq_hoare_r_t)
    apply (rule assigns_abr_hoare_r'_t)
   apply (rule assigns_abr_hoare_r'_t)
  apply rel_simp
  apply (simp add: lens_indep_sym)
  done

lemma swap_test:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows
 "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
   z \<Midarrow> &x;;
   x \<Midarrow> &y;;
   y \<Midarrow> &z
  \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  using assms
  apply (simp only: uabr_comp uabr_simpl lens_indep_def)
  apply rel_simp
done

subsection {*Even count program*}

lemma even_count_total:
  "\<lbrace>&a =\<^sub>u \<guillemotleft>0::int\<guillemotright> \<and> &n =\<^sub>u 1 \<and>
    \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
    \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright>\<rbrace>
     i \<Midarrow> &a;;
     j \<Midarrow> 0;;
    (&a =\<^sub>u 0 \<and> &n =\<^sub>u 1 \<and> &j =\<^sub>u 0 \<and> &i =\<^sub>u &a \<and>
     \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
     \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright>)\<^sup>\<top>\<^sup>C;;
    while &i <\<^sub>u &n
    invr &a =\<^sub>u 0 \<and> &n =\<^sub>u 1 \<and>
         \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
         \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright> \<and>
         &j =\<^sub>u (((&i + 1) - &a) div 2) \<and> &i \<le>\<^sub>u &n \<and>  &i \<ge>\<^sub>u &a
    do
      bif &i mod 2 =\<^sub>u 0
        then j \<Midarrow> &j + 1
      else
        SKIP\<^sub>A\<^sub>B\<^sub>R
      eif;;
      i \<Midarrow> &i + 1
    od
  \<lbrace>&j =\<^sub>u 1\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (rule seq_hoare_r_t)
   prefer 2
   apply (rule seq_hoare_r_t [of _ _ true])
    apply (rule assigns_abr_hoare_r'_t)
   apply (rule seq_hoare_r_t)
    apply (rule assume_hoare_r_t)
     apply (rule skip_abr_hoare_r_t)
    prefer 2
    apply (rule while_invr_hoare_r_t)
      apply (rule seq_hoare_r_t)
       prefer 2
       apply (rule assigns_abr_hoare_r'_t)
      apply (rule cond_abr_hoare_r_t)
       apply (rule assigns_abr_hoare_r_t)
       prefer 6
       apply (rule assigns_abr_hoare_r_t)
       unfolding lens_indep_def
       apply rel_auto
      apply rel_auto
     using mod_pos_pos_trivial apply auto
     apply rel_auto
    apply rel_auto
   apply rel_auto
  apply rel_auto
  done

end


theory examples_total_correctness
  imports "../hoare/utp_hoare_total"
begin

section Examples

text \<open>In this section we provide a set of examples for the use of Hoare logic
      for total correctness based on a theory of UTP and lenses. The combination of
      relational algebra, ie. UTP, and lens algebra allows for a semantic based
      framework for the specification of programming languages and their features. It also
      allows a powerful proof tactics for the framework such as @{method rel_auto},
      @{method pred_auto}, etc.\<close>

text \<open>In the following examples:
      \begin{itemize}
         \<^item> The formal notation @{term "\<lbrace>Pre\<rbrace>prog\<lbrace>Post\<rbrace>\<^sub>D"} represent a hoare triple for total
            correctness.
         \<^item> All variables are represented by lenses and have the type @{typ "'v \<Longrightarrow> 's"}:
           where  @{typ "'v"} is the view type of the lens and @{typ "'s"} is the type of the state.
         \<^item> Lens properties such as @{term "weak_lens"}, @{term "mwb_lens"}, @{term "wb_lens"},
           @{term "vwb_lens"}, @{term "ief_lens"}, @{term "bij_lens"}
           are used to semantically express what does not change in the state space. For example
           applying the property @{term "id_lens"}.
            Informally this means that any change on x will appear on all
           other variables in the state space.The property @{term "ief_lens"} is just the opposite
           of @{term "id_lens"}.
         \<^item> The formal notation @{term "x \<sharp>\<sharp> P"} is a syntactic sugar for
            @{term "unrest_relation x P"}:
           informally it is used to semantically express that the variable x does not occur
           in the program P.
         \<^item> The formal notation @{term "x \<Midarrow> v"} is a lifting of @{term "x :== v"} to the theory
            of designs: informally it represent an assignment of a value v to a variable x.
         \<^item> The formal notation @{term "&x"} is a syntactic sugar for @{term "\<langle>id\<rangle>\<^sub>s x"}:
           informally it represent the content of a variable x.
         \<^item> The formal notation @{term "\<guillemotleft>l\<guillemotright>"} is a syntactic sugar for @{term "lit l"}:
            informally it represent a lifting of an HOL literal l to a utp expression.
         \<^item> The formal notation @{term "x \<bowtie> y"} is a syntactic sugar for @{term "lens_indep x y"}:
           informally it is a semantic representation that uses two variables
           to characterise independence between two state space regions.
         \<^item> The tactics @{method rel_auto}, @{method pred_auto}, @{method rel_simp},
           @{method pred_simp}, @{method rel_blast}, @{method pred_blast} are used
           to discharge proofs related to UTP-relations and UTP-predicates.
     \end{itemize}\<close>

subsection \<open>Swap variables program\<close>

lemma swap_test_manual:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
  z \<Midarrow> &x;;
  x \<Midarrow> &y;;
  y \<Midarrow> &z
  \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>D"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   defer
   apply (rule seq_hoare_r_t)
    apply (rule assigns_hoare_r'_t)
   apply (rule assigns_hoare_r'_t)
  apply rel_simp
  apply (simp add: lens_indep_sym)
  apply blast
  done

lemma swap_test:
  assumes "weak_lens x" and "weak_lens y" and "weak_lens z"
  and "x \<bowtie> y" and "x \<bowtie> z" and "y \<bowtie> z"
  shows "\<lbrace>&x =\<^sub>u \<guillemotleft>a\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>b\<guillemotright>\<rbrace>
  z \<Midarrow> &x;;
  x \<Midarrow> &y;;
  y \<Midarrow> &z
  \<lbrace>&x =\<^sub>u \<guillemotleft>b\<guillemotright> \<and> &y =\<^sub>u \<guillemotleft>a\<guillemotright>\<rbrace>\<^sub>D"
  using assms
  by rel_auto (simp add: lens_indep_sym)

subsection {*Even count program*}

lemma even_count_total:
  "\<lbrace>&a =\<^sub>u \<guillemotleft>0::int\<guillemotright> \<and> &n =\<^sub>u 1 \<and>
    \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
    \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright>\<rbrace>
     i \<Midarrow> &a;;
     j \<Midarrow> 0;;
    (&a =\<^sub>u 0 \<and> &n =\<^sub>u 1 \<and> &j =\<^sub>u 0 \<and> &i =\<^sub>u &a \<and>
     \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
     \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright>)\<^sup>\<top>\<^sup>C;;
    while &i <\<^sub>u &n
    invr &a =\<^sub>u 0 \<and> &n =\<^sub>u 1 \<and>
         \<guillemotleft>weak_lens i\<guillemotright> \<and> \<guillemotleft>weak_lens a\<guillemotright> \<and> \<guillemotleft>weak_lens j\<guillemotright> \<and> \<guillemotleft>weak_lens n\<guillemotright> \<and>
         \<guillemotleft>i \<bowtie> a\<guillemotright> \<and> \<guillemotleft>i \<bowtie> j\<guillemotright>  \<and> \<guillemotleft>i \<bowtie> n\<guillemotright> \<and> \<guillemotleft>a \<bowtie> j\<guillemotright> \<and> \<guillemotleft>a \<bowtie> n\<guillemotright> \<and> \<guillemotleft>j \<bowtie> n\<guillemotright> \<and>
         &j =\<^sub>u (((&i + 1) - &a) div 2) \<and> &i \<le>\<^sub>u &n \<and>  &i \<ge>\<^sub>u &a
    do
      bif &i mod 2 =\<^sub>u 0
        then j \<Midarrow> &j + 1
      else
        SKIP
      eif;;
      i \<Midarrow> &i + 1
    od
  \<lbrace>&j =\<^sub>u 1\<rbrace>\<^sub>D"
  apply (rule seq_hoare_r_t)
   prefer 2
   apply (rule seq_hoare_r_t [of _ _ true])
    apply (rule assigns_hoare_r'_t)
   apply (rule seq_hoare_r_t)
    apply (rule assume_hoare_r_t)
     apply (rule skip_hoare_r_t)
    prefer 2
    apply (rule while_invr_hoare_r_t)
      apply (rule seq_hoare_r_t)
       prefer 2
       apply (rule assigns_hoare_r'_t)
      apply (rule cond_hoare_r_t)
       apply (rule assigns_hoare_r_t)
       prefer 6
       apply (rule assigns_hoare_r_t)
       unfolding lens_indep_def
       apply rel_auto
      apply rel_auto
     using mod_pos_pos_trivial apply auto
     apply rel_auto
    apply rel_auto
   apply rel_auto
  apply rel_auto
  done

end


(*
 * Copyright 2016, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * Author: Zhe Hou.
 *)

text {* Miscellaneous definitions. *}
theory Misc
  imports Main
begin

text {* Some utility functions and lemmas. *}
lemma set_eq: "(\<forall>x. (x \<in> s1) = (x \<in> s2)) \<Longrightarrow> s1 = s2"
  by blast

lemma list_mem_range: "List.member l e \<Longrightarrow> \<exists>i. (0 \<le> i \<and> i < List.length l \<and> (l!i) = e)"
  by (meson in_set_conv_nth in_set_member not_le not_less0)

lemma list_mem_range_rev: "\<exists>i. (0 \<le> i \<and> i < List.length l \<and> (l!i) = e) \<Longrightarrow>
  List.member l e"
  by (meson List.member_def nth_mem)

text {* Test if x is before y in the list l. *}

definition list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"list_before x l y \<equiv> \<exists>i j. 0 \<le> i \<and> i < length l \<and> 0 \<le> j \<and> j < length l \<and>
  (l!i) = x \<and> (l!j) = y \<and> i < j"

value "{1::nat,2,3,4}"

text {* A  version of list_before for code export. *}

text {* Given a list l and a member e, return the sublist l' of l
after the first occurrence of e. *}

primrec sublist_after:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sublist_after e [] = []"
|"sublist_after e (x#t) = (if e = x then t else sublist_after e t)"

definition list_before2:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"list_before2 x l y \<equiv> List.member (sublist_after x l) y"

lemma all_drop_eq:
assumes a0:"n\<le>j" and
        a1:"j<length l"
      shows "l!j = (drop n l)!(j-n)"
  using a0 a1 by (simp add: less_or_eq_imp_le)

lemma length_take_while:"i<length l \<Longrightarrow>
       Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l)) \<le> (i + 1)"
  by (metis (full_types) Suc_eq_plus1_left add.commute nat_add_left_cancel_less not_le_imp_less
            nth_mem set_takeWhileD takeWhile_nth)

lemma suc_length_take_while_less_j:
 assumes a0: "j < length l" and
     a1:"x = l ! i" and
     a2:"i < j" and a3:"y = l ! j"
   shows "Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l))\<le>j"
proof-
  have i_l:"i< length l" using a0 a2 by auto
  thus ?thesis using a2 length_take_while[OF i_l] by auto
qed

(*
lemma sublist_after_emp: "\<not> (List.member l x) \<Longrightarrow> sublist_after x l = []"
proof (induction l)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    proof (cases "x = a")
      case True
      then have "List.member (a#l) x"
        by (simp add: member_rec(1))
      then show ?thesis
        using Cons by auto
    next
      case False
      then have "sublist_after x (a # l) = sublist_after x l"
        by simp
      then show ?thesis
        using Cons
        by (simp add: member_rec(1))
    qed
  qed

lemma sublist_after_mem: "List.member l x \<Longrightarrow> sublist_after x (l@l') = (sublist_after x l)@l'"
proof (induction l)
  case Nil
  then show ?case
    by (simp add: member_rec(2))
next
  case (Cons a l)
  then show ?case
  proof (cases "a = x")
    case True
    then have "sublist_after x ((a # l) @ l') = l@l'"
      by simp
    from True have "sublist_after x (a # l) @ l' = l@l'"
      by simp
    then show ?thesis
      using Cons
      using \<open>sublist_after x ((a # l) @ l') = l @ l'\<close> by auto
  next
    case False
    then have f1: "sublist_after x ((a # l) @ l') = sublist_after x (l @ l')"
      by auto
    from False have f2: "sublist_after x (a # l) @ l' = sublist_after x l @ l'"
      by auto
    from Cons(2) False have f3: "List.member l x"
      by (simp add: member_rec(1))
    from Cons f1 f2 f3 show ?thesis
      by auto
  qed
qed

lemma sublist_after_extend: "List.member (sublist_after x l) y \<Longrightarrow>
  List.member (sublist_after x l@l') y"
proof (induction l' rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc w ws)
  then have f1: "List.member (sublist_after x l @ ws) y"
    by auto
  then have f1_1: "List.member ((sublist_after x l @ ws)@[w]) y"
    by (metis UnCI in_set_member set_append)
  from snoc(2) have f2: "List.member l x"
    using member_rec(2) sublist_after_emp by fastforce
  from f1_1 f2 show ?case
    using sublist_after_mem by auto
qed

lemma sublist_after_extend2: "List.member (sublist_after x l) y \<Longrightarrow>
  List.member (sublist_after x (l@l')) y"
proof (induction l' rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc w ws)
  then have f1: "List.member (sublist_after x (l @ ws)) y"
    by auto
  then have f1_1: "List.member ((sublist_after x (l @ ws))@[w]) y"
    by (metis UnCI in_set_member set_append)
  from snoc(2) have f2: "List.member l x"
    using member_rec(2) sublist_after_emp by fastforce
  from f1_1 f2 show ?case
    by (simp add: sublist_after_mem)
qed

lemma list_before2_extend: "list_before2 e1 l e2 \<Longrightarrow> list_before2 e1 (l@l') e2"
  unfolding list_before2_def
  by (simp add: sublist_after_extend2)
*)

lemma list_before_extend: "list_before e1 l e2 \<Longrightarrow> list_before e1 (l@l') e2"
proof -
  assume a1: "list_before e1 l e2"
  obtain nn :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat" and nna :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat" where
    "\<forall>x0 x1 x2. (\<exists>v3 v4. 0 \<le> v3 \<and> v3 < length x1 \<and> 0 \<le> v4 \<and> v4 < length x1 \<and> x1 ! v3 = x2 \<and> x1 ! v4 = x0 \<and> v3 < v4) = (0 \<le> nn x0 x1 x2 \<and> nn x0 x1 x2 < length x1 \<and> 0 \<le> nna x0 x1 x2 \<and> nna x0 x1 x2 < length x1 \<and> x1 ! nn x0 x1 x2 = x2 \<and> x1 ! nna x0 x1 x2 = x0 \<and> nn x0 x1 x2 < nna x0 x1 x2)"
  by moura
  then have f2: "\<forall>a as aa. (\<not> list_before a as aa \<or> 0 \<le> nn aa as a \<and> nn aa as a < length as \<and> 0 \<le> nna aa as a \<and> nna aa as a < length as \<and> as ! nn aa as a = a \<and> as ! nna aa as a = aa \<and> nn aa as a < nna aa as a) \<and> (list_before a as aa \<or> (\<forall>n na. \<not> 0 \<le> n \<or> \<not> n < length as \<or> \<not> 0 \<le> na \<or> \<not> na < length as \<or> as ! n \<noteq> a \<or> as ! na \<noteq> aa \<or> \<not> n < na))"
    by (meson list_before_def)
  then have f3: "0 \<le> nn e2 l e1 \<and> nn e2 l e1 < length l \<and> 0 \<le> nna e2 l e1 \<and> nna e2 l e1 < length l \<and> l ! nn e2 l e1 = e1 \<and> l ! nna e2 l e1 = e2 \<and> nn e2 l e1 < nna e2 l e1"
    using a1 by presburger
  then have f4: "nn e2 l e1 < length (l @ l')"
    by simp
    have f5: "nna e2 l e1 < length (l @ l')"
      using f3 by simp
    have f6: "(l @ l') ! nn e2 l e1 = e1"
      using f3 by (simp add: nth_append)
    have "(l @ l') ! nna e2 l e1 = e2"
      using f3 by (metis nth_append)
  then show ?thesis
    using f6 f5 f4 f3 f2 by meson
qed

lemma list_before_extend2:
  assumes a1: "List.member l e1"
  and a2: "\<not>(List.member l e2)"
  and a3: "List.member (l@l') e2"
shows "list_before e1 (l@l') e2"
proof -
  from a1 obtain i where f1: "i < length l \<and> (l!i) = e1"
    by (meson list_mem_range)
  from a2 have f2: "\<not>(\<exists>k. k < length l \<and> (l!k) = e2)"
    by (meson in_set_member nth_mem)
  then have f3: "\<not>(\<exists>k. k < length l \<and> ((l@l')!k) = e2)"
    by (metis nth_append)
  from a3 obtain j where f4: "j < length (l@l') \<and> ((l@l')!j) = e2"
    by (meson list_mem_range)
  from f3 f4 have f5: "j \<ge> length l"
    using not_le by blast
  from f1 have f6: "i < length l \<and> ((l@l')!i) = e1"
    by (simp add: nth_append)
  show ?thesis unfolding list_before_def using f4 f5 f6
    by (metis (no_types, lifting) dual_order.strict_trans le0 less_le_trans)
qed

lemma list_before_extend2':
  assumes a1: "List.member l e1"
  and a2: "List.member l' e2"
shows "list_before e1 (l@l') e2"
proof -
  from a1 obtain i where  f0:"i < length l \<and> (l!i) = e1"
    by (meson list_mem_range)
  then have f1:"i<length l + length l' \<and> (l @ l') ! i = e1"
    by (meson nth_append trans_less_add1 list_mem_range)
  from a2 obtain j where f2: "j < length l' \<and> (l'!j) = e2"
    by (meson list_mem_range)
  then have "j+length l < length l + length l'" by auto
  moreover have "(l @ l') ! (j+length l) = e2" using f2
    by (metis add.commute nth_append_length_plus)
  moreover have "i<(j+length l)" using f1
    by (simp add: f0 trans_less_add2)
  ultimately show ?thesis using f1 unfolding list_before_def
    by (metis length_append less_eq_nat.simps(1))
qed

lemma list_elements_before: "List.member l e1 \<Longrightarrow> List.member l e2 \<Longrightarrow>  e1 \<noteq> e2 \<Longrightarrow>
  list_before e1 l e2 \<or> list_before e2 l e1"
  apply auto
  unfolding list_before_def apply simp
  using list_mem_range
  by (metis linorder_neqE_nat)

lemma dist_elem_not_before: "List.member l e1 \<Longrightarrow> List.member l e2 \<Longrightarrow> e1 \<noteq> e2
  \<Longrightarrow> \<not> (list_before e1 l e2) \<Longrightarrow> list_before e2 l e1"
  using list_elements_before by fastforce

text {* Define a list without repeating members. *}

(*
definition non_repeat_list:: "'a list \<Rightarrow> bool" where
"non_repeat_list l \<equiv>
  \<forall>i j. (0 \<le> i \<and> i < List.length l \<and> 0 \<le> j \<and> j < List.length l \<and> i \<noteq> j) \<longrightarrow>
        (l!i \<noteq> l!j)"
*)

definition non_repeat_list:: "'a list \<Rightarrow> bool" where
"non_repeat_list l \<equiv> distinct l"

text {* Get the position of a member in a non-repeating list. *}

definition non_repeat_list_pos:: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"non_repeat_list_pos x l \<equiv> THE n. non_repeat_list l \<and> n < length l \<and> (l!n) = x"

text {* A new version of non_repeat_list_post that is used to code export. *}

primrec non_repeat_list_pos2:: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"non_repeat_list_pos2 x [] = 0"
|"non_repeat_list_pos2 x (a#al) = (if x = a then 0 else 1 + (non_repeat_list_pos2 x al))"

(* Zhe: non_repeat_list_pos2 and non_repeat_list_pos are actually different when
x is not in l! I'm not sure what value would non_repeat_list_pos return when
x is not in l. *)
lemma non_repeat_list_code_equal: "non_repeat_list_pos2 x l = non_repeat_list_pos x l"
sorry

lemma non_repeat_list_emp: "non_repeat_list []"
  unfolding non_repeat_list_def
  by auto

lemma non_repeat_list_pos_rel: "non_repeat_list l \<Longrightarrow> List.member l x \<Longrightarrow> List.member l y \<Longrightarrow>
 x \<noteq> y \<Longrightarrow> list_before x l y \<or> list_before y l x"
  unfolding non_repeat_list_def list_before_def
  by (metis le_neq_implies_less list_mem_range not_le)

(*
  apply auto
  by (metis in_set_conv_nth member_def nat_neq_iff)
*)

lemma non_repeat_list_extend: "non_repeat_list l \<Longrightarrow> \<not> (List.member l x) \<Longrightarrow>
 non_repeat_list (l@[x])"
  using non_repeat_list_def
  by (simp add: member_def non_repeat_list_def)

(*
proof (auto simp add: non_repeat_list_def)
  fix i :: nat and j :: nat
  assume a1: "\<not> List.member l x"
  assume a2: "i \<noteq> j"
  assume a3: "i < Suc (length l)"
  assume a4: "j < Suc (length l)"
  assume a5: "(l @ [x]) ! i = (l @ [x]) ! j"
  assume a6: "\<forall>i j. i < length l \<and> j < length l \<and> i \<noteq> j \<longrightarrow> l ! i \<noteq> l ! j"
  have f7: "\<And>n as. \<not> n < length as \<or> List.member as (as ! n::'a)"
    by (metis in_set_member nth_mem)
  then have "length l = i"
    using a6 a5 a4 a3 a2 a1 by (metis (no_types) less_Suc_eq nth_append nth_append_length)
  then show False
    using f7 a5 a4 a2 a1 by (metis (no_types) less_Suc_eq nth_append nth_append_length)
qed
*)

lemma non_repeat_list_sublist_mem: "non_repeat_list (l1@[x]@l2) \<Longrightarrow> \<not> (List.member l1 x)"
  unfolding non_repeat_list_def
  by (simp add: in_set_member non_repeat_list_def)
(*
proof -
  assume "\<forall>i j. 0 \<le> i \<and> i < length (l1 @ [x] @ l2) \<and> 0 \<le> j \<and> j < length (l1 @ [x] @ l2) \<and> i \<noteq> j \<longrightarrow> (l1 @ [x] @ l2) ! i \<noteq> (l1 @ [x] @ l2) ! j"
  then have "distinct (l1 @ [x] @ l2)"
    by (meson distinct_conv_nth less_eq_nat.simps(1))
  then show ?thesis
  by (simp add: in_set_member)
qed
*)

lemma non_repeat_list_pos_unique: "non_repeat_list l \<Longrightarrow>
0 \<le> i \<and> i < length l \<Longrightarrow> 0 \<le> j \<and> j < length l \<Longrightarrow> l!i = l!j \<Longrightarrow> i = j"
  unfolding non_repeat_list_def
  by (simp add: nth_eq_iff_index_eq)
(*
  by auto
*)

lemma non_repeat_list_sublist: "non_repeat_list l \<Longrightarrow> l1@l2 = l \<Longrightarrow> non_repeat_list l1"
  unfolding non_repeat_list_def
  using distinct_append by blast

(*  by (metis length_append nth_append trans_less_add1) *)

lemma non_repeat_list_before: "non_repeat_list l \<Longrightarrow> list_before e1 l e2 \<Longrightarrow>
  \<not>(list_before e2 l e1)"
  unfolding non_repeat_list_def list_before_def
  using nth_eq_iff_index_eq by fastforce
(*
  apply auto
  by (metis less_asym' less_trans) *)

text {* l1 is a sublist of l2. *}

definition is_sublist:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sublist l1 l2 \<equiv> \<exists>l. l1@l = l2"

text {* A new version of is_sublist for code export. *}

definition is_sublist2:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sublist2 l1 l2 \<equiv> take (length l1) l2 = l1"

lemma is_sublist_code_equal: "is_sublist2 l1 l2 = is_sublist l1 l2"
  unfolding is_sublist2_def is_sublist_def
  by (metis append_eq_conv_conj append_take_drop_id)

lemma is_sublist_id: "is_sublist l l"
  unfolding is_sublist_def
  by auto

lemma sublist_element: "is_sublist l1 l2 \<Longrightarrow> i < List.length l1 \<Longrightarrow> l1!i = l2!i"
  unfolding is_sublist_def
  by (metis nth_append)

lemma sublist_member:
  assumes a1: "is_sublist l1 l2"
  and a2: " List.member l1 e"
shows "List.member l2 e"
proof -
  from a2 obtain i where f1: "i < List.length l1 \<and> l1!i = e"
    by (meson list_mem_range)
  then have f2: "l2!i = e"
    using a1 sublist_element by fastforce
  from f1 a1 have "i < List.length l2"
    unfolding is_sublist_def
    by auto
  then have "i < List.length l2 \<and> l2!i = e"
    using f2 by auto
  then show ?thesis
    by (meson member_def nth_mem)
qed

lemma sublist_repeat: "is_sublist l1 l2 \<Longrightarrow> \<not> (non_repeat_list l1) \<Longrightarrow> \<not> (non_repeat_list l2)"
  unfolding is_sublist_def non_repeat_list_def
  apply auto
  done
(*  by (metis nth_append trans_less_add1)    *)

text {* Given an item and a list, return the sub-list that
is before the item in the list.
If the item in not in the list, return []. *}

primrec find_sub_list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"find_sub_list_before e [] acc = []"
|"find_sub_list_before e (x#xs) acc = (if e = x then acc else find_sub_list_before e xs (acc@[x]))"

definition sub_list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sub_list_before e l = find_sub_list_before e l []"

lemma list_before_tran:
"distinct l \<Longrightarrow>
 list_before x1 l x2 \<Longrightarrow>
 list_before x2 l x3 \<Longrightarrow>
 list_before x1 l x3"
  unfolding list_before_def
  by (metis (no_types, lifting) dual_order.strict_trans nth_eq_iff_index_eq)

lemma list_before_not_sym:
"distinct l \<Longrightarrow>
 list_before x l y \<Longrightarrow> \<not> list_before y l x"
  unfolding list_before_def
  using nth_eq_iff_index_eq by fastforce

lemma list_before_in_list:
"x\<in>{x. list_before x l y} \<Longrightarrow>
 List.member l x"
  unfolding list_before_def
  apply auto
  by (meson dual_order.strict_trans in_set_member nth_mem)

lemma not_list_before_members_eq_or_inv:"List.member l x \<Longrightarrow> List.member l y \<Longrightarrow> \<not> list_before x l y \<Longrightarrow>
      x=y \<or> list_before y l x"
  unfolding list_before_def
  by (metis le_neq_implies_less list_mem_range not_le)

lemma exists_unique_list_member:
      "finite z \<Longrightarrow>
       z\<noteq>{} \<Longrightarrow>
       distinct l \<Longrightarrow>
       z\<subseteq>{x. List.member l x} \<Longrightarrow>
       \<exists>x. x\<in>z \<and> (\<forall>x'\<in>z. x'\<noteq>x \<longrightarrow> list_before x' l x)"
proof(induction rule: Finite_Set.finite_ne_induct)
case (singleton x)
  then show ?case
    by blast
next
  case (insert x F)
  then obtain x1 where hp:"x1\<in>F \<and> (\<forall>x'\<in>F. x' \<noteq> x1 \<longrightarrow> list_before x' l x1)"
     by auto
  then have neq:"x\<noteq>x1" using insert by auto
  { assume "list_before x l x1"
    then have ?case using hp neq by fastforce
  }note l1 =this
  {
    assume assm:"list_before x1 l x"
    then have ?case using hp neq list_before_tran[OF insert(5) _ assm]
      by fast
  }note l2 = this
  show ?case
    by (metis hp insert.prems(2) insert_subset l1 l2 list_elements_before mem_Collect_eq
       neq set_rev_mp)
qed

lemma unique_max_list_before:
  assumes
        a2:"distinct l" and
       a4:"x\<in>z \<and> (\<forall>x'\<in>z. x'\<noteq>x \<longrightarrow> list_before x' l x)"
     shows "\<forall>x'. x'\<in>z \<and> (\<forall>x''\<in>z. x''\<noteq>x' \<longrightarrow> list_before x'' l x') \<longrightarrow> x' = x "
  using list_before_not_sym[OF a2] a4 by metis

lemma finite_subset_list:"z\<subseteq>{x. List.member l x} \<Longrightarrow> finite z"
  unfolding member_def
  by (simp add: finite_subset)

lemma exists_unique_list_before_list:"distinct l \<Longrightarrow>
       z\<subseteq>{x. List.member l x} \<Longrightarrow>
       z\<noteq>{} \<Longrightarrow>
       \<exists>!x. x\<in>z \<and> (\<forall>x'\<in>z. x'\<noteq>x \<longrightarrow> list_before x' l x)"
  apply (frule exists_unique_list_member[OF finite_subset_list],assumption+)
  apply clarsimp
  by (frule unique_max_list_before, auto simp add: Ex1_def)

lemma exists_unique_list_before_lb:
  assumes a0:"distinct l" and
       a1:"z\<subseteq>{x. list_before x l y}" and
      a2:"z\<noteq>{}"
    shows "\<exists>!x. x\<in>z \<and> (\<forall>x'\<in>z. x'\<noteq>x \<longrightarrow> list_before x' l x)"
proof-
  have "z\<subseteq>{x. List.member l x}"
    using a1 unfolding list_before_def member_def by auto
  then show ?thesis using exists_unique_list_before_list[OF a0 _ a2]
    by auto
qed

end


subsection \<open>Oblivious Transfer functionalities\<close>

text\<open>Here we define the functionalities for 1-out-of-2 and 1-out-of-4 OT.\<close>

theory OT_Functionalities imports
  CryptHOL.CryptHOL
begin

definition funct_OT_12 :: "('a \<times>  'a) \<Rightarrow> bool \<Rightarrow> (unit \<times> 'a) spmf"
  where "funct_OT_12 input\<^sub>1 \<sigma> = return_spmf (() , if \<sigma> then (snd input\<^sub>1) else (fst input\<^sub>1))"

lemma lossless_funct_OT_12: "lossless_spmf (funct_OT_12 msgs \<sigma>)"
  by(simp add: funct_OT_12_def)

definition funct_OT_14 :: "('a \<times> 'a \<times> 'a \<times> 'a) \<Rightarrow> (bool \<times> bool) \<Rightarrow> (unit \<times> 'a) spmf"
  where "funct_OT_14 M C = do {
    let (c0,c1) = C;
    let (m00, m01, m10, m11) = M;
    return_spmf ((),if c0 then (if c1 then m11 else m10) else (if c1 then m01 else m00))}"

lemma lossless_funct_14_OT: "lossless_spmf (funct_OT_14 M C)"
  by(simp add: funct_OT_14_def split_def)

end