(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_regexp_RecSeq
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun split :: "'a => ((('a list), ('a list)) pair) list =>
              ((('a list), ('a list)) pair) list" where
"split x (nil2) = nil2"
| "split x (cons2 (pair2 xs ys) x2) =
     cons2 (pair2 (cons2 x xs) ys) (split x x2)"

fun split2 :: "'a list => ((('a list), ('a list)) pair) list" where
"split2 (nil2) = cons2 (pair2 (nil2) (nil2)) (nil2)"
| "split2 (cons2 y s) =
     cons2 (pair2 (nil2) (cons2 y s)) (split y (split2 s))"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun or2 :: "bool list => bool" where
"or2 (nil2) = False"
| "or2 (cons2 y xs) = (y | (or2 xs))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

fun formula :: "R => R => (((A list), (A list)) pair) list =>
              bool list" where
"formula p q (nil2) = nil2"
| "formula p q (cons2 (pair2 s1 s2) z) =
     cons2 ((recognise p s1) & (recognise q s2)) (formula p q z)"

theorem property0 :
  "((recognise (Seq p q) s) = (or2 (formula p q (split2 s))))"
  oops

end


(*
 * Copyright 2014, NICTA
 *
 * 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.
 *
 * @TAG(NICTA_BSD)
 *)

(*
Termination for recursive functions.
*)
theory Factorial
imports
  "../../AutoCorres"
  "../../../lib/OptionMonadWP"
begin

(* Parse the input file. *)
install_C_file "factorial.c"

autocorres "factorial.c"

context factorial begin

(* Termination *)
thm factorial'.simps
thm l1_call_factorial_def

lemma ovalidNF_grab_asm2:
  "ovalidNF (\<lambda>s. G \<and> P s) f Q \<Longrightarrow> G \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def)

lemma ovalidNF_grab_asm_eq:
  "(G \<longrightarrow> ovalidNF P f Q) = ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (auto simp: ovalidNF_def)

lemma ovalid_post_triv:
  "(\<And>r s. Q r s) \<Longrightarrow> ovalid P f Q"
  by (simp add: ovalid_def)

lemma factorial'_terminates: "no_ofail (\<lambda>_. m > unat n) (factorial' m n)"
proof (induct n arbitrary: m rule: less_induct)
   fix x m
   assume induct_asm0: "(\<And>y m. y < x \<Longrightarrow> no_ofail (\<lambda>_. unat y < m) (factorial' m y))"
   have induct_asm: "(\<And>y m. no_ofail (\<lambda>_. y < x \<and> unat y < m) (factorial' m y))"
     apply (rule no_ofail_grab_asm)
     by (rule induct_asm0)

   show "no_ofail (\<lambda>_. unat x < m) (factorial' m x)"
     apply (subst factorial'.simps)
     apply (wp induct_asm ovalid_post_triv)
     apply unat_arith
    done
qed

lemma factorial'_terminates_old: "m > unat n \<longrightarrow> factorial' m n s \<noteq> None"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, simp add: ocondition_def obind_def split: option.splits)
  apply (metis One_nat_def Suc_eq_plus1 less_diff_conv option.distinct(1) unatSuc)
  done

(* A fun fact *)
function fact :: "('n :: len) word \<Rightarrow> ('n :: len) word" where
  "fact n = (if n = 0 then 1 else n * fact (n - 1))"
  by auto
termination by (metis "termination" in_measure measure_unat wf_measure)
declare fact.simps [simp del]

(* Termination & correctness *)
lemma factorial'_correct: "ovalidNF (\<lambda>_. m > unat n) (factorial' m n) (\<lambda>r _. r = fact n)"
proof (induct n arbitrary: m)
   fix n m
   show "ovalidNF (\<lambda>_. unat 0 < m) (factorial' m 0) (\<lambda>r _. r = fact 0)"
     apply (subst factorial'.simps)
     apply (simp add: ovalidNF_def ocondition_def ofail_def oreturn_def obind_def fact.simps)
     done

   assume induct_asm0: "\<And>m. ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. r = fact n)"
   have induct_asm: "\<And>m. 1 + n \<noteq> 0 \<Longrightarrow> ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. (1 + n) * r = fact (1 + n))"
     apply (subst fact.simps)
     apply simp
     apply (insert induct_asm0)
     apply (unfold ovalidNF_def)
     apply simp
     done

   show "\<lbrakk> 1 + n \<noteq> 0 \<rbrakk>
          \<Longrightarrow> ovalidNF (\<lambda>_. unat (1 + n) < m) (factorial' m (1 + n))
              (\<lambda>r _. r = fact (1 + n))"
     apply (subst factorial'.simps)
     apply (rule_tac G = "1 + n \<noteq> 0" in ovalidNF_grab_asm2)
      apply wp
       apply (simp del: One_nat_def)
       apply (wp induct_asm)
       apply assumption
      apply unat_arith
     apply assumption
    done
qed

lemma factorial'_correct_old: "m > unat n \<longrightarrow> factorial' m n s = Some (fact n)"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (clarsimp split: option.splits)
  apply (intro conjI impI)
    apply unat_arith
   apply (metis (hide_lams, no_types) Nat.add_0_right Nat.le_iff_add Suc_eq_plus1_left Suc_pred factorial.factorial'_terminates_old less_nat_zero_code nat_add_left_cancel_less nat_less_le unatSuc)
  apply (unat_arith, force)
  done

(* Termination & correctness of call_factorial *)
thm call_factorial'_def

lemma "\<lbrace> \<top> \<rbrace> call_factorial' \<lbrace> \<lambda>r s. r = fact 42 \<rbrace>!"
  unfolding call_factorial'_def
  apply wp
   using factorial'_correct_old
   apply force
  apply (force simp: option_monad_mono_eq (* factorial'_mono *))
  done

end

end


(* Title: Designs_And_Graphs.thy
   Author: Chelsea Edmonds
*)

section \<open> Graphs and Designs \<close>
text \<open>There are many links between graphs and design - most fundamentally that graphs are designs\<close>

theory Designs_And_Graphs imports Block_Designs Graph_Theory.Digraph Graph_Theory.Digraph_Component
begin

subsection \<open>Non-empty digraphs\<close>
text \<open>First, we define the concept of a non-empty digraph. This mirrors the idea of a "proper design"
in the design theory library \<close>
locale non_empty_digraph = wf_digraph +
  assumes arcs_not_empty: "arcs G \<noteq> {}"

begin

lemma verts_not_empty: "verts G \<noteq> {}"
  using wf arcs_not_empty head_in_verts by fastforce

end

subsection \<open>Arcs to Blocks \<close>
text \<open>A digraph uses a pair of points to define an ordered edge. In the case of simple graphs,
both possible orderings will be in the arcs set. Blocks are inherently unordered, and as such
a method is required to convert between the two representations \<close>
context graph
begin

definition arc_to_block :: "'b \<Rightarrow> 'a set" where
  "arc_to_block e \<equiv> {tail G e, head G e}"

lemma arc_to_block_to_ends: "{fst (arc_to_ends G e), snd (arc_to_ends G e)} = arc_to_block e"
  by (simp add: arc_to_ends_def arc_to_block_def)

lemma arc_to_block_to_ends_swap: "{snd (arc_to_ends G e), fst (arc_to_ends G e)} = arc_to_block e"
  using arc_to_block_to_ends
  by (simp add: arc_to_block_to_ends insert_commute)

lemma arc_to_ends_to_block: "arc_to_block e = {x, y} \<Longrightarrow>
  arc_to_ends G e = (x, y) \<or> arc_to_ends G e = (y, x)"
  by (metis arc_to_block_def arc_to_ends_def doubleton_eq_iff)

lemma arc_to_block_sym: "arc_to_ends G e1 = (u, v) \<Longrightarrow> arc_to_ends G e2 = (v, u) \<Longrightarrow>
  arc_to_block e1 = arc_to_block e2"
  by (simp add: arc_to_block_def arc_to_ends_def insert_commute)

definition arcs_blocks :: "'a set multiset" where
"arcs_blocks \<equiv> mset_set (arc_to_block ` (arcs G))"

lemma  arcs_blocks_ends: "(x, y) \<in> arcs_ends G \<Longrightarrow> {x, y} \<in># arcs_blocks"
proof (auto simp add: arcs_ends_def arcs_blocks_def )
  fix xa
  assume assm1: "(x, y) = arc_to_ends G xa" and assm2: "xa \<in> arcs G"
  obtain z where zin: "z \<in> (arc_to_block ` (arcs G))" and "z = arc_to_block xa"
    using assm2 by blast
  thus "{x, y} \<in> arc_to_block ` (arcs G)" using assm1 arc_to_block_to_ends
    by (metis fst_conv snd_conv)
qed

lemma arc_ends_blocks_subset: "E \<subseteq> arcs G \<Longrightarrow> (x, y) \<in> ((arc_to_ends G) ` E) \<Longrightarrow>
  {x, y} \<in> (arc_to_block ` E)"
  by (auto simp add: arc_to_ends_def arc_to_block_def )

lemma arc_blocks_end_subset: assumes "E \<subseteq> arcs G"  and "{x, y} \<in> (arc_to_block ` E)"
  shows "(x, y) \<in> ((arc_to_ends G) ` E) \<or> (y, x) \<in> ((arc_to_ends G) ` E)"
proof -
  obtain e where "e \<in> E" and "arc_to_block e = {x,y}" using assms
    by fastforce
  then have "arc_to_ends G e = (x, y) \<or> arc_to_ends G e = (y, x)"
    using arc_to_ends_to_block by simp
  thus ?thesis
    by (metis \<open>e \<in> E\<close> image_iff)
qed

lemma arcs_ends_blocks: "{x, y} \<in># arcs_blocks \<Longrightarrow> (x, y) \<in> arcs_ends G \<and> (y, x) \<in> arcs_ends G"
proof (auto simp add: arcs_ends_def arcs_blocks_def )
  fix xa
  assume assm1: "{x, y} = arc_to_block  xa" and assm2: "xa \<in> (arcs G)"
  obtain z where zin: "z \<in> (arc_to_ends G ` (arcs G))" and "z = arc_to_ends G xa"
    using assm2 by blast
  then have "z = (x, y) \<or> z = (y, x)" using arc_to_block_to_ends assm1
    by (metis arc_to_ends_def doubleton_eq_iff fst_conv snd_conv) (* Slow *)
  thus "(x, y) \<in> arc_to_ends G ` (arcs G)" using assm2
    by (metis arcs_ends_def arcs_ends_symmetric sym_arcs zin)
next
  fix xa
  assume assm1: "{x, y} = arc_to_block  xa" and assm2: "xa \<in> (arcs G)"
  thus "(y, x) \<in> arc_to_ends G ` arcs G" using arcs_ends_def
    by (metis (mono_tags, hide_lams) arc_blocks_end_subset graph_symmetric image_iff subset_refl)
qed

lemma arcs_blocks_iff: "{x, y} \<in># arcs_blocks \<longleftrightarrow> (x, y) \<in> arcs_ends G \<and> (y, x) \<in> arcs_ends G"
  using arcs_ends_blocks arcs_blocks_ends by blast

lemma arcs_ends_wf: "(x, y) \<in> arcs_ends G \<Longrightarrow> x \<in> verts G \<and> y \<in> verts G"
  by auto

lemma arcs_blocks_elem: "bl \<in># arcs_blocks \<Longrightarrow> \<exists> x y . bl = {x, y}"
  apply (auto simp add: arcs_blocks_def)
  by (meson arc_to_block_def)

lemma arcs_ends_blocks_wf:
  assumes "bl \<in># arcs_blocks"
  shows "bl \<subseteq> verts G"
proof -
  obtain x y where blpair: "bl = {x, y}" using arcs_blocks_elem assms
    by fastforce
  then have "(x, y) \<in> arcs_ends G" using arcs_ends_blocks assms by simp
  thus ?thesis using arcs_ends_wf blpair by auto
qed

lemma arcs_blocks_simple: "bl \<in># arcs_blocks \<Longrightarrow> count (arcs_blocks) bl = 1"
  by (simp add: arcs_blocks_def)

lemma arcs_blocks_ne: "arcs G \<noteq> {} \<Longrightarrow> arcs_blocks \<noteq> {#}"
  by (simp add: arcs_blocks_iff arcs_blocks_def mset_set_empty_iff)

end

subsection \<open>Graphs are designs \<close>

text \<open> Prove that a graph is a number of different types of designs \<close>
sublocale graph \<subseteq> design "verts G" "arcs_blocks"
  using arcs_ends_blocks_wf arcs_blocks_elem by (unfold_locales) (auto)

sublocale graph \<subseteq> simple_design "verts G" "arcs_blocks"
  using arcs_ends_blocks_wf arcs_blocks_elem arcs_blocks_simple by (unfold_locales) (auto)

locale non_empty_graph = graph + non_empty_digraph

sublocale non_empty_graph \<subseteq> proper_design "verts G" "arcs_blocks"
  using arcs_blocks_ne arcs_not_empty by (unfold_locales) simp

lemma (in graph) graph_block_size: assumes "bl \<in># arcs_blocks" shows "card bl = 2"
proof -
  obtain x y where blrep: "bl = {x, y}" using assms arcs_blocks_elem
    by fastforce
  then have "(x, y) \<in> arcs_ends G" using arcs_ends_blocks assms by simp
  then have "x \<noteq> y" using no_loops using adj_not_same by blast
  thus ?thesis using blrep by simp
qed

sublocale non_empty_graph \<subseteq> block_design "verts G" "arcs_blocks" 2
  using arcs_not_empty graph_block_size arcs_blocks_ne by (unfold_locales) simp_all

subsection \<open>R-regular graphs \<close>
text \<open>To reason on r-regular graphs and their link to designs, we require a number of extensions to
lemmas reasoning around the degrees of vertices \<close>
context sym_digraph
begin

lemma in_out_arcs_reflexive: "v \<in> verts G \<Longrightarrow> (e \<in> (in_arcs G v) \<Longrightarrow>
    \<exists> e' . (e' \<in> (out_arcs G v) \<and> head G e' = tail G e))"
  using symmetric_conv sym_arcs by fastforce

lemma out_in_arcs_reflexive: "v \<in> verts G \<Longrightarrow> (e \<in> (out_arcs G v) \<Longrightarrow>
    \<exists> e' . (e' \<in> (in_arcs G v) \<and> tail G e' = head G e))"
  using symmetric_conv sym_arcs by fastforce

end

context nomulti_digraph
begin

lemma in_arcs_single_per_vert:
  assumes "v \<in> verts G" and "u \<in> verts G"
  assumes "e1 \<in> in_arcs G v" and " e2 \<in> in_arcs G v"
  assumes "tail G e1 = u" and "tail G e2 = u"
  shows "e1 = e2"
proof -
  have in_arcs1: "e1 \<in> arcs G" and in_arcs2: "e2 \<in> arcs G" using assms by auto
  have "arc_to_ends G e1 = arc_to_ends G e2" using assms arc_to_ends_def
    by (metis in_in_arcs_conv)
  thus ?thesis using in_arcs1 in_arcs2 no_multi_arcs by simp
qed

lemma out_arcs_single_per_vert:
  assumes "v \<in> verts G" and "u \<in> verts G"
  assumes "e1 \<in> out_arcs G v" and " e2 \<in> out_arcs G v"
  assumes "head G e1 = u" and "head G e2 = u"
  shows "e1 = e2"
proof -
  have in_arcs1: "e1 \<in> arcs G" and in_arcs2: "e2 \<in> arcs G" using assms by auto
  have "arc_to_ends G e1 = arc_to_ends G e2" using assms arc_to_ends_def
    by (metis in_out_arcs_conv)
  thus ?thesis using in_arcs1 in_arcs2 no_multi_arcs by simp
qed

end

text \<open> Some helpers on the transformation arc definition \<close>
context graph
begin

lemma arc_to_block_is_inj_in_arcs: "inj_on arc_to_block (in_arcs G v)"
  apply (auto simp add: arc_to_block_def inj_on_def)
  by (metis arc_to_ends_def doubleton_eq_iff no_multi_arcs)

lemma arc_to_block_is_inj_out_arcs: "inj_on arc_to_block (out_arcs G v)"
  apply (auto simp add: arc_to_block_def inj_on_def)
  by (metis arc_to_ends_def doubleton_eq_iff no_multi_arcs)

lemma in_out_arcs_reflexive_uniq: "v \<in> verts G \<Longrightarrow> (e \<in> (in_arcs G v) \<Longrightarrow>
    \<exists>! e' . (e' \<in> (out_arcs G v) \<and> head G e' = tail G e))"
  apply auto
    using symmetric_conv apply fastforce
  using out_arcs_single_per_vert by (metis head_in_verts in_out_arcs_conv)

lemma out_in_arcs_reflexive_uniq: "v \<in> verts G \<Longrightarrow> e \<in> (out_arcs G v) \<Longrightarrow>
    \<exists>! e' . (e' \<in> (in_arcs G v) \<and> tail G e' = head G e)"
  apply auto
    using symmetric_conv apply fastforce
  using in_arcs_single_per_vert by (metis tail_in_verts in_in_arcs_conv)

lemma in_eq_out_arc_ends: "(u, v) \<in> ((arc_to_ends G) ` (in_arcs G v)) \<longleftrightarrow>
    (v, u) \<in> ((arc_to_ends G) ` (out_arcs G v))"
  using arc_to_ends_def in_in_arcs_conv in_out_arcs_conv
  by (smt (z3) Pair_inject adj_in_verts(1) dominatesI image_iff out_in_arcs_reflexive_uniq)

lemma in_degree_eq_card_arc_ends: "in_degree G v = card ((arc_to_ends G) ` (in_arcs G v))"
  apply (simp add: in_degree_def)
  using  no_multi_arcs by (metis card_image in_arcs_in_arcs inj_onI)

lemma in_degree_eq_card_arc_blocks: "in_degree G v = card (arc_to_block ` (in_arcs G v))"
  apply (simp add: in_degree_def)
  using no_multi_arcs arc_to_block_is_inj_in_arcs by (simp add: card_image)

lemma out_degree_eq_card_arc_blocks: "out_degree G v = card (arc_to_block ` (out_arcs G v))"
  apply (simp add: out_degree_def)
  using no_multi_arcs arc_to_block_is_inj_out_arcs by (simp add: card_image)

lemma out_degree_eq_card_arc_ends: "out_degree G v = card ((arc_to_ends G) ` (out_arcs G v))"
  apply (simp add: out_degree_def)
  using no_multi_arcs by (metis card_image out_arcs_in_arcs inj_onI)

lemma bij_betw_in_out_arcs: "bij_betw (\<lambda> (u, v) . (v, u)) ((arc_to_ends G) ` (in_arcs G v))
    ((arc_to_ends G) ` (out_arcs G v))"
  apply (auto simp add: bij_betw_def)
    apply (simp add: swap_inj_on)
   apply (metis Pair_inject arc_to_ends_def image_eqI in_eq_out_arc_ends in_in_arcs_conv)
  by (metis arc_to_ends_def imageI in_eq_out_arc_ends in_out_arcs_conv pair_imageI)

lemma in_eq_out_degree: "in_degree G v = out_degree G v"
  using bij_betw_in_out_arcs bij_betw_same_card in_degree_eq_card_arc_ends
    out_degree_eq_card_arc_ends by auto

lemma in_out_arcs_blocks: "arc_to_block ` (in_arcs G v) = arc_to_block ` (out_arcs G v)"
proof (auto)
  fix xa
  assume a1: "xa \<in> arcs G" and a2: "v = head G xa"
  then have "xa \<in> in_arcs G v" by simp
  then obtain e where out: "e \<in> out_arcs G v" and "head G e = tail G xa"
    using out_in_arcs_reflexive_uniq by force
  then have "arc_to_ends G e = (v, tail G xa)"
    by (simp add: arc_to_ends_def)
  then have "arc_to_block xa = arc_to_block e"
    using arc_to_block_sym by (metis a2 arc_to_ends_def)
  then show "arc_to_block xa \<in> arc_to_block ` out_arcs G (head G xa)"
    using out a2 by blast
next
  fix xa
  assume a1: "xa \<in> arcs G" and a2: "v = tail G xa"
  then have "xa \<in> out_arcs G v" by simp
  then obtain e where ina: "e \<in> in_arcs G v" and "tail G e = head G xa"
    using out_in_arcs_reflexive_uniq by force
  then have "arc_to_ends G e = (head G xa, v)"
    by (simp add: arc_to_ends_def)
  then have "arc_to_block xa = arc_to_block e"
    using arc_to_block_sym by (metis a2 arc_to_ends_def)
  then show "arc_to_block xa \<in> arc_to_block ` in_arcs G (tail G xa)"
    using ina a2 by blast
qed

end

text \<open> A regular digraph is defined as one where the in degree equals the out degree which in turn
equals some fixed integer $\mathrm{r}$\<close>
locale regular_digraph = wf_digraph +
  fixes \<r> :: nat
  assumes in_deg_r: "v \<in> verts G \<Longrightarrow> in_degree G v = \<r>"
  assumes out_deg_r: "v \<in> verts G \<Longrightarrow> out_degree G v = \<r>"

locale regular_graph = graph + regular_digraph
begin

lemma rep_vertices_in_blocks [simp]:
  assumes "x \<in> verts G"
  shows "size {# e \<in># arcs_blocks . x \<in> e #} = \<r>"
proof -
  have "\<And> e . e \<in> (arc_to_block ` (arcs G)) \<Longrightarrow> x \<in> e \<Longrightarrow> e \<in> (arc_to_block ` in_arcs G x)"
    using arc_to_block_def in_in_arcs_conv insert_commute insert_iff singleton_iff sym_arcs
      symmetric_conv by fastforce
  then have "{ e \<in> (arc_to_block ` (arcs G)) . x \<in> e} =  (arc_to_block ` (in_arcs G x))"
    using arc_to_block_def by auto
  then have "card { e \<in> (arc_to_block ` (arcs G)) . x \<in> e} = \<r>"
    using in_deg_r in_degree_eq_card_arc_blocks assms by auto
  thus ?thesis
    using arcs_blocks_def finite_arcs by force
qed

end

text \<open>Intro rules for regular graphs \<close>
lemma graph_in_degree_r_imp_reg[intro]: assumes "graph G"
  assumes "(\<And> v . v \<in> (verts G) \<Longrightarrow> in_degree G v = \<r>)"
  shows "regular_graph G \<r>"
proof -
  interpret g: graph G using assms by simp
  interpret wf: wf_digraph G by (simp add: g.wf_digraph_axioms)
  show ?thesis
    using assms(2) g.in_eq_out_degree by (unfold_locales) simp_all
qed

lemma graph_out_degree_r_imp_reg[intro]: assumes "graph G"
  assumes "(\<And> v . v \<in> (verts G) \<Longrightarrow> out_degree G v = \<r>)"
  shows "regular_graph G \<r>"
proof -
  interpret g: graph G using assms by simp
  interpret wf: wf_digraph G by (simp add: g.wf_digraph_axioms)
  show ?thesis
    using assms(2) g.in_eq_out_degree by (unfold_locales) simp_all
qed

text \<open>Regular graphs (non-empty) can be shown to be a constant rep design\<close>
locale non_empty_regular_graph = regular_graph + non_empty_digraph

sublocale non_empty_regular_graph \<subseteq> non_empty_graph
  by unfold_locales

sublocale non_empty_regular_graph \<subseteq> constant_rep_design "verts G" "arcs_blocks" \<r>
  using arcs_blocks_ne arcs_not_empty
  by (unfold_locales)(simp_all add: point_replication_number_def)

end


(*  Title:       Inductive definition of termination
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory Termi imports Lang begin

subsection{*Termination*}

text{*Although partial correctness appeals because of its simplicity,
in many cases one would like the additional assurance that the command
is guaranteed to termiate if started in a state that satisfies the
precondition. Even to express this we need to define when a command is
guaranteed to terminate. We can do this without modifying our existing
semantics by merely adding a second inductively defined judgement
@{text"c\<down>s"} that expresses guaranteed termination of @{term c}
started in state @{term s}: *}

inductive
  termi :: "com \<Rightarrow> state \<Rightarrow> bool" (infixl "\<down>" 50)
where
  (*<*)Do[iff]:(*>*) "f s \<noteq> {} \<Longrightarrow> Do f \<down> s"

| (*<*)Semi[intro!]:(*>*) "\<lbrakk> c\<^sub>1 \<down> s\<^sub>0; \<forall>s\<^sub>1. s\<^sub>0 -c\<^sub>1\<rightarrow> s\<^sub>1 \<longrightarrow> c\<^sub>2 \<down> s\<^sub>1 \<rbrakk> \<Longrightarrow> (c\<^sub>1;c\<^sub>2) \<down> s\<^sub>0"

| (*<*)IfT[intro,simp]:(*>*) "\<lbrakk>  b s; c\<^sub>1 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c\<^sub>1 ELSE c\<^sub>2 \<down> s"
| (*<*)IfF[intro,simp]:(*>*) "\<lbrakk> \<not>b s; c\<^sub>2 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c\<^sub>1 ELSE c\<^sub>2 \<down> s"

| (*<*)WhileFalse:(*>*) "\<not>b s \<Longrightarrow> WHILE b DO c \<down> s"
| (*<*)WhileTrue:(*>*) "\<lbrakk> b s; c \<down> s; \<forall>t. s -c\<rightarrow> t \<longrightarrow> WHILE b DO c \<down> t \<rbrakk> \<Longrightarrow> WHILE b DO c \<down> s"

| (*<*)Local:(*>*) "c \<down> f s \<Longrightarrow> LOCAL f;c;g \<down> s"

lemma [iff]: "((c\<^sub>1;c\<^sub>2) \<down> s\<^sub>0) = (c\<^sub>1 \<down> s\<^sub>0 \<and> (\<forall>s\<^sub>1. s\<^sub>0 -c\<^sub>1\<rightarrow> s\<^sub>1 \<longrightarrow> c\<^sub>2 \<down> s\<^sub>1))"
apply(rule iffI)
 prefer 2
 apply(best intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(IF b THEN c\<^sub>1 ELSE c\<^sub>2 \<down> s) =
              ((if b s then c\<^sub>1 else c\<^sub>2) \<down> s)"
apply simp
apply(rule conjI)
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(LOCAL f;c;g \<down> s) = (c \<down> f s)"
by(fast elim: termi.cases intro:termi.intros)

lemma termi_while_lemma[rule_format]:
 "w\<down>fk \<Longrightarrow>
 (\<forall>k b c. fk = f k \<and> w = WHILE b DO c \<and> (\<forall>i. f i -c\<rightarrow> f(Suc i))
          \<longrightarrow> (\<exists>i. \<not>b(f i)))"
apply(erule termi.induct)
apply simp_all
apply blast
apply blast
done

lemma termi_while:
 "\<lbrakk> (WHILE b DO c) \<down> f k;  \<forall>i. f i -c\<rightarrow> f(Suc i) \<rbrakk> \<Longrightarrow> \<exists>i. \<not>b(f i)"
by(blast intro:termi_while_lemma)

lemma wf_termi: "wf {(t,s). WHILE b DO c \<down> s \<and> b s \<and> s -c\<rightarrow> t}"
apply(subst wf_iff_no_infinite_down_chain)
apply(rule notI)
apply clarsimp
apply(insert termi_while)
apply blast
done

end


theory RelationalIncorrectness
  imports "HOL-IMP.Big_Step"
begin

(* Author: Toby Murray *)

section "Under-Approximate Relational Judgement"

text \<open>
  This is the relational analogue of OHearn's~\cite{OHearn_19} and de Vries \& Koutavas'~\cite{deVries_Koutavas_11}
  judgements.

  Note that in our case it doesn't really make sense to talk about ``erroneous'' states: the
  presence of an error can be seen only by the violation of a relation. Unlike O'Hearn, we cannot
  encode it directly into the semantics of our programs, without giving them a relational semantics.
  We use the standard big step semantics of IMP unchanged.
\<close>

type_synonym rassn = "state \<Rightarrow> state \<Rightarrow> bool"

definition
  ir_valid :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  "ir_valid P c c' Q \<equiv> (\<forall> t t'. Q t t' \<longrightarrow> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"

section "Rules of the Logic"

definition
  flip :: "rassn \<Rightarrow> rassn"
  where
  "flip P \<equiv> \<lambda>s s'. P s' s"

inductive
  ir_hoare :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  ir_Skip: "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c',s') \<Rightarrow> t') \<Longrightarrow>
            ir_hoare P SKIP c' Q" |
  ir_If_True:   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) c\<^sub>1 c' Q \<Longrightarrow>
                 ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_If_False:   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) c\<^sub>2 c' Q \<Longrightarrow>
                  ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_Seq1: "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d SKIP R \<Longrightarrow> ir_hoare P (Seq c d) c' R" |
  ir_Assign: "ir_hoare (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow>
              ir_hoare P (Assign x e) c' Q" |
  ir_While_False: "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_True: "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) (c;; WHILE b DO c) c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_backwards_frontier: "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                                ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
                                ir_hoare (P 0) (WHILE b DO c) c' Q" |
  ir_conseq:      "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                   ir_hoare P' c c' Q'" |
  ir_disj:        "ir_hoare P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_hoare P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                   ir_hoare (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')" |
  ir_sym: "ir_hoare (flip P) c c' (flip Q) \<Longrightarrow> ir_hoare P c' c Q"

section "Simple Derived Rules"

lemma meh_simp[simp]: "(SKIP, s') \<Rightarrow> t' = (s' = t')"
  by auto

lemma ir_pre: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s')  \<Longrightarrow>
                  ir_hoare P' c c' Q"
  by(erule ir_conseq, blast+)

lemma ir_post: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s')  \<Longrightarrow>
                  ir_hoare P c c' Q'"
  by(erule ir_conseq, blast+)

section "Soundness"

lemma Skip_ir_valid[intro]:
  "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c', s') \<Rightarrow> t') \<Longrightarrow> ir_valid P SKIP c' Q"
  by(auto simp: ir_valid_def)

lemma sym_ir_valid[intro]:
  "ir_valid (flip P) c' c (flip Q) \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def flip_def)

lemma If_True_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> bval b a) c\<^sub>1 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma If_False_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> \<not> bval b a) c\<^sub>2 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma Seq1_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d SKIP R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq2_ir_valid[intro]:
  "ir_valid P c SKIP Q \<Longrightarrow> ir_valid Q d c' R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d d' R \<Longrightarrow> ir_valid P (c;; d) (c';; d') R"
  by(fastforce simp: ir_valid_def)

lemma Assign_blah[intro]:
  "t x = aval e (t(x := v))
       \<Longrightarrow> (x ::= e, t(x := v)) \<Rightarrow> t"
  using Assign
  by (metis fun_upd_triv fun_upd_upd)

lemma Assign_ir_valid[intro]:
  "ir_valid (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow> ir_valid P (Assign x e) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_False_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_True_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> bval b s) (Seq c (WHILE b DO c)) c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(clarsimp simp: ir_valid_def, blast)

lemma While_backwards_frontier_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s. P (k + n) s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t)"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q r' \<and> bval b q \<and>  (c, q) \<Rightarrow> r"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) c' Q"
  by(auto simp: meh_simp ir_valid_def intro: While_backwards_frontier_ir_valid')

lemma conseq_ir_valid:
  "ir_valid P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                  ir_valid P' c c' Q'"
  by(clarsimp simp: ir_valid_def, blast)

lemma disj_ir_valid[intro]:
  "ir_valid P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_valid P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                  ir_valid (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  by(fastforce simp: ir_valid_def)

theorem soundness:
  "ir_hoare P c c' Q \<Longrightarrow> ir_valid P c c' Q"
  apply(induction rule: ir_hoare.induct)
              apply(blast intro!: Skip_ir_valid)
  by (blast intro: conseq_ir_valid)+

section "Completeness"

lemma ir_Skip_Skip[intro]:
  "ir_hoare P SKIP SKIP P"
  by(rule ir_Skip, simp)

lemma ir_hoare_Skip_Skip[simp]:
  "ir_hoare P SKIP SKIP Q = (\<forall>s s'. Q s s' \<longrightarrow> P s s')"
  using soundness ir_valid_def meh_simp ir_conseq ir_Skip by metis

lemma ir_valid_Seq1:
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_Seq1':
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t')) c2 SKIP Q"
  by(clarsimp simp: ir_valid_def, meson SeqE)

lemma ir_valid_track_history:
  "ir_valid P c c' Q \<Longrightarrow>
   ir_valid P c c' (\<lambda>t t'. Q s s' \<and> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_If:
  "ir_valid (\<lambda>s s'. P s s') (IF b THEN c1 ELSE c2) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> bval b s) c1 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> bval b s)) \<and>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) c2 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> \<not> bval b s))"
  by(clarsimp simp: ir_valid_def, blast)

text \<open>
  Inspired by the
  ``@{text "p(n) = {\<sigma> | you can get back from \<sigma> to some state in p by executing C backwards n times}"}''
  part of OHearn~\cite{OHearn_19}.
\<close>
primrec get_back where
  "get_back P b c 0 = (\<lambda>t t'. P t t')" |
  "get_back P b c (Suc n) = (\<lambda>t t'. \<exists>s. (c,s) \<Rightarrow> t \<and> bval b s \<and> get_back P b c n s t')"

(* Currently not used anywhere *)
lemma ir_valid_get_back:
  "ir_valid (get_back P b c (Suc k)) (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
proof(induct k)
  case 0
  then show ?case by(clarsimp simp: ir_valid_def, blast)
next
  case (Suc k)
  then show ?case  using  WhileTrue get_back.simps(2) ir_valid_def by smt
qed

(* both this an the next one get used in the completeness proof *)
lemma ir_valid_While1:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c SKIP (\<lambda>t t'. get_back P b c (Suc k) t t' \<and> (\<exists>u u'. (WHILE b DO c,t) \<Rightarrow> u \<and> (c',t') \<Rightarrow> u' \<and> Q u u')))"
proof (subst ir_valid_def, clarsimp)
  fix t t' s u u'
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', t') \<Rightarrow> u'"
         "Q u u'"
         "bval b s"
         "get_back P b c k s t'"
  thus "\<exists>s. get_back P b c k s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t"
  proof(induction k arbitrary: t t' s u u')
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

lemma ir_valid_While3:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c c' (\<lambda>t t'. (\<exists>s'. (c',s') \<Rightarrow> t' \<and> get_back P b c (Suc k) t s' \<and> (\<exists>u. (WHILE b DO c,t) \<Rightarrow> u \<and>  Q u t'))))"
  apply(subst ir_valid_def, clarsimp)
proof -
  fix t t' s' s u
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', s') \<Rightarrow> t'"
         "Q u t'"
         "bval b s"
         "get_back P b c k s s'"
  thus "\<exists>s s'. get_back P b c k s s' \<and> bval b s \<and> (c, s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
  proof(induction k arbitrary: t t' s' s u)
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(4) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

(* not used anywhere *)
lemma ir_valid_While2:
   "ir_valid P (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' (\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c',s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval b t))"
  by(clarsimp simp: ir_valid_def, blast)

lemma assign_upd_blah:
  "(\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) = s"
  by(rule ext, auto)

lemma Assign_complete:
  assumes v: "ir_valid P (x1 ::= x2) c' Q"
  assumes q: "Q t t'"
  shows  "\<exists>s'. (\<exists>v. P (t(x1 := v)) s' \<and> t x1 = aval x2 (t(x1 := v))) \<and> (c', s') \<Rightarrow> t'"
proof -
  from v and q obtain s s' where a: "P s s' \<and> (x1 ::= x2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
    using ir_valid_def by smt
  hence "P (\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) s' \<and> aval x2 s = aval x2 (s(x1 := s x1))"
    using assign_upd_blah
    by simp
  thus ?thesis
    using assign_upd_blah a
    by (metis AssignE fun_upd_same fun_upd_triv fun_upd_upd)
qed

lemmas ir_Skip_sym = ir_sym[OF ir_Skip, simplified flip_def]

theorem completeness:
  "ir_valid P c c' Q \<Longrightarrow> ir_hoare P c c' Q"
proof(induct c arbitrary: P c' Q)
case SKIP
  show ?case
    apply(rule ir_Skip)
    using SKIP by(fastforce simp: ir_valid_def)
next
  case (Assign x1 x2)
  show ?case
    apply(rule ir_Assign)
    apply(rule ir_Skip)
    using Assign_complete Assign by blast
next
  case (Seq c1 c2)
  have a: "ir_hoare P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> (\<exists>u. (c2, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_Seq1 Seq by blast
  show ?case
    apply(rule ir_Seq1)
     apply (blast intro: a)
    apply(rule ir_Skip_sym)
    by(metis SeqE ir_valid_def Seq)
next
  case (If x1 c1 c2)
  have t: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c1 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> bval x1 s))" and
       f: " ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval x1 s) c2 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> \<not> bval x1 s))"
    using ir_valid_If If by blast+
  show ?case
    (* consider both cases of the if via conseq, disj, then _True and _False *)
    apply(rule ir_conseq)
      apply(rule ir_disj)
       apply(rule ir_If_True,fastforce intro: t)
      apply(rule ir_If_False, fastforce intro: f)
     apply blast
    by (smt IfE ir_valid_def If)
next
  case (While x1 c)
  have a: "\<And>n. ir_hoare (\<lambda>s s'. get_back P x1 c n s s' \<and> bval x1 s) c SKIP (get_back P x1 c (Suc n))"
    using ir_valid_While1  While
    by (smt get_back.simps(2) ir_valid_def meh_simp)
  have b: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c c'
                    (\<lambda>t t'.  \<exists>s'. (c', s') \<Rightarrow> t' \<and> (\<exists>s. (c, s) \<Rightarrow> t \<and> bval x1 s \<and> P s s') \<and>
                    (\<exists>u. (WHILE x1 DO c, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_While3[where k=0,simplified] While by blast
  have gb: "\<And>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t) \<Longrightarrow>
                    \<exists>s'. ((\<exists>n. get_back P x1 c n t s') \<and> \<not> bval x1 t) \<and> (c', s') \<Rightarrow> t'"
    by (meson get_back.simps(1))

  show ?case
    (* use the frontier rule much as in OHearn POPL *)
    apply(rule ir_conseq)
      apply(rule_tac P="get_back P x1 c" in ir_While_backwards_frontier)
       apply(blast intro: a)
      (* consider both cases of the While via conseq, disj, then _True and _False *)
      apply(rule ir_conseq)
        apply(rule ir_disj)
         apply(rule_tac P="\<lambda>s s'. \<exists>n. get_back P x1 c n s s'" and Q="(\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t))" in ir_While_False)
         apply(rule ir_Skip, blast intro: gb)
        apply(rule ir_While_True)
        apply(rule ir_Seq1[OF b])
        apply(rule ir_Skip_sym)
        apply(fastforce)
       apply (metis get_back.simps(1))
      apply assumption
     apply simp
    by (metis While.prems WhileE ir_valid_def)
qed

section "A Decomposition Principle: Proofs via Under-Approximate Hoare Logic"

text \<open>
  We show the under-approximate analogue holds for Beringer's~\cite{Beringer_11} decomposition
  principle for over-approximate relational logic.
\<close>

definition
  decomp :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> rassn" where
  "decomp P c c' Q \<equiv> \<lambda>t s'. \<exists>s t'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> Q t t'"

lemma ir_valid_decomp1:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp2:
  "ir_valid P c SKIP R \<and> ir_valid R SKIP c' Q \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp:
  "ir_valid P c c' Q = (ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q)"
  using ir_valid_decomp1 ir_valid_decomp2 by blast

text \<open>
  Completeness with soundness means we can prove proof rules about @{term ir_hoare} in terms
  of @{term ir_valid}.
\<close>

lemma ir_to_Skip:
  "ir_hoare P c c' Q = (ir_hoare P c SKIP (decomp P c c' Q) \<and> ir_hoare (decomp P c c' Q) SKIP c' Q)"
  using soundness completeness ir_valid_decomp
  by meson

text \<open>
  O'Hearn's under-approximate Hoare triple, for the ``ok'' case (since that is the only case we have)
  This is also likely the same as from the "Reverse Hoare Logic" paper (SEFM).
\<close>
type_synonym assn = "state \<Rightarrow> bool"
definition
  ohearn :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  where
  "ohearn P c Q \<equiv> (\<forall>t. Q t \<longrightarrow> (\<exists>s. P s \<and> (c,s) \<Rightarrow> t))"

lemma fold_ohearn2:
  "ir_valid P SKIP c' Q = (\<forall>t. ohearn (P t) c' (Q t))"
  by(simp add: ir_valid_def ohearn_def)

theorem relational_via_hoare:
  "ir_hoare P c c' Q = ((\<forall>t'. ohearn (\<lambda>t. P t t') c (\<lambda>t. decomp P c c' Q t t')) \<and> (\<forall>t. ohearn (decomp P c c' Q t) c' (Q t)))"
proof -
  have a: "\<And>P c c' Q. ir_hoare P c c' Q = ir_valid P c c' Q"
    using soundness completeness by auto
  show ?thesis
    using ir_to_Skip a fold_ohearn1 fold_ohearn2 by metis
qed

section "Deriving Proof Rules from Completeness"

text \<open>
  Note that we can more easily derive proof rules sometimes by appealing to the
   corresponding properties of @{term ir_valid} than from the proof rules directly.

  We see more examples of this later on when we consider examples.
\<close>

lemma ir_Seq2:
  "ir_hoare P c SKIP Q \<Longrightarrow> ir_hoare Q d c' R \<Longrightarrow> ir_hoare P (Seq c d) c' R"
  using soundness completeness Seq2_ir_valid by metis

lemma ir_Seq:
  "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d d' R \<Longrightarrow> ir_hoare P (Seq c d) (Seq c' d') R"
  using soundness completeness Seq_ir_valid by metis

section "Examples"

subsection "Some Derived Proof Rules"

text \<open>
First derive some proof rules -- here not by appealing to completeness but just using
the existing rules
\<close>

lemma ir_If_True_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> \<not> bval b' s') c\<^sub>1 c\<^sub>2' Q \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') Q"
  apply(rule ir_If_True)
  apply(rule ir_sym)
  apply(rule ir_If_False)
  apply(rule ir_sym)
  by(simp add: flip_def)

lemma ir_Assign_Assign:
  "ir_hoare P (x ::= e) (x' ::= e') (\<lambda>t t'. \<exists>v v'. P (t(x := v)) (t'(x' := v')) \<and> t x = aval e (t(x := v)) \<and> t' x' = aval e' (t'(x' := v')))"
  apply(rule ir_Assign)
  apply(rule ir_sym)
  apply(rule ir_Assign)
  by(simp add: flip_def, auto)

subsection "prog1"

text \<open>
  A tiny insecure program. Note that we only need to reason on one path through this program to
  detect that it is insecure.
\<close>

abbreviation low_eq :: rassn where "low_eq s s' \<equiv> s ''low'' = s' ''low''"
abbreviation low_neq :: rassn where "low_neq s s' \<equiv> \<not> low_eq s s'"
definition prog1 :: com where
  "prog1 \<equiv> (IF (Less (N 0) (V ''x'')) THEN (Assign ''low'' (N 1)) ELSE (Assign ''low'' (N 0)))"

text \<open>
  We prove that @{term prog1} is definitely insecure. To do that, we need to find some non-empty
  post-relation that implies insecurity. The following property encodes the idea that the
  post-relation is non-empty, i.e. represents a feasible pair of execution paths.
\<close>
definition
  nontrivial :: "rassn \<Rightarrow> bool"
  where
  "nontrivial Q \<equiv> (\<exists>t t'. Q t t')"

text \<open>
  Note the property we prove here explicitly encodes the fact that the postcondition can be anything
  that implies insecurity, i.e. implies @{term low_neq}. In particular we should not necessarily
  expect it to cover the entirely of all states that satisfy @{term low_neq}.

  Also note that we also have to prove that the postcondition is non-trivial. This is necessary to
  make sure that the violation we find is not an infeasible path.
\<close>
lemma prog1:
  "\<exists>Q. ir_hoare low_eq prog1 prog1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI)
  apply(rule conjI)
   apply(simp add: prog1_def)
   apply(rule ir_If_True_False)
   apply(rule ir_Assign_Assign)
  apply(rule conjI)
   apply auto[1]
  apply(clarsimp simp: nontrivial_def)
  apply(rule_tac x="\<lambda>v. 1" in exI)
  apply simp
  apply(rule_tac x="\<lambda>v. 0" in exI)
  by auto

subsection "More Derived Proof Rules for Examples"

definition BEq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "BEq a b \<equiv> And (Less a (Plus b (N 1))) (Less b (Plus a (N 1)))"

lemma BEq_aval[simp]:
  "bval (BEq a b) s = ((aval a s) = (aval b s))"
  by(auto simp add: BEq_def)

lemma ir_If_True_True:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t')"
  by(simp add: ir_If_True ir_sym flip_def)

lemma ir_If_False_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>2 t t')"
  by(simp add: ir_If_False ir_sym flip_def)

lemma ir_If':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  apply(rule ir_pre)
   apply(rule ir_disj)
    apply(rule ir_If_True_True)
    apply assumption
   apply(rule ir_If_False_False)
   apply assumption
  apply blast
  done

lemma ir_While_triv:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>2 s s'))"
  by(simp add: ir_While_False ir_sym flip_def)

lemma ir_While':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') (c;;WHILE b DO c) (c';;WHILE b' DO c') Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>1 s s' \<or> Q\<^sub>2 s s'))"
  apply(rule ir_pre)
   apply(rule ir_disj)
     apply(rule ir_While_True)
     apply(rule ir_sym)
     apply(simp add: flip_def)
     apply(rule ir_While_True)
     apply(rule ir_sym)
    apply(simp add: flip_def)
   apply(rule ir_While_triv)
   apply assumption
  apply simp
  done

subsection "client0"

definition low_eq_strong where
  "low_eq_strong s s' \<equiv> (s ''high'' \<noteq> s' ''high'') \<and> low_eq s s'"

lemma low_eq_strong_upd[simp]:
  "var \<noteq> ''high'' \<and> var \<noteq> ''low'' \<Longrightarrow> low_eq_strong(s(var := v)) (s'(var := v')) = low_eq_strong s s'"
  by(auto simp: low_eq_strong_def)

text \<open>
  A variation on client0 from O'Hearn~\cite{OHearn_19}: how to reason about loops via a single unfolding
\<close>
definition client0 :: com where
  "client0 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (N 0) (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (V ''n'')));;
                      (Assign ''n'' (V ''nondet''))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client0:
  "\<exists>Q. ir_hoare low_eq client0 client0 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client0_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

    apply(rule ir_While')
      apply clarsimp

      apply(rule ir_Seq)
       apply(rule ir_Seq)
        apply(rule ir_Assign_Assign)
       apply(rule ir_Assign_Assign)
      apply clarsimp

      apply(rule ir_While_triv)
      apply clarsimp
      apply assumption

     apply clarsimp
     apply assumption

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

(* Not needed? *)
lemma ir_While_backwards:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                       ir_hoare (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) c' Q"
  apply(rule ir_While_backwards_frontier)
   apply assumption
  apply(rule ir_While_False)
  apply auto
  done

subsection "Derive a variant of the backwards variant rule"

text \<open>Here we appeal to completeness again to derive this rule from the corresponding
        property about @{term ir_valid}.\<close>

subsection "A variant of the frontier rule"

text \<open>
  Agin we derive this rule by appealing to completeness and the corresponding property of
  @{term ir_valid}
\<close>

lemma While_backwards_frontier_both_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s s'. P (k + n) s s' \<and> bval b s \<and> bval b' s' \<and> (c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(WHILE b' DO c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(WHILE b' DO c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q q' \<and> bval b q \<and> bval b' q' \<and> (c, q) \<Rightarrow> r \<and> (c', q') \<Rightarrow> r'"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_both_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  by(auto simp: ir_valid_def intro: While_backwards_frontier_both_ir_valid')

lemma ir_While_backwards_frontier_both:
  "\<lbrakk>\<And>n. ir_hoare (\<lambda>s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n));
   ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q\<rbrakk>
   \<Longrightarrow> ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  using soundness completeness While_backwards_frontier_both_ir_valid by auto

text \<open>
  The following rule then follows easily as a special case
\<close>
lemma ir_While_backwards_both:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s \<and> \<not> bval b' s')"
  apply(rule ir_While_backwards_frontier_both)
   apply blast
  by(simp add: ir_While_False ir_sym flip_def)

subsection "client1"

text \<open>
  An example roughly equivalent to cient1 from O'Hearn~\cite{OHearn_19}0

  In particular we use the backwards variant rule to reason about the loop.
\<close>
definition client1 :: com where
  "client1 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client1:
  "\<exists>Q. ir_hoare low_eq client1 client1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client1_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
      apply(rule ir_While_backwards_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> int n \<le> s ''n'' \<and> int n \<le> s' ''n''"])
      apply(rule ir_post)
       apply(rule ir_Assign_Assign)
      apply clarsimp

     apply clarsimp

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

subsection "client2"

text \<open>
  An example akin to client2 from O'Hearn~\cite{OHearn_19}.

  Note that this example is carefully written to show use of the frontier rule first to
  reason up to the broken loop iteration, and then we unfold the loop at that point to
  reason about the broken iteration, and then use the plain backwards variant rule to
  reason over the remainder of the loop.
\<close>
definition client2 :: com where
  "client2 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (N 4000000))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)));;
                       (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))
                       )
              )"

lemma client2:
  "\<exists>Q. ir_hoare low_eq client2 client2 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client2_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
     apply(rule ir_Assign_Assign)
    apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_frontier_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> s ''x'' \<ge> 0 \<and> s ''x'' \<le> 2000000 - 1 \<and> s' ''x'' \<ge> 0 \<and> s' ''x'' \<le> 2000000 - 1"])
      apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
  apply clarsimp
      apply(rule ir_post)
       apply(rule ir_If')
        apply(rule ir_Assign_Assign)
       apply(rule ir_Skip_Skip)
      apply clarsimp

     apply clarsimp
     apply(rule ir_While')
      apply clarsimp
      apply(rule ir_Seq)
       apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
      apply(rule ir_If_True_True)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_both[where P="\<lambda>n s s'.  s ''x'' = 2000000 + int n \<and> s' ''x'' = 2000000 + int n \<and> s ''x'' \<ge> 2000000 \<and> s ''x'' \<le> 4000000 \<and> s' ''x'' \<ge> 2000000 \<and> s' ''x'' \<le> 4000000 \<and> s ''low'' = s ''high'' \<and> s' ''low'' = s' ''high'' \<and> s ''high'' \<noteq> s' ''high''"])

     apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
      apply(rule ir_If_False_False)
       apply fastforce
      apply (fastforce simp: low_eq_strong_def)
     apply fastforce
    apply(fastforce simp: low_eq_strong_def)
   apply(fastforce simp: low_eq_strong_def)

  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Ancient_Numeral
  imports Main Reversed_Bit_Lists Legacy_Aliases
begin

definition Bit :: "int \<Rightarrow> bool \<Rightarrow> int"  (infixl "BIT" 90)
  where "k BIT b = (if b then 1 else 0) + k + k"

lemma Bit_B0: "k BIT False = k + k"
   by (simp add: Bit_def)

lemma Bit_B1: "k BIT True = k + k + 1"
   by (simp add: Bit_def)

lemma Bit_B0_2t: "k BIT False = 2 * k"
  by (rule trans, rule Bit_B0) simp

lemma Bit_B1_2t: "k BIT True = 2 * k + 1"
  by (rule trans, rule Bit_B1) simp

lemma uminus_Bit_eq:
  "- k BIT b = (- k - of_bool b) BIT b"
  by (cases b) (simp_all add: Bit_def)

lemma power_BIT: "2 ^ Suc n - 1 = (2 ^ n - 1) BIT True"
  by (simp add: Bit_B1)

lemma bin_rl_simp [simp]: "bin_rest w BIT bin_last w = w"
  by (simp add: Bit_def)

lemma bin_rest_BIT [simp]: "bin_rest (x BIT b) = x"
  by (simp add: Bit_def)

lemma even_BIT [simp]: "even (x BIT b) \<longleftrightarrow> \<not> b"
  by (simp add: Bit_def)

lemma bin_last_BIT [simp]: "bin_last (x BIT b) = b"
  by simp

lemma BIT_eq_iff [iff]: "u BIT b = v BIT c \<longleftrightarrow> u = v \<and> b = c"
  by (auto simp: Bit_def) arith+

lemma BIT_bin_simps [simp]:
  "numeral k BIT False = numeral (Num.Bit0 k)"
  "numeral k BIT True = numeral (Num.Bit1 k)"
  "(- numeral k) BIT False = - numeral (Num.Bit0 k)"
  "(- numeral k) BIT True = - numeral (Num.BitM k)"
  by (simp_all only: Bit_B0 Bit_B1 numeral.simps numeral_BitM)

lemma BIT_special_simps [simp]:
  shows "0 BIT False = 0"
    and "0 BIT True = 1"
    and "1 BIT False = 2"
    and "1 BIT True = 3"
    and "(- 1) BIT False = - 2"
    and "(- 1) BIT True = - 1"
  by (simp_all add: Bit_def)

lemma Bit_eq_0_iff: "w BIT b = 0 \<longleftrightarrow> w = 0 \<and> \<not> b"
  by (auto simp: Bit_def) arith

lemma Bit_eq_m1_iff: "w BIT b = -1 \<longleftrightarrow> w = -1 \<and> b"
  by (auto simp: Bit_def) arith

lemma expand_BIT:
  "numeral (Num.Bit0 w) = numeral w BIT False"
  "numeral (Num.Bit1 w) = numeral w BIT True"
  "- numeral (Num.Bit0 w) = (- numeral w) BIT False"
  "- numeral (Num.Bit1 w) = (- numeral (w + Num.One)) BIT True"
  by (simp_all add: BitM_inc_eq add_One)

lemma less_Bits: "v BIT b < w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> \<not> b \<and> c"
  by (auto simp: Bit_def)

lemma le_Bits: "v BIT b \<le> w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> (\<not> b \<or> c)"
  by (auto simp: Bit_def)

lemma pred_BIT_simps [simp]:
  "x BIT False - 1 = (x - 1) BIT True"
  "x BIT True - 1 = x BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma succ_BIT_simps [simp]:
  "x BIT False + 1 = x BIT True"
  "x BIT True + 1 = (x + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma add_BIT_simps [simp]:
  "x BIT False + y BIT False = (x + y) BIT False"
  "x BIT False + y BIT True = (x + y) BIT True"
  "x BIT True + y BIT False = (x + y) BIT True"
  "x BIT True + y BIT True = (x + y + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma mult_BIT_simps [simp]:
  "x BIT False * y = (x * y) BIT False"
  "x * y BIT False = (x * y) BIT False"
  "x BIT True * y = (x * y) BIT False + y"
  by (simp_all add: Bit_B0_2t Bit_B1_2t algebra_simps)

lemma B_mod_2': "X = 2 \<Longrightarrow> (w BIT True) mod X = 1 \<and> (w BIT False) mod X = 0"
  by (simp add: Bit_B0 Bit_B1)

lemma bin_ex_rl: "\<exists>w b. w BIT b = bin"
  by (metis bin_rl_simp)

lemma bin_exhaust: "(\<And>x b. bin = x BIT b \<Longrightarrow> Q) \<Longrightarrow> Q"
by (metis bin_ex_rl)

lemma bin_abs_lem: "bin = (w BIT b) \<Longrightarrow> bin \<noteq> -1 \<longrightarrow> bin \<noteq> 0 \<longrightarrow> nat \<bar>w\<bar> < nat \<bar>bin\<bar>"
  apply clarsimp
  apply (unfold Bit_def)
  apply (cases b)
   apply (clarsimp, arith)
  apply (clarsimp, arith)
  done

lemma bin_induct:
  assumes PPls: "P 0"
    and PMin: "P (- 1)"
    and PBit: "\<And>bin bit. P bin \<Longrightarrow> P (bin BIT bit)"
  shows "P bin"
  apply (rule_tac P=P and a=bin and f1="nat \<circ> abs" in wf_measure [THEN wf_induct])
  apply (simp add: measure_def inv_image_def)
  apply (case_tac x rule: bin_exhaust)
  apply (frule bin_abs_lem)
  apply (auto simp add : PPls PMin PBit)
  done

lemma Bit_div2: "(w BIT b) div 2 = w"
  by (fact bin_rest_BIT)

lemma twice_conv_BIT: "2 * x = x BIT False"
  by (simp add: Bit_def)

lemma BIT_lt0 [simp]: "x BIT b < 0 \<longleftrightarrow> x < 0"
by(cases b)(auto simp add: Bit_def)

lemma BIT_ge0 [simp]: "x BIT b \<ge> 0 \<longleftrightarrow> x \<ge> 0"
by(cases b)(auto simp add: Bit_def)

lemma bin_to_bl_aux_Bit_minus_simp [simp]:
  "0 < n \<Longrightarrow> bin_to_bl_aux n (w BIT b) bl = bin_to_bl_aux (n - 1) w (b # bl)"
  by (cases n) auto

lemma bl_to_bin_BIT:
  "bl_to_bin bs BIT b = bl_to_bin (bs @ [b])"
  by (simp add: bl_to_bin_append Bit_def)

lemma bin_nth_0_BIT: "bin_nth (w BIT b) 0 \<longleftrightarrow> b"
  by simp

lemma bin_nth_Suc_BIT: "bin_nth (w BIT b) (Suc n) = bin_nth w n"
  by (simp add: bit_Suc)

lemma bin_nth_minus [simp]: "0 < n \<Longrightarrow> bin_nth (w BIT b) n = bin_nth w (n - 1)"
  by (cases n) (simp_all add: bit_Suc)

lemma bin_sign_simps [simp]:
  "bin_sign (w BIT b) = bin_sign w"
  by (simp add: bin_sign_def Bit_def)

lemma bin_nth_Bit: "bin_nth (w BIT b) n \<longleftrightarrow> n = 0 \<and> b \<or> (\<exists>m. n = Suc m \<and> bin_nth w m)"
  by (cases n) auto

lemmas sbintrunc_Suc_BIT [simp] =
  signed_take_bit_Suc [where a="w BIT b", simplified bin_last_BIT bin_rest_BIT] for w b

lemmas sbintrunc_0_BIT_B0 [simp] =
  signed_take_bit_0 [where a="w BIT False", simplified bin_last_numeral_simps bin_rest_numeral_simps]
  for w

lemmas sbintrunc_0_BIT_B1 [simp] =
  signed_take_bit_0 [where a="w BIT True", simplified bin_last_BIT bin_rest_numeral_simps]
  for w

lemma sbintrunc_Suc_minus_Is:
  \<open>0 < n \<Longrightarrow>
  sbintrunc (n - 1) w = y \<Longrightarrow>
  sbintrunc n (w BIT b) = y BIT b\<close>
  by (cases n) (simp_all add: Bit_def signed_take_bit_Suc)

lemma bin_cat_Suc_Bit: "bin_cat w (Suc n) (v BIT b) = bin_cat w n v BIT b"
  by (auto simp add: Bit_def concat_bit_Suc)

lemma int_not_BIT [simp]: "NOT (w BIT b) = (NOT w) BIT (\<not> b)"
  by (simp add: not_int_def Bit_def)

lemma int_and_Bits [simp]: "(x BIT b) AND (y BIT c) = (x AND y) BIT (b \<and> c)"
  using and_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma int_or_Bits [simp]: "(x BIT b) OR (y BIT c) = (x OR y) BIT (b \<or> c)"
  using or_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma int_xor_Bits [simp]: "(x BIT b) XOR (y BIT c) = (x XOR y) BIT ((b \<or> c) \<and> \<not> (b \<and> c))"
  using xor_int_rec [of \<open>x BIT b\<close> \<open>y BIT c\<close>] by (auto simp add: Bit_B0_2t Bit_B1_2t)

lemma mod_BIT:
  "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit" for bit
proof -
  have "2 * (bin mod 2 ^ n) + 1 = (2 * bin mod 2 ^ Suc n) + 1"
    by (simp add: mod_mult_mult1)
  also have "\<dots> = ((2 * bin mod 2 ^ Suc n) + 1) mod 2 ^ Suc n"
    by (simp add: ac_simps pos_zmod_mult_2)
  also have "\<dots> = (2 * bin + 1) mod 2 ^ Suc n"
    by (simp only: mod_simps)
  finally show ?thesis
    by (auto simp add: Bit_def)
qed

lemma minus_BIT_0: fixes x y :: int shows "x BIT b - y BIT False = (x - y) BIT b"
by(simp add: Bit_def)

lemma int_lsb_BIT [simp]: fixes x :: int shows
  "lsb (x BIT b) \<longleftrightarrow> b"
by(simp add: lsb_int_def)

lemma int_shiftr_BIT [simp]: fixes x :: int
  shows int_shiftr0: "drop_bit 0 x = x"
  and int_shiftr_Suc: "drop_bit (Suc n) (x BIT b) = drop_bit n x"
  by (simp_all add: drop_bit_Suc)

lemma msb_BIT [simp]: "msb (x BIT b) = msb x"
by(simp add: msb_int_def)

end