theory Ch7
  imports Big_Step
begin

(*
datatype com =
    SKIP
  | Assign vname aexp    ("_ ::= _" [1000, 61] 61)
  | Seq    com  com      ("_;;/ _"  [60, 61] 60)
  | If     bexp com com  ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
  | While  bexp com      ("(WHILE _/ DO _)"  [0, 61] 61)
*)

(* 7.1 *)

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}" |
"assigned (Assign v a) = {v}" |
"assigned (Seq c1 c2) = (assigned c1 \<union> assigned c2)" |
"assigned (If b c1 c2) = (assigned c1 \<union> assigned c2)" |
"assigned (While b c) = assigned c"

lemma "\<lbrakk>(c, s) \<Rightarrow> t; x \<notin> assigned c\<rbrakk> \<Longrightarrow> s x = t x"
  apply(induction rule: big_step_induct)
  apply(auto)
  done

(* 7.2 *)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>The Option Monad\<close>

theory Option_Monad
  imports "HOL-Library.Monad_Syntax"
begin

declare Option.bind_cong [fundef_cong]

definition guard :: "bool \<Rightarrow> unit option"
  where
    "guard b = (if b then Some () else None)"

lemma guard_cong [fundef_cong]:
  "b = c \<Longrightarrow> (c \<Longrightarrow> m = n) \<Longrightarrow> guard b >> m = guard c >> n"
  by (simp add: guard_def)

lemma guard_simps:
  "guard b = Some x \<longleftrightarrow> b"
  "guard b = None \<longleftrightarrow> \<not> b"
  by (cases b) (simp_all add: guard_def)

lemma guard_elims[elim]:
  "guard b = Some x \<Longrightarrow> (b \<Longrightarrow> P) \<Longrightarrow> P"
  "guard b = None \<Longrightarrow> (\<not> b \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp_all add: guard_simps)

lemma guard_intros [intro, simp]:
  "b \<Longrightarrow> guard b = Some ()"
  "\<not> b \<Longrightarrow> guard b = None"
  by (simp_all add: guard_simps)

lemma guard_True [simp]: "guard True = Some ()" by simp
lemma guard_False [simp]: "guard False = None" by simp

lemma guard_and_to_bind: "guard (a \<and> b) = guard a \<bind> (\<lambda> _. guard b)" by (cases a; cases b; auto)

fun zip_option :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list option"
  where
    "zip_option [] [] = Some []"
  | "zip_option (x#xs) (y#ys) = do { zs \<leftarrow> zip_option xs ys; Some ((x, y) # zs) }"
  | "zip_option (x#xs) [] = None"
  | "zip_option [] (y#ys) = None"

text \<open>induction scheme for zip\<close>
lemma zip_induct [case_names Cons_Cons Nil1 Nil2]:
  assumes "\<And>x xs y ys. P xs ys \<Longrightarrow> P (x # xs) (y # ys)"
    and "\<And>ys. P [] ys"
    and "\<And>xs. P xs []"
  shows "P xs ys"
  using assms by (induction_schema) (pat_completeness, lexicographic_order)

lemma zip_option_same[simp]: \<^marker>\<open>contributor \<open>Martin Desharnais\<close>\<close>
  "zip_option xs xs = Some (zip xs xs)"
  by (induction xs) simp_all

lemma zip_option_zip_conv:
  "zip_option xs ys = Some zs \<longleftrightarrow> length ys = length xs \<and> length zs = length xs \<and> zs = zip xs ys"
proof -
  {
    assume "zip_option xs ys = Some zs"
    hence "length ys = length xs \<and> length zs = length xs \<and> zs = zip xs ys"
    proof (induct xs ys arbitrary: zs rule: zip_option.induct)
      case (2 x xs y ys)
      then obtain zs' where "zip_option xs ys = Some zs'"
        and "zs = (x, y) # zs'" by (cases "zip_option xs ys") auto
      from 2(1) [OF this(1)] and this(2) show ?case by simp
    qed simp_all
  } moreover {
    assume "length ys = length xs" and "zs = zip xs ys"
    hence "zip_option xs ys = Some zs"
      by (induct xs ys arbitrary: zs rule: zip_induct) force+
  }
  ultimately show ?thesis by blast
qed

lemma zip_option_None:
  "zip_option xs ys = None \<longleftrightarrow> length xs \<noteq> length ys"
proof -
  {
    assume "zip_option xs ys = None"
    have "length xs \<noteq> length ys"
    proof (rule ccontr)
      assume "\<not> length xs \<noteq> length ys"
      hence "length xs = length ys" by simp
      hence "zip_option xs ys = Some (zip xs ys)" by (simp add: zip_option_zip_conv)
      with \<open>zip_option xs ys = None\<close> show False by simp
    qed
  } moreover {
    assume "length xs \<noteq> length ys"
    hence "zip_option xs ys = None"
      by (induct xs ys rule: zip_option.induct) simp_all
  }
  ultimately show ?thesis by blast
qed

declare zip_option.simps [simp del]

lemma zip_option_intros [intro]:
  "\<lbrakk>length ys = length xs; length zs = length xs; zs = zip xs ys\<rbrakk>
    \<Longrightarrow> zip_option xs ys = Some zs"
  "length xs \<noteq> length ys \<Longrightarrow> zip_option xs ys = None"
  by (simp_all add: zip_option_zip_conv zip_option_None)

lemma zip_option_elims [elim]:
  "zip_option xs ys = Some zs
    \<Longrightarrow> (\<lbrakk>length ys = length xs; length zs = length xs; zs = zip xs ys\<rbrakk> \<Longrightarrow> P)
    \<Longrightarrow> P"
  "zip_option xs ys = None \<Longrightarrow> (length xs \<noteq> length ys \<Longrightarrow> P) \<Longrightarrow> P"
  by (simp_all add: zip_option_zip_conv zip_option_None)

lemma zip_option_simps [simp]:
  "zip_option xs ys = None \<Longrightarrow> length xs = length ys \<Longrightarrow> False"
  "zip_option xs ys = None \<Longrightarrow> length xs \<noteq> length ys"
  "zip_option xs ys = Some zs \<Longrightarrow> zs = zip xs ys"
  by (simp_all add: zip_option_None zip_option_zip_conv)

fun mapM :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list option"
  where
    "mapM f [] = Some []"
  | "mapM f (x#xs) = do {
      y \<leftarrow> f x;
      ys \<leftarrow> mapM f xs;
      Some (y # ys)
    }"

lemma mapM_None:
  "mapM f xs = None \<longleftrightarrow> (\<exists>x\<in>set xs. f x = None)"
proof (induct xs)
  case (Cons x xs) thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some:
  "mapM f xs = Some ys \<Longrightarrow> ys = map (\<lambda>x. the (f x)) xs \<and> (\<forall>x\<in>set xs. f x \<noteq> None)"
proof (induct xs arbitrary: ys)
  case (Cons x xs ys)
  thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some_idx:
  assumes some: "mapM f xs = Some ys" and i: "i < length xs"
  shows "\<exists>y. f (xs ! i) = Some y \<and> ys ! i = y"
proof -
  note m = mapM_Some [OF some]
  from m[unfolded set_conv_nth] i have "f (xs ! i) \<noteq> None" by auto
  then obtain y where "f (xs ! i) = Some y" by auto
  then have "f (xs ! i) = Some y \<and> ys ! i = y" unfolding m [THEN conjunct1] using i by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma mapM_map:
  "mapM f xs = (if (\<forall>x\<in>set xs. f x \<noteq> None) then Some (map (\<lambda>x. the (f x)) xs) else None)"
proof (cases "mapM f xs")
  case None
  thus ?thesis using mapM_None by auto
next
  case (Some ys)
  with mapM_Some [OF Some] show ?thesis by auto
qed

lemma mapM_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> 'c option) \<Rightarrow> 'd option"
  assumes C: "\<And>y. mono_option (C y)"
  shows "mono_option (\<lambda>f. mapM (\<lambda>y. C y f) B)"
proof (induct B)
  case Nil
  show ?case unfolding mapM.simps
    by (rule option.const_mono)
next
  case (Cons b B)
  show ?case unfolding mapM.simps
    by (rule bind_mono [OF C bind_mono [OF Cons option.const_mono]])
qed

end


theory Check_Shortest_Path_Verification
imports
  "Vcg"
  "../Simpl_Verification/Check_Shortest_Path_Impl"

begin

definition no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool" where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition abs_IGraph :: "IGraph \<Rightarrow> (nat, nat) pre_digraph" where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iarcs G, head = snd o iarcs G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and arcs_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and tail_absI[simp]: "tail (abs_IGraph G) e = fst (iarcs G e)"
  and head_absI[simp]: "head (abs_IGraph G) e = snd (iarcs G e)"
  by (auto simp: abs_IGraph_def)

lemma is_wellformed_inv_step:
  "is_wellformed_inv G (Suc i) \<longleftrightarrow> is_wellformed_inv G i
      \<and> fst (iarcs G i) < ivertex_cnt G \<and> snd (iarcs G i) < ivertex_cnt G"
  by (auto simp add: is_wellformed_inv_def less_Suc_eq)

lemma (in is_wellformed_impl) is_wellformed_spec:
  "\<forall>G. \<Gamma> \<turnstile>\<^sub>t \<lbrace>\<acute>G = G\<rbrace> \<acute>R :== PROC is_wellformed(\<acute>G) \<lbrace>\<acute>R = is_wellformed_inv G (iedge_cnt G)\<rbrace>"
  apply vcg
  apply (auto simp: is_wellformed_inv_step)
  apply (auto simp: is_wellformed_inv_def)
done

lemma trian_inv_step:
  "trian_inv G d c (Suc i) \<longleftrightarrow> trian_inv G d c i
    \<and> d (snd (iarcs G i)) \<le> d (fst (iarcs G i)) + c i"
  by (auto simp: trian_inv_def less_Suc_eq)

lemma (in trian_impl) trian_spec:
  "\<forall>G d c. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>c = c\<rbrace>
    \<acute>R :== PROC trian(\<acute>G, \<acute>dist, \<acute>c)
    \<lbrace> \<acute>R = trian_inv G d c (iedge_cnt G)\<rbrace>"
  apply vcg
  apply (auto simp add: trian_inv_step)
  apply (auto simp: trian_inv_def)
done

lemma just_inv_step:
  "just_inv G d c s n p (Suc v) \<longleftrightarrow> just_inv G d c s n p v
    \<and> (v \<noteq> s \<and> n v \<noteq> \<infinity> \<longrightarrow>
      (\<exists> e. e = the (p v) \<and> e < iedge_cnt G \<and>
        v = snd (iarcs G e) \<and>
        d v = d (fst (iarcs G e)) + ereal (c e) \<and>
        n v = n (fst (iarcs G e)) + (enat 1)))"
  by (auto simp: just_inv_def less_Suc_eq)

lemma just_inv_le:
  assumes "j \<le> i" "just_inv G d c s n p i"
  shows "just_inv G d c s n p j"
  using assms by (induct rule: dec_induct) (auto simp: just_inv_step)

lemma not_just_verts:
  fixes G R c d n p s v
  assumes "v < ivertex_cnt G"
  assumes "v \<noteq> s \<and> n v \<noteq> \<infinity> \<and>
        (iedge_cnt G \<le> the (p v) \<or>
        snd (iarcs G (the (p v))) \<noteq> v \<or>
        d v \<noteq>
          d (fst (iarcs G (the (p v)))) + ereal (c (the (p v))) \<or>
        n v \<noteq> n (fst (iarcs G (the (p v)))) + enat 1)"
  shows "\<not> just_inv G d c s n p (ivertex_cnt G)"
proof (rule notI)
  assume jv: "just_inv G d c s n p (ivertex_cnt G)"
  have "just_inv G d c s n p (Suc v)"
    using just_inv_le[OF _ jv] assms(1) by simp
  then have "(v \<noteq> s \<and> n v \<noteq> \<infinity> \<longrightarrow>
      (\<exists> e. e = the (p v) \<and> e < iedge_cnt G \<and>
        v = snd (iarcs G e) \<and>
        d v = d (fst (iarcs G e)) + ereal (c e) \<and>
        n v = n (fst (iarcs G e)) + (enat 1)))"
        by (auto simp: just_inv_step)
  with assms show False  by force
qed

lemma (in just_impl) just_spec:
  "\<forall>G d c s n p.
    \<Gamma>  \<turnstile>\<^sub>t \<lbrace>\<acute>G = G \<and> \<acute>dist = d \<and>
    \<acute>c = c \<and> \<acute>s = s \<and> \<acute>enum = n \<and> \<acute>pred = p\<rbrace>
    \<acute>R :== PROC just(\<acute>G, \<acute>dist, \<acute>c, \<acute>s, \<acute>enum, \<acute>pred)
    \<lbrace> \<acute>R = just_inv  G d c s n p (ivertex_cnt G)\<rbrace>"
  apply vcg
  apply (auto simp: not_just_verts just_inv_step)
  apply (simp add: just_inv_def)
done

lemma no_path_inv_step:
  "no_path_inv G d n (Suc v) \<longleftrightarrow> no_path_inv G d n v
    \<and> (d v = \<infinity> \<longleftrightarrow> n v = \<infinity>)"
  by (auto simp add: no_path_inv_def less_Suc_eq)

lemma (in no_path_impl) no_path_spec:
  "\<forall>G d n. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>enum = n\<rbrace>
    \<acute>R :== PROC no_path(\<acute>G, \<acute>dist, \<acute>enum)
    \<lbrace> \<acute>R = no_path_inv G d n (ivertex_cnt G)\<rbrace>"
  apply vcg
  apply (simp_all add: no_path_inv_step)
  apply (auto simp: no_path_inv_def)
done

lemma non_neg_cost_inv_step:
  "non_neg_cost_inv G c (Suc i) \<longleftrightarrow> non_neg_cost_inv G c i
    \<and> c i \<ge> 0"
  by (auto simp add: non_neg_cost_inv_def less_Suc_eq)

lemma (in non_neg_cost_impl) non_neg_cost_spec:
  "\<forall>G c. \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>c = c\<rbrace>
    \<acute>R :== PROC non_neg_cost(\<acute>G, \<acute>c)
    \<lbrace> \<acute>R = non_neg_cost_inv G c (iedge_cnt G)\<rbrace>"
  apply vcg
  apply (simp_all add: non_neg_cost_inv_step)
  apply (auto simp: non_neg_cost_inv_def)
done

lemma basic_just_sp_eq_invariants:
"\<And>G dist c s enum pred.
  basic_just_sp_pred (abs_IGraph G) dist c s enum pred \<longleftrightarrow>
    (is_wellformed_inv G (iedge_cnt G) \<and>
    dist s \<le> 0 \<and>
    trian_inv G dist c (iedge_cnt G) \<and>
    just_inv G dist c s enum pred (ivertex_cnt G))"
proof -
  fix G d c s n p
  let ?aG = "abs_IGraph G"
  have "fin_digraph (abs_IGraph G) \<longleftrightarrow> is_wellformed_inv G (iedge_cnt G)"
    unfolding is_wellformed_inv_def fin_digraph_def fin_digraph_axioms_def
      wf_digraph_def no_loops_def
      by auto
moreover
  have "trian_inv G d c (iedge_cnt G) =
    (\<forall>e. e \<in> arcs (abs_IGraph G) \<longrightarrow>
   (d (head ?aG e) \<le> d (tail ?aG e) + ereal (c e)))"
    by (simp add: trian_inv_def)
moreover
  have "just_inv  G d c s n p (ivertex_cnt G) =
    (\<forall>v. v \<in> verts ?aG \<longrightarrow>
      v \<noteq> s \<longrightarrow> n v \<noteq> \<infinity> \<longrightarrow>
      (\<exists>e\<in>arcs ?aG. e = the (p v) \<and>
      v = head ?aG e \<and>
      d v = d (tail ?aG e) + ereal (c e) \<and>
     n v = n (tail ?aG e) + enat 1))"
      unfolding just_inv_def by fastforce
ultimately
   show "?thesis G d c s n p"
   unfolding
    basic_just_sp_pred_def
    basic_just_sp_pred_axioms_def
    basic_sp_def basic_sp_axioms_def
   by presburger
qed

lemma (in check_basic_just_sp_impl) check_basic_just_sp_imp_locale:
  "\<forall> G d c s n p . \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>c = c \<and> \<acute>s = s \<and> \<acute>enum = n \<and> \<acute>pred = p \<rbrace>
    \<acute>R :== PROC check_basic_just_sp (\<acute>G, \<acute>dist, \<acute>c, \<acute>s, \<acute>enum, \<acute>pred)
    \<lbrace> \<acute>R =  basic_just_sp_pred (abs_IGraph G) d c s n p\<rbrace>"
    by vcg (simp add: basic_just_sp_eq_invariants)

(*
lemma (in check_basic_just_sp_impl) check_basic_just_sp_imp_locale:
  "\<And>G d c s n p . \<Gamma> \<turnstile> \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>c = c \<and> \<acute>s = s \<and> \<acute>enum = n \<and> \<acute>pred = p \<rbrace>
    \<acute>R :== PROC check_basic_just_sp (\<acute>G, \<acute>dist, \<acute>c, \<acute>s, \<acute>enum, \<acute>pred)
    \<lbrace> \<acute>R =  basic_just_sp_pred (abs_IGraph G) d c s n p\<rbrace>"
    by vcg (simp add: basic_just_sp_eq_invariants)
*)
lemma shortest_path_non_neg_cost_eq_invariants:
"\<And>G d c s n p .
  shortest_path_non_neg_cost_pred (abs_IGraph G) d c s n p \<longleftrightarrow>
    (is_wellformed_inv G (iedge_cnt G) \<and>
    d s \<le> 0 \<and>
    trian_inv G d c (iedge_cnt G) \<and>
    just_inv G d c s n p (ivertex_cnt G) \<and>
    s < ivertex_cnt G \<and> d s = 0 \<and>
    no_path_inv G d n (ivertex_cnt G) \<and>
    non_neg_cost_inv G c (iedge_cnt G))"
proof -
  fix G d c s n p
  let ?aG = "abs_IGraph G"
  have "no_path_inv G d n (ivertex_cnt G) \<longleftrightarrow>
    (\<forall>v. v \<in> verts ?aG \<longrightarrow> (d v = \<infinity>) = (n v = \<infinity>))"
    by (simp add: no_path_inv_def)
moreover
  have "non_neg_cost_inv G c (iedge_cnt G) \<longleftrightarrow>
    (\<forall>e. e \<in> arcs ?aG \<longrightarrow> 0 \<le> c e)"
    by (simp add: non_neg_cost_inv_def)
ultimately
   show "?thesis G d c s n p"
   unfolding shortest_path_non_neg_cost_pred_def
    shortest_path_non_neg_cost_pred_axioms_def
   using basic_just_sp_eq_invariants by simp
qed

theorem (in check_sp_impl) check_sp_eq_locale:
  "\<forall> G d c s n p . \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>c = c \<and> \<acute>s = s \<and> \<acute>enum = n \<and> \<acute>pred = p \<rbrace>
    \<acute>R :== PROC check_sp(\<acute>G, \<acute>dist, \<acute>c, \<acute>s, \<acute>enum, \<acute>pred)
    \<lbrace> \<acute>R = shortest_path_non_neg_cost_pred (abs_IGraph G) d c s n p\<rbrace>"
    by vcg (auto simp add: shortest_path_non_neg_cost_eq_invariants)

lemma shortest_path_non_neg_cost_imp_correct:
"\<And>G d c s n p .
  shortest_path_non_neg_cost_pred (abs_IGraph G) d c s n p \<longrightarrow>
   (\<forall>v \<in> verts (abs_IGraph G).
   d v = wf_digraph.\<mu> (abs_IGraph G) c s v)"
using shortest_path_non_neg_cost_pred.correct_shortest_path_pred by fast

theorem (in check_sp_impl) check_sp_spec:
  "\<forall> G d c s n p . \<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>dist = d \<and> \<acute>c = c \<and> \<acute>s = s \<and> \<acute>enum = n \<and> \<acute>pred = p \<rbrace>
    \<acute>R :== PROC check_sp(\<acute>G, \<acute>dist, \<acute>c, \<acute>s, \<acute>enum, \<acute>pred)
    \<lbrace> \<acute>R \<longrightarrow>  (\<forall>v \<in> verts (abs_IGraph G). d v = wf_digraph.\<mu> (abs_IGraph G) c s v)\<rbrace>"
using shortest_path_non_neg_cost_eq_invariants
      shortest_path_non_neg_cost_imp_correct
by vcg blast

end