theory a2
  (* Download the file RegExp.thy and put it in the same directory as this one: *)
  imports RegExp
begin

section "Question 1: Higher-Order Logic"

lemma hol_a: "\<not>(\<forall>x. P x) \<longleftrightarrow> (\<exists>x. \<not>P x)"
  (*TODO*)
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule allI)
   apply (rule ccontr)
   apply (erule notE)
   apply (rule_tac x = "x" in exI)
   apply assumption
  apply (rule notI)
  apply (erule exE)
  apply (erule notE)
  apply (erule_tac x = "x" in allE)
  apply assumption
  done

lemma hol_b: "(\<forall>x. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q x))"
  (*TODO*)
  apply (rule iffI)
   apply (rule impI)
   apply (rule allI)
   apply (erule_tac x = "x" in allE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (erule_tac x = "x" in allE)
  apply assumption
  oops

  find_theorems "(_ \<or> _)"

lemma hol_c: "\<forall>x. \<not>f x \<longrightarrow> f (g x) \<Longrightarrow> \<forall>x. f x \<or> f (g x)"
  (*TODO*)
  apply (rule allI)
  apply (erule_tac x = "x" in allE)
  apply (rule classical)
  apply (erule impE)
   apply (rule notI)
   apply (erule notE)
   apply (rule disjI1)
   apply assumption
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma hol_d: "\<lbrakk>\<forall>x. \<not>f x \<longrightarrow> f (g x); \<exists>x. f x\<rbrakk> \<Longrightarrow> \<exists>x. f x \<and> f (g (g x))"
  (*TODO*)
  apply (erule exE)
  apply (case_tac "f (g (g x))")
   apply (rule_tac x = "x" in exI)
   apply (rule conjI)
    apply assumption
   apply assumption
  apply (rule_tac x = "g x" in exI)
  apply (rule conjI)
   apply (drule hol_c)
   apply (erule_tac x = "g x" in allE)
   apply (erule disjE)
    apply assumption
   apply (erule notE)
   apply assumption
  apply (erule_tac x = "g (g x)" in allE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma hol_e: "(\<forall>x. Q x = P x) \<and> ((\<exists>x. P x) \<longrightarrow> H) \<and> (\<exists>x. Q x) \<longrightarrow> H"
  (*TODO*)
  apply (rule impI)
  apply (erule conjE)
  apply (erule conjE)
  apply (erule exE)
  apply (erule_tac x = "x" in allE)
  apply (drule iffD1)
   apply assumption
  apply (erule impE)
   apply (rule_tac x = "x" in exI)
   apply assumption
  apply assumption
  done

lemma hol_f: "(\<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P x)"
  (*TODO*)
  apply (rule impI)
  apply (erule_tac x = "\<exists>x . P x" in allE)
  apply (erule impE)
   prefer 2
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (rule_tac x = "x" in exI)
  apply assumption
  done

(*---------------------------------------------------------*)
section "Question 2: Strings and Regular Expressions"

(* An example string with newline characters *)
definition
  test_str :: string
  where
  "test_str =
''some
test
abc hello
text''"

definition
  new_line :: char
  where
  "new_line = CHR ''\<newline>''"

(*----------------*)
(* Question 2 (a) *)
primrec
  glue :: "'a \<Rightarrow> 'a list list \<Rightarrow> 'a list"
  where
  "glue a [] = []" |
  "glue a (xs # xss) = (if xss = [] then xs else xs @ a # glue a xss)"

(* test on some examples *)

value "glue (Suc 0) [[0, 0], [2, 2], [0]]"
value "glue (Suc 0) [[0, 0], [2, 2], [0], []]"
value "glue (Suc 0) [[],[]]"

(* Define and test on some examples:
  chop :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list list"
*)

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

definition "chop = chop' []"

(*----------------*)
(* Question 2 (b) *)
primrec
  num_of :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
  where
  "num_of a [] = 0" |
  "num_of a (x # xs ) = (if a = x then Suc (num_of a xs) else num_of a xs)"

lemma length_glue:
  "length (glue a xss) = sum_list (map length xss) + length xss - 1"
  (*TODO*)
  apply (induct xss)
  apply auto
  done

lemma length_chop' [simp]:
  "length (chop' ys x xs) = num_of x xs + 1"
  apply (induct xs arbitrary: ys)
  apply auto
  done

lemma length_chop:
  "length (chop x xs) = num_of x xs + 1"
  (*TODO*)
  apply (unfold chop_def)
  apply (simp add: chop_def)
  done

(*----------------*)
(* Question 2 (c) *)
lemma chop'_set:
  "\<lbrakk> ls \<in> set (chop' ys a xs); a \<notin> set ys \<rbrakk> \<Longrightarrow> a \<notin> set ls"
  apply (induct xs arbitrary: ys ls)
  apply (auto split: if_split_asm)
  done

lemma chop_sep:
  "ls \<in> set (chop a xs) \<Longrightarrow> a \<notin> set ls"
  (*TODO*)
  apply (simp add: chop'_set chop_def)
  done

lemma chop'_neq_Nil[simp]:
  "chop' ys a xs \<noteq> []"
  by (induct xs arbitrary: ys) auto

lemma glue_chop'[simp]:
  "glue a (chop' ys a xs) = ys @ xs"
  by (induct xs arbitrary: ys) auto

lemma glue_chop:
  "glue a (chop a xs) = xs"
  (*TODO*)
   apply (simp add: chop_def)
  done

(*----------------*)
(* Question 2 (d) *)

(* TODO: define
  any_of :: "regexp list \<Rightarrow> regexp"
*)

definition
  any_of :: "regexp list \<Rightarrow> regexp"
  where
  "any_of xs = fold Alt xs null"

lemma lang_fold_Alt[simp]:
  "lang (fold Alt rs r) = \<Union> (lang ` set rs) \<union> lang r"
  apply (induct rs arbitrary: r)
   apply auto
  done

lemma lang_any_of[simp]:
  "lang (any_of rs) = \<Union> (lang ` set rs)"
  (* TODO *)
  apply (simp add: any_of_def)
  done

primrec
  repeat :: "word set \<Rightarrow> nat \<Rightarrow> word set"
  where
  "repeat A 0 = {[]}"
| "repeat A (Suc n) = conc A (repeat A n)"

lemma concI[elim]:
  "\<lbrakk> as \<in> A; bs \<in> B \<rbrakk> \<Longrightarrow> as @ bs \<in> conc A B"
  apply (auto simp: conc_def)
  done

lemma concD[dest!]:
  "xs \<in> conc A B \<Longrightarrow> \<exists>as bs. as \<in> A \<and> bs \<in> B \<and> xs = as @ bs"
  apply (auto simp: conc_def)
  done

lemma repeat_0[simp,intro!]:
  "[] \<in> repeat A 0"
  apply simp
  done

lemma repeat_Suc[elim]:
  "\<lbrakk> as \<in> A; xs \<in> repeat A n \<rbrakk> \<Longrightarrow> as @ xs \<in> repeat A (Suc n)"
  apply auto
  done

lemma star_repeat_Ex:
  "as \<in> star A \<Longrightarrow> \<exists>n. as \<in> repeat A n"
  apply (erule star.induct)
    apply auto
  done

lemma repeat_n_star:
  "as \<in> repeat A n \<Longrightarrow> as \<in> star A"
  apply (induct n arbitrary: as)
    apply auto
  done

lemma star_repeat:
  "star A = (\<Union>n. repeat A n)"
  apply auto
  apply (auto simp: star_repeat_Ex repeat_n_star)
  done

(*----------------*)
(* Question 2 (e) *)
definition
  matches :: "regexp \<Rightarrow> string \<Rightarrow> bool"
  where
  "matches r w \<equiv> w \<in> lang r"

definition
  matches_sub :: "regexp \<Rightarrow> string \<Rightarrow> bool"
  where
  "matches_sub r = matches TODO"

primrec
  string :: "string \<Rightarrow> regexp"
  where
  "string [] = TODO"

primrec
  is_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
  "is_prefix [] ys = TODO"

primrec
  is_substring :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
  "is_substring xs [] = TODO"

(* TODO: test on some examples *)

lemma matches_sub:
  "matches_sub r xs = (\<exists>xs' ys zs. xs = ys @ xs' @ zs \<and> matches r xs')"
  (* TODO *)
  oops

lemma matches_string[simp]:
  "matches (string xs) ys = (ys = xs)"
  (* TODO *)
  oops

lemma is_substring:
  "is_substring xs ys = (\<exists>bs cs. ys = bs @ xs @ cs)"
  (* TODO *)
  oops

lemma matches_substring:
  "matches_sub (string xs) l = is_substring xs l"
  (* TODO *)
  oops

(*----------------*)
(* Question 2 (f) *)
primrec
  rlen :: "regexp \<Rightarrow> nat option"
  where
  "rlen (Atom a) = TODO"

lemma rlen_string[simp]:
  "rlen (string xs) = Some (length xs)"
  (* TODO *)
  oops

lemma rlen_lang:
  "rlen r = Some n \<Longrightarrow> \<forall>xs \<in> lang r. length xs = n"
  (* TODO *)
  oops

(*---------------------------------------------------------*)
section "Question 3: Normal Forms"

(*----------------*)
(* Question 3 (a) *)
fun
  find_pat :: "'a list \<Rightarrow> 'a list"
  where
  (* TODO *)

value "find_pat ''cababc''"

lemma hd_find_pat[simp]:
  "hd (find_pat xs) = hd xs"
  (* TODO *)
  oops

lemma last_find_pat[simp]:
  "last (find_pat xs) = last xs"
  (* TODO *)
  oops

lemma find_pat_neq:
  "(find_pat xs \<noteq> xs) = (\<exists>as bs x y. xs = as @ x # y # x # bs)"
  (* TODO *)
  oops

lemma find_pat_eq:
  "(find_pat xs = xs) = (\<forall>as bs x y. xs \<noteq> as @ x # y # x # bs)"
  by (metis find_pat_neq)

(*----------------*)
(* Question 3 (b) *)

lemma find_pat_neq_Cons:
  "find_pat xs \<noteq> xs \<Longrightarrow> find_pat (x#xs) \<noteq> x#xs"
  oops (* helper *)

lemma find_pat_eq_Cons:
  "find_pat (x#xs) = x#xs \<Longrightarrow> find_pat xs = xs"
  oops (* helper *)

lemma find_pat_Cons_find_pat:
  "find_pat (x#find_pat xs) = find_pat (find_pat (x#xs))"
  (* TODO *)
  oops

lemma find_pat_app_find_pat:
  "find_pat (find_pat xs @ [x]) = find_pat (find_pat (xs @ [x]))"
  (* TODO *)
  oops

lemma find_pat_appendD:
  "find_pat (xs @ ys) = xs @ ys \<Longrightarrow> find_pat xs = xs"
  oops (* helper *)

lemma find_pat_eq_rev:
  "find_pat xs = xs \<Longrightarrow> find_pat (rev xs) = rev xs"
  (* TODO *)
  oops

lemma find_pat_rev:
  "find_pat xs = xs \<Longrightarrow> find_pat (rev xs @ [x]) = rev (find_pat (x # xs))"
  (* TODO *)
  oops

(*----------------*)
(* Question 3 (c) *)
fun
  nf :: "'a list \<Rightarrow> 'a list"
  where
  "nf xs = (if find_pat xs = xs then xs else nf (find_pat xs))"
  (* Extract a lemma that helps Isabelle to prove termination here. Make it [simp]. *)
  sorry

(* This means simp will not automatically unfold nf. Use "subst nf.simps" to unfold manually. *)
declare nf.simps[simp del]

value "nf ''cabacacb''"

lemma nf_singles[simp]:
  "nf [] = []"
  "nf [x] = [x]"
  "nf [x,y] = [x,y]"
  by (auto simp: nf.simps)

lemma nf_find_pat:
  "nf (find_pat xs) = nf xs"
  (* TODO *)
  oops

lemma nf_fp:
  "find_pat (nf xs) = nf xs"
  (* TODO *)
  oops

lemma nf_nf:
  "nf (nf xs) = nf xs"
  (* TODO *)
  oops

lemma hd_nf:
  "hd (nf xs) = hd xs"
  (* TODO *)
  oops

lemma last_nf:
  "last (nf xs) = last xs"
  (* TODO *)
  oops

(*----------------*)
(* Question 3 (d) *)

lemma find_pat_nf_Cons:
  "find_pat xs = xs \<Longrightarrow> nf (x#xs) = find_pat (x#xs)"
  oops (* helper *)

lemma nf_find_pat_Cons:
  "find_pat xs \<noteq> xs \<Longrightarrow> nf (x # find_pat xs) = nf (x # xs)"
  oops (* helper *)

lemma nf_Cons_nf:
  "nf (x#nf xs) = nf (x#xs)"
  (* TODO *)
  oops

lemma nf_hd_dist:
  "nf (x#xs) = find_pat (x#nf xs)"
  (* TODO *)
  oops

lemma nf_last_dist:
  "nf (xs @ [x]) = find_pat (nf xs @ [x])"
  (* TODO *)
  oops

lemma find_pat_rev_Cons:
  "rev (find_pat (x#nf xs)) = find_pat (rev (x#nf xs))"
  oops (* helper *)

lemma nf_rev:
  "nf (rev xs) = rev (nf xs)"
  (* TODO *)
  oops

end


theory XC_Definition
  imports "Karp21.Polynomial_Reductions"
          "HOL-Library.Disjoint_Sets"
          "../../poly-reductions/Lib/SAT_Definition"
begin

subsection "Exact cover definitions"

definition "exact_cover_alter_def \<equiv>
   {(X, S). \<Union>S \<subseteq> X \<and>
    (\<exists>S' \<subseteq> S. \<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t))}"

definition "exact_cover \<equiv> {(X, S). \<Union>S \<subseteq> X \<and> (\<exists>S' \<subseteq> S. \<Union>S' = X \<and> disjoint S')}"

lemma exact_cover_alter_def_eq: "(X, S) \<in> exact_cover_alter_def \<longleftrightarrow> (X, S) \<in> exact_cover"
proof (standard, goal_cases)
  assume 1: "(X, S) \<in> exact_cover_alter_def"
  hence "\<Union>S \<subseteq> X" unfolding exact_cover_alter_def_def
    by blast
  from 1 obtain S' where s_def: "S' \<subseteq> S" "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
    unfolding exact_cover_alter_def_def
    by blast
  hence "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s"
    by blast
  then have "X \<subseteq> \<Union>S'"
    by blast
  moreover have "\<Union>S' \<subseteq> X"
    using \<open>S' \<subseteq> S\<close> \<open>\<Union>S \<subseteq> X\<close>
    by blast
  ultimately have "X = \<Union>S'"
    by simp
  have "disjoint S'"
  proof (rule disjointI)
    fix a b
    assume ab_def: "a \<in> S'" "b \<in> S'" "a \<noteq> b"

    with s_def have
      "\<forall>x \<in> X. x \<in> a \<longrightarrow> x \<notin> b"
      "\<forall>x \<in> X. x \<in> b \<longrightarrow> x \<notin> a"
       by metis+
    hence "\<forall>x\<in>X. x \<notin> a \<inter> b"
      by blast
    moreover from \<open>\<Union>S' \<subseteq> X\<close> have "\<forall>x \<in> a \<inter> b. x \<in> X"
      using ab_def
      by blast
    ultimately show "a \<inter> b = {}"
      by blast
  qed
  from \<open>X = \<Union>S'\<close> \<open>disjoint S'\<close> \<open>S' \<subseteq> S\<close> \<open>\<Union>S \<subseteq> X\<close>
  show "(X, S) \<in> exact_cover"
    unfolding exact_cover_def
    by blast
next
  assume 2:"(X, S) \<in> exact_cover"
  then have "\<Union>S \<subseteq> X"
    unfolding exact_cover_def
    by blast
  from 2 obtain S' where S'_def: "S' \<subseteq> S" "\<Union>S' = X" "disjoint S'"
    unfolding exact_cover_def
    by blast
  have "\<forall>x \<in> X. \<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
  proof
    fix x
    assume "x \<in> X"
    then obtain s where "s \<in> S'" "x \<in> s"
      using S'_def
      by blast
    moreover then have "\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t"
      using disjointD[OF \<open>disjoint S'\<close>]
      by blast
    ultimately show "\<exists>s \<in> S'. x \<in> s \<and> (\<forall>t \<in> S'. s \<noteq> t \<longrightarrow> x \<notin> t)"
      by blast
  qed
  then show "(X, S) \<in> exact_cover_alter_def"
    using \<open>\<Union>S \<subseteq> X\<close> \<open>S' \<subseteq> S\<close>
    unfolding exact_cover_alter_def_def
    by blast
qed

definition cover :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
"cover S' X \<longleftrightarrow> \<Union>S' = X \<and> disjoint S'"

lemma exact_cover_I: "\<lbrakk>S' \<subseteq> S; \<Union>S \<subseteq> X; cover S' X\<rbrakk> \<Longrightarrow> (X, S) \<in> exact_cover"
  unfolding exact_cover_def cover_def
  by blast

lemma exact_cover_D: "\<lbrakk>(X, S) \<in> exact_cover; \<Union>S \<subseteq> X\<rbrakk> \<Longrightarrow> (\<exists>S' \<subseteq> S. cover S' X)"
  unfolding exact_cover_def cover_def
  by blast

definition
  "cnf_sat \<equiv> {F. sat F}"
end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.*)
  theory TIP_prop_16
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun even :: "Nat => bool" where
"even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z)) = even z"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "even (t2 x x)"
  oops

end


(* 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.*)
  theory TIP_weird_nat_mul3_assoc1
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 (mul3 x1 x2 x3) x4 x5) = (mul3 x1 x2 (mul3 x3 x4 x5)))"
  oops

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Small examples for evaluation mechanisms\<close>

theory Eval_Examples
imports Complex_Main
begin

text \<open>evaluation oracle\<close>

lemma "True \<or> False" by eval
lemma "Suc 0 \<noteq> Suc 1" by eval
lemma "[] = ([] :: int list)" by eval
lemma "[()] = [()]" by eval
lemma "fst ([] :: nat list, Suc 0) = []" by eval

text \<open>normalization\<close>

lemma "True \<or> False" by normalization
lemma "Suc 0 \<noteq> Suc 1" by normalization
lemma "[] = ([] :: int list)" by normalization
lemma "[()] = [()]" by normalization
lemma "fst ([] :: nat list, Suc 0) = []" by normalization

text \<open>term evaluation\<close>

value "(Suc 2 + 1) * 4"

value "(Suc 2 + Suc 0) * Suc 3"

value "nat 100"

value "(10::int) \<le> 12"

value "max (2::int) 4"

value "of_int 2 / of_int 4 * (1::rat)"

value "[] :: nat list"

value "[(nat 100, ())]"

text \<open>a fancy datatype\<close>

datatype ('a, 'b) foo =
    Foo "'a::order" 'b
  | Bla "('a, 'b) bar"
  | Dummy nat
and ('a, 'b) bar =
    Bar 'a 'b
  | Blubb "('a, 'b) foo"

value "Bla (Bar (4::nat) [Suc 0])"

end


theory tut4
  imports Main

(* Isar, structured proofs *)

begin
(* Exercise 1 *)

(*- takes the assumptions and puts them in the proof*)
lemma "(P \<longrightarrow> (Q \<longrightarrow> R)) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R))"
proof
  assume "P \<longrightarrow> (Q \<longrightarrow> R)"
  show "(P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)"
  proof
    assume "P \<longrightarrow> Q"
    show "P \<longrightarrow> R"
    proof
      assume P
      show R
      proof (rule mp)
        show "Q \<longrightarrow> R" by (rule mp) fact+
        show Q by (rule mp) fact+
      qed
    qed
  qed
qed

lemma "(P \<longrightarrow> (Q \<longrightarrow> R)) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R))"
proof (rule impI)+
  assume "P" "P \<longrightarrow> Q \<longrightarrow> R" then have qr: "Q \<longrightarrow> R"
(*try sledgehammer *)
    by fast
  assume "P" "P \<longrightarrow> Q" then have "Q"
    by blast
  then show "R" using qr
    by blast
qed

lemma "(\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> (\<exists>x. P x \<longrightarrow> Q)"
proof
  assume "\<forall>x. P x \<longrightarrow> Q"
  then have "P a \<longrightarrow> Q" by (erule_tac x="a" in allE)
  then show "(\<exists>x. P x \<longrightarrow> Q)" by (rule exI)
qed

lemma assumes 0: "(\<not>(\<exists>x. P x))" shows "(\<forall>x. \<not>P x)"
proof (rule allI, rule notI)
  fix x
  assume 0: "\<not>(\<exists>x. P x)" and forContra: "P x"
  have 1: "\<exists>x. P x" using forContra by (rule exI)
qed

(*method safe*)
(* -, do nothing, don't do natural deduction steps*)
lemma assumes n_all: "(\<not>(\<forall>x. P x))" shows "(\<exists>x. \<not>P x)"
proof (rule ccontr) (* can use classical too *)
  assume n_ex: "(\<nexists>x. \<not>P x)"
  have "\<forall>x. P x"
  proof -
    {fix x
      have "P x"
      proof (rule ccontr)
        assume "\<not> P x" then have "\<exists>x. \<not> P x" ..
        then show False using n_ex by simp
      qed
    }
    then show ?thesis ..
  qed
  then show False using n_all by simp
qed

lemma "(R \<longrightarrow> P) \<longrightarrow> (((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S))"
proof
  assume 0: "R \<longrightarrow> P"
  show "((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S)"
  proof
    assume 1: "\<not>R \<or> P"
    show "Q \<longrightarrow> S"

(* Exercise 2 *)
lemma "(\<forall>x. \<not>rich x \<longrightarrow> rich(father x)) \<longrightarrow> (\<exists>x. rich(father(father x)) \<and> rich x)"
proof cases
  assume "(\<forall>x. \<not>rich x \<longrightarrow> rich(father x))"
  show "(\<exists>x. rich(father(father x)) \<and> rich x)"
  next

qed

end


(*
  Verified Knuth-Morris-Pratt String Search Algorithm in LLVM.
  Adapted from Fabian Hellauer, Peter Lammich: AFP/Knuth_Morris_Pratt by
*)
theory KMP
  imports "../sepref/IICF/IICF"
    "HOL-Library.Sublist"
begin

declare len_greater_imp_nonempty[simp del] min_absorb2[simp]

section\<open>Specification\<close>text_raw\<open>\label{sec:spec}\<close>

subsection\<open>Sublist-predicate with a position check\<close>

subsubsection\<open>Definition\<close>

text \<open>One could define\<close>
definition "sublist_at' xs ys i \<equiv> take (length xs) (drop i ys) = xs"

text\<open>However, this doesn't handle out-of-bound indexes uniformly:\<close>
value[nbe] "sublist_at' [] [a] 5"
value[nbe] "sublist_at' [a] [a] 5"
value[nbe] "sublist_at' [] [] 5"

text\<open>Instead, we use a recursive definition:\<close>
fun sublist_at :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> bool" where
  "sublist_at (x#xs) (y#ys) 0 \<longleftrightarrow> x=y \<and> sublist_at xs ys 0" |
  "sublist_at xs (y#ys) (Suc i) \<longleftrightarrow> sublist_at xs ys i" |
  "sublist_at [] ys 0 \<longleftrightarrow> True" |
  "sublist_at _ [] _ \<longleftrightarrow> False"

text\<open>In the relevant cases, both definitions agree:\<close>
lemma "i \<le> length ys \<Longrightarrow> sublist_at xs ys i \<longleftrightarrow> sublist_at' xs ys i"
  unfolding sublist_at'_def
  by (induction xs ys i rule: sublist_at.induct) auto

text\<open>However, the new definition has some reasonable properties:\<close>
subsubsection\<open>Properties\<close>
lemma sublist_lengths: "sublist_at xs ys i \<Longrightarrow> i + length xs \<le> length ys"
  by (induction xs ys i rule: sublist_at.induct) auto

text\<open>Furthermore, we need:\<close>
lemma sublist_step[intro]:
  "\<lbrakk>i + length xs < length ys; sublist_at xs ys i; ys!(i + length xs) = x\<rbrakk> \<Longrightarrow> sublist_at (xs@[x]) ys i"
  apply (induction xs ys i rule: sublist_at.induct)
      apply auto
  using sublist_at.elims(3) by fastforce

lemma all_positions_sublist:
"\<lbrakk>i + length xs \<le> length ys; \<forall>jj<length xs. ys!(i+jj) = xs!jj\<rbrakk> \<Longrightarrow> sublist_at xs ys i"
proof (induction xs rule: rev_induct)
  case Nil
  then show ?case by (simp add: Nil_is_sublist)
next
  case (snoc x xs)
  from \<open>i + length (xs @ [x]) \<le> length ys\<close> have "i + length xs \<le> length ys" by simp
  moreover have "\<forall>jj<length xs. ys!(i + jj) = xs!jj"
    by (simp add: nth_append snoc.prems(2))
  ultimately have "sublist_at xs ys i"
    using snoc.IH by simp
  then show ?case
    using snoc.prems by auto
qed

lemma sublist_all_positions: "sublist_at xs ys i \<Longrightarrow> \<forall>jj<length xs. ys!(i+jj) = xs!jj"
  by (induction xs ys i rule: sublist_at.induct) (auto simp: nth_Cons')

text\<open>It also connects well to theory @{theory "HOL-Library.Sublist"} (compare @{thm[source] sublist_def}):\<close>
lemma sublist_at_altdef:
  "sublist_at xs ys i \<longleftrightarrow> (\<exists>ps ss. ys = ps@xs@ss \<and> i = length ps)"
proof (induction xs ys i rule: sublist_at.induct)
  case (2 ss t ts i)
  show "sublist_at ss (t#ts) (Suc i) \<longleftrightarrow> (\<exists>xs ys. t#ts = xs@ss@ys \<and> Suc i = length xs)"
    (is "?lhs \<longleftrightarrow> ?rhs")
  proof
    assume ?lhs
    then have "sublist_at ss ts i" by simp
    with "2.IH" obtain xs where "\<exists>ys. ts = xs@ss@ys \<and> i = length xs" by auto
    then have "\<exists>ys. t#ts = (t#xs)@ss@ys \<and> Suc i = length (t#xs)" by simp
    then show ?rhs by blast
  next
    assume ?rhs
    then obtain xs where "\<exists>ys. t#ts = xs@ss@ys \<and> Suc i = length xs" by blast
    then have "\<exists>ys. ts = (tl xs)@ss@ys \<and> i = length (tl xs)"
      by (metis hd_Cons_tl length_0_conv list.sel(3) nat.simps(3) size_Cons_lem_eq tl_append2)
    then have "\<exists>xs ys. ts = xs@ss@ys \<and> i = length xs" by blast
    with "2.IH" show ?lhs by simp
  qed
qed auto

corollary sublist_iff_sublist_at: "Sublist.sublist xs ys \<longleftrightarrow> (\<exists>i. sublist_at xs ys i)"
  by (simp add: sublist_at_altdef Sublist.sublist_def)

subsection\<open>Sublist-check algorithms\<close>

text\<open>
  We use the Isabelle Refinement Framework to
  phrase the specification and the algorithm.
\<close>
text\<open>@{term s} for "searchword" / "searchlist", @{term t} for "text"\<close>
definition "kmp_SPEC s t = SPEC (\<lambda>
  None \<Rightarrow> \<nexists>i. sublist_at s t i |
  Some i \<Rightarrow> sublist_at s t i \<and> (\<forall>ii<i. \<not>sublist_at s t ii))"

lemma is_arg_min_id: "is_arg_min id P i \<longleftrightarrow> P i \<and> (\<forall>ii<i. \<not>P ii)"
  unfolding is_arg_min_def by auto

lemma kmp_result: "kmp_SPEC s t =
  RETURN (if sublist s t then Some (LEAST i. sublist_at s t i) else None)"
  unfolding kmp_SPEC_def sublist_iff_sublist_at
  apply (auto intro: LeastI dest: not_less_Least split: option.splits)
  by (meson LeastI nat_neq_iff not_less_Least)

corollary weak_kmp_SPEC: "kmp_SPEC s t \<le> SPEC (\<lambda>pos. pos\<noteq>None \<longleftrightarrow> Sublist.sublist s t)"
  by (simp add: kmp_result)

lemmas kmp_SPEC_altdefs =
  kmp_SPEC_def[folded is_arg_min_id]
  kmp_SPEC_def[folded sublist_iff_sublist_at]
  kmp_result

section\<open>Naive algorithm\<close>

text\<open>Since KMP is a direct advancement of the naive "test-all-starting-positions" approach, we provide it here for comparison:\<close>

subsection\<open>Invariants\<close>
definition "I_out_na s t \<equiv> \<lambda>(i,j,pos).
  (\<forall>ii<i. \<not>sublist_at s t ii) \<and>
  (case pos of None \<Rightarrow> j = 0
    | Some p \<Rightarrow> p=i \<and> sublist_at s t i)"
definition "I_in_na s t i \<equiv> \<lambda>(j,pos).
  case pos of None \<Rightarrow> j < length s \<and> (\<forall>jj<j. t!(i+jj) = s!(jj))
    | Some p \<Rightarrow> sublist_at s t i"

subsection\<open>Algorithm\<close>

(*Algorithm is common knowledge \<longrightarrow> remove citation here, move explanations to KMP below?*)
text\<open>The following definition is taken from Helmut Seidl's lecture on algorithms and data structures@{cite GAD} except that we
\<^item> output the identified position @{term \<open>pos :: nat option\<close>} instead of just @{const True}
\<^item> use @{term \<open>pos :: nat option\<close>} as break-flag to support the abort within the loops
\<^item> rewrite @{prop \<open>i \<le> length t - length s\<close>} in the first while-condition to @{prop \<open>i + length s \<le> length t\<close>} to avoid having to use @{typ int} for list indexes (or the additional precondition @{prop \<open>length s \<le> length t\<close>})
\<close>

definition "naive_algorithm s t \<equiv> do {
  let i=0;
  let j=0;
  let pos=None;
  (_,_,pos) \<leftarrow> WHILEIT (I_out_na s t) (\<lambda>(i,_,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    (_,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,_). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      let i = i + 1;
      let j = 0;
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

subsection\<open>Correctness\<close>

text\<open>The basic lemmas on @{const sublist_at} from the previous chapter together
  with the Refinement Framework's verification condition generator / solver suffice:\<close>

lemma "s \<noteq> [] \<Longrightarrow> naive_algorithm s t \<le> kmp_SPEC s t"
  unfolding naive_algorithm_def kmp_SPEC_def I_out_na_def I_in_na_def
  apply (refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(i,_,pos). length t - i + (if pos = None then 1 else 0))"]
    WHILEIT_rule[where R="measure (\<lambda>(j,_::nat option). length s - j)"]
    )
                 apply (all \<open>clarsimp;(auto; fail)?\<close>)
  subgoal by (metis add_Suc_right all_positions_sublist less_antisym)
  subgoal using less_Suc_eq by blast
  subgoal by (metis less_SucE sublist_all_positions)
  subgoal by (auto split: option.splits) (metis sublist_lengths add_less_cancel_right leI le_less_trans)
  done

text\<open>Note that the precondition cannot be removed without an extra branch: If @{prop \<open>s = []\<close>}, the inner while-condition accesses out-of-bound memory. This will apply to KMP, too.\<close>

section\<open>Knuth--Morris--Pratt algorithm\<close>

text\<open>Just like our templates@{cite KMP77}@{cite GAD}, we first verify the main routine and discuss the computation of the auxiliary values @{term \<open>\<ff> s\<close>} only in a later section.\<close>

subsection\<open>Preliminaries: Borders of lists\<close>

definition "border xs ys \<longleftrightarrow> prefix xs ys \<and> suffix xs ys"
definition "strict_border xs ys \<longleftrightarrow> border xs ys \<and> length xs < length ys"
definition "intrinsic_border ls \<equiv> ARG_MAX length b. strict_border b ls"

subsubsection\<open>Properties\<close>

interpretation border_order: order border strict_border
  by standard (auto simp: border_def suffix_def strict_border_def)
interpretation border_bot: order_bot Nil border strict_border
  by standard (simp add: border_def)

lemma borderE[elim]:
  fixes xs ys :: "'a list"
  assumes "border xs ys"
  obtains "prefix xs ys" and "suffix xs ys"
  using assms unfolding border_def by blast

lemma strict_borderE[elim]:
  fixes xs ys :: "'a list"
  assumes "strict_border xs ys"
  obtains "border xs ys" and "length xs < length ys"
  using assms unfolding strict_border_def by blast

lemma strict_border_simps[simp]:
  "strict_border xs [] \<longleftrightarrow> False"
  "strict_border [] (x # xs) \<longleftrightarrow> True"
  by (simp_all add: strict_border_def)

lemma strict_border_prefix: "strict_border xs ys \<Longrightarrow> strict_prefix xs ys"
  and strict_border_suffix: "strict_border xs ys \<Longrightarrow> strict_suffix xs ys"
  and strict_border_imp_nonempty: "strict_border xs ys \<Longrightarrow> ys \<noteq> []"
  and strict_border_prefix_suffix: "strict_border xs ys \<longleftrightarrow> strict_prefix xs ys \<and> strict_suffix xs ys"
  by (auto simp: border_order.order.strict_iff_order border_def)

lemma border_length_le: "border xs ys \<Longrightarrow> length xs \<le> length ys"
  unfolding border_def by (simp add: prefix_length_le)

lemma border_length_r_less (*rm*): "\<forall>xs. strict_border xs ys \<longrightarrow> length xs < length ys"
  using strict_borderE by auto

lemma all_positions_drop_length_take: "\<lbrakk>i \<le> length w; i \<le> length x;
  \<forall>j<i. x ! j = w ! (length w + j - i)\<rbrakk>
    \<Longrightarrow> drop (length w - i) w = take i x"
  by (cases "i = length x") (simp_all add: nth_equalityI)

lemma all_positions_suffix_take: "\<lbrakk>i \<le> length w; i \<le> length x;
  \<forall>j<i. x ! j = w ! (length w + j - i)\<rbrakk>
    \<Longrightarrow> suffix (take i x) w"
  by (metis all_positions_drop_length_take suffix_drop)

lemma suffix_butlast: "suffix xs ys \<Longrightarrow> suffix (butlast xs) (butlast ys)"
  unfolding suffix_def by (metis append_Nil2 butlast.simps(1) butlast_append)

lemma positions_border: "\<forall>j<l. w!j = w!(length w - l + j) \<Longrightarrow> border (take l w) w"
  by (cases "l < length w") (simp_all add: border_def all_positions_suffix_take take_is_prefix)

lemma positions_strict_border: "l < length w \<Longrightarrow> \<forall>j<l. w!j = w!(length w - l + j) \<Longrightarrow> strict_border (take l w) w"
  by (simp add: positions_border strict_border_def)

lemmas intrinsic_borderI = arg_max_natI[OF _ border_length_r_less, folded intrinsic_border_def]

lemmas intrinsic_borderI' = border_bot.bot.not_eq_extremum[THEN iffD1, THEN intrinsic_borderI]

lemmas intrinsic_border_max = arg_max_nat_le[OF _ border_length_r_less, folded intrinsic_border_def]

lemma nonempty_is_arg_max_ib: "ys \<noteq> [] \<Longrightarrow> is_arg_max length (\<lambda>xs. strict_border xs ys) (intrinsic_border ys)"
  by (simp add: intrinsic_borderI' intrinsic_border_max is_arg_max_linorder)

lemma intrinsic_border_less: "w \<noteq> [] \<Longrightarrow> length (intrinsic_border w) < length w"
  using intrinsic_borderI[of w] border_length_r_less intrinsic_borderI' by blast

lemma intrinsic_border_take_less: "j > 0 \<Longrightarrow> w \<noteq> [] \<Longrightarrow> length (intrinsic_border (take j w)) < length w"
  by (metis intrinsic_border_less length_take less_not_refl2 min_less_iff_conj take_eq_Nil)

subsubsection\<open>Examples\<close>

lemma border_example: "{b. border b ''aabaabaa''} = {'''', ''a'', ''aa'', ''aabaa'', ''aabaabaa''}"
  (is "{b. border b ?l} = {?take0, ?take1, ?take2, ?take5, ?l}")
proof
  show "{?take0, ?take1, ?take2, ?take5, ?l} \<subseteq> {b. border b ?l}"
    by simp eval
  have "\<not>border ''aab'' ?l" "\<not>border ''aaba'' ?l" "\<not>border ''aabaab'' ?l" "\<not>border ''aabaaba'' ?l"
    by eval+
  moreover have "{b. border b ?l} \<subseteq> set (prefixes ?l)"
    using border_def in_set_prefixes by blast
  ultimately show "{b. border b ?l} \<subseteq> {?take0, ?take1, ?take2, ?take5, ?l}"
    by auto
qed

corollary strict_border_example: "{b. strict_border b ''aabaabaa''} = {'''', ''a'', ''aa'', ''aabaa''}"
  (is "?l = ?r")
proof
  have "?l \<subseteq> {b. border b ''aabaabaa''}"
    by auto
  also have "\<dots> = {'''', ''a'', ''aa'', ''aabaa'', ''aabaabaa''}"
    by (fact border_example)
  finally show "?l \<subseteq> ?r" by auto
  show "?r \<subseteq> ?l" by simp eval
qed

corollary "intrinsic_border ''aabaabaa'' = ''aabaa''"
proof - \<comment> \<open>We later obtain a fast algorithm for that.\<close>
  have exhaust: "strict_border b ''aabaabaa'' \<longleftrightarrow> b \<in> {'''', ''a'', ''aa'', ''aabaa''}" for b
    using strict_border_example by auto
  then have
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''''"
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''a''"
    "\<not>is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''aa''"
    "is_arg_max length (\<lambda>b. strict_border b ''aabaabaa'') ''aabaa''"
    unfolding is_arg_max_linorder by auto
  moreover have "strict_border (intrinsic_border ''aabaabaa'') ''aabaabaa''"
    using intrinsic_borderI' by blast
  note this[unfolded exhaust]
  ultimately show ?thesis
    by simp (metis list.discI nonempty_is_arg_max_ib)
qed

subsection\<open>Main routine\<close>

text\<open>The following is Seidl's "border"-table@{cite GAD} (values shifted by 1 so we don't need @{typ int}),
or equivalently, "f" from Knuth's, Morris' and Pratt's paper@{cite KMP77} (with indexes starting at 0).\<close>
fun \<ff> :: "'a list \<Rightarrow> nat \<Rightarrow> nat" where
  "\<ff> s 0 = 0" \<comment> \<open>This increments the compare position while @{prop \<open>j=(0::nat)\<close>}\<close> |
  "\<ff> s j = length (intrinsic_border (take j s)) + 1"
text\<open>Note that we use their "next" only implicitly.\<close>

subsubsection\<open>Invariants\<close>
definition "I_outer s t \<equiv> \<lambda>(i,j,pos).
  (\<forall>ii<i. \<not>sublist_at s t ii) \<and>
  (i\<le>length t) \<and>
  (case pos of None \<Rightarrow> (\<forall>jj<j. t!(i+jj) = s!(jj)) \<and> j < length s
    | Some p \<Rightarrow> p=i \<and> sublist_at s t i)"
text\<open>For the inner loop, we can reuse @{const I_in_na}.\<close>

subsubsection\<open>Algorithm\<close>
text\<open>First, we use the non-evaluable function @{const \<ff>} directly:\<close>
definition "kmp s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  (_,_,pos) \<leftarrow> WHILEIT (I_outer s t) (\<lambda>(i,j,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    ASSERT (i + length s \<le> length t);
    (j,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,pos). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      ASSERT (j < length s \<and> \<ff> s j \<le> j);
      let i = i + (j - \<ff> s j + 1);
      let j = max 0 (\<ff> s j - 1); \<comment> \<open>\<open>max\<close> not necessary, but indicates that subtraction may actually underflow\<close>
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

subsubsection\<open>Correctness\<close>
lemma \<ff>_eq_0_iff_j_eq_0[simp]: "\<ff> s j = 0 \<longleftrightarrow> j = 0"
  by (cases j) simp_all

lemma j_le_\<ff>_le: "j \<le> length s \<Longrightarrow> \<ff> s j \<le> j"
  apply (cases j)
  apply simp_all
  by (metis Suc_leI intrinsic_border_less length_take list.size(3) min.absorb2 nat.simps(3) not_less)

lemma j_le_\<ff>_le': "0 < j \<Longrightarrow> j \<le> length s \<Longrightarrow> \<ff> s j - 1 < j"
  by (metis diff_less j_le_\<ff>_le le_eq_less_or_eq less_imp_diff_less less_one)

lemma \<ff>_le: "s \<noteq> [] \<Longrightarrow> \<ff> s j - 1 < length s"
  by (cases j) (simp_all add: intrinsic_border_take_less)

(*
  Only needed for run-time analysis
*)
lemma "p576 et seq":
  assumes
    "j \<le> length s" and
    assignments:
    "i' = i + (j + 1 - \<ff> s j)"
    "j' = max 0 (\<ff> s j - 1)"
  shows
    sum_no_decrease: "i' + j' \<ge> i + j" and
    i_increase: "i' > i"
  using assignments by (simp_all add: j_le_\<ff>_le[OF assms(1), THEN le_imp_less_Suc])

lemma reuse_matches:
  assumes j_le: "j \<le> length s"
  and old_matches: "\<forall>jj<j. t ! (i + jj) = s ! jj"
  shows "\<forall>jj<\<ff> s j - 1. t ! (i + (j - \<ff> s j + 1) + jj) = s ! jj"
    (is "\<forall>jj<?j'. t ! (?i' + jj) = s ! jj")
proof (cases "j>0")
  assume "j>0"
  have \<ff>_le: "\<ff> s j \<le> j"
    by (simp add: j_le j_le_\<ff>_le)
  with old_matches have 1: "\<forall>jj<?j'. t ! (?i' + jj) = s ! (j - \<ff> s j + 1 + jj)"
    by (metis ab_semigroup_add_class.add.commute add.assoc diff_diff_cancel less_diff_conv)
  have [simp]: "length (take j s) = j" "length (intrinsic_border (take j s)) = ?j'"
    by (simp add: j_le) (metis \<open>0 < j\<close> diff_add_inverse2 \<ff>.elims nat_neq_iff)
  then have "\<forall>jj<?j'. take j s ! jj = take j s ! (j - (\<ff> s j - 1) + jj)"
    by (metis intrinsic_borderI' \<open>0 < j\<close> border_positions length_greater_0_conv strict_border_def)
  then have "\<forall>jj<?j'. take j s ! jj = take j s ! (j - \<ff> s j + 1 + jj)"
    by (simp add: \<ff>_le)
  then have 2: "\<forall>jj<?j'. s ! (j - \<ff> s j + 1 + jj) = s ! jj"
    using \<ff>_le by simp
  from 1 2 show ?thesis by simp
qed simp

theorem shift_safe:
  assumes
    "\<forall>ii<i. \<not>sublist_at s t ii"
    "t!(i+j) \<noteq> s!j" and
    [simp]: "j < length s" and
    matches: "\<forall>jj<j. t!(i+jj) = s!jj"
  defines
    assignment: "i' \<equiv> i + (j - \<ff> s j + 1)"
  shows
    "\<forall>ii<i'. \<not>sublist_at s t ii"
proof (standard, standard)
  fix ii
  assume "ii < i'"
  then consider \<comment> \<open>The position falls into one of three categories:\<close>
    (old) "ii < i" |
    (current) "ii = i" |
    (skipped) "ii > i"
    by linarith
  then show "\<not>sublist_at s t ii"
  proof cases
    case old \<comment> \<open>Old position, use invariant.\<close>
    with \<open>\<forall>ii<i. \<not>sublist_at s t ii\<close> show ?thesis by simp
  next
    case current \<comment> \<open>The mismatch occurred while testing this alignment.\<close>
    with \<open>t!(i+j) \<noteq> s!j\<close> show ?thesis
      using sublist_all_positions[of s t i] by auto
  next
    case skipped \<comment> \<open>The skipped positions.\<close>
    then have "0<j"
      using \<open>ii < i'\<close> assignment by linarith
    then have less_j[simp]: "j + i - ii < j" and le_s: "j + i - ii \<le> length s"
      using \<open>ii < i'\<close> assms(3) skipped by linarith+
    note \<ff>_le[simp] = j_le_\<ff>_le[OF assms(3)[THEN less_imp_le]]
    have "0 < \<ff> s j"
      using \<open>0 < j\<close> \<ff>_eq_0_iff_j_eq_0 neq0_conv by blast
    then have "j + i - ii > \<ff> s j - 1"
      using \<open>ii < i'\<close> assignment \<ff>_le by linarith
    then have contradiction_goal: "j + i - ii > length (intrinsic_border (take j s))"
      by (metis \<ff>.elims \<open>0 < j\<close> add_diff_cancel_right' not_gr_zero)
    show ?thesis
    proof
      assume "sublist_at s t ii"
      note sublist_all_positions[OF this]
      with le_s have a: "\<forall>jj < j+i-ii. t!(ii+jj) = s!jj"
        by simp
      have ff1: "\<not> ii < i"
        by (metis not_less_iff_gr_or_eq skipped)
      then have "i + (ii - i + jj) = ii + jj" for jj
        by (metis add.assoc add_diff_inverse_nat)
      then have "\<not> jj < j + i - ii \<or> t ! (ii + jj) = s ! (ii - i + jj)" if "ii - i + jj < j" for jj
        using that ff1 by (metis matches)
      then have "\<not> jj < j + i - ii \<or> t ! (ii + jj) = s ! (ii - i + jj)" for jj
        using ff1 by auto
      with matches have "\<forall>jj < j+i-ii. t!(ii+jj) = s!(ii-i+jj)" by metis
      then have "\<forall>jj < j+i-ii. s!jj = s!(ii-i+jj)"
        using a by auto
      then have "\<forall>jj < j+i-ii. (take j s)!jj = (take j s)!(ii-i+jj)"
        using \<open>i<ii\<close> by auto
      with positions_strict_border[of "j+i-ii" "take j s", simplified]
      have "strict_border (take (j+i-ii) s) (take j s)".
      note intrinsic_border_max[OF this]
      also note contradiction_goal
      also have "j+i-ii \<le> length s" by (fact le_s)
      ultimately
      show False by simp
    qed
  qed
qed

lemma kmp_correct: "s \<noteq> []
  \<Longrightarrow> kmp s t \<le> kmp_SPEC s t"
  unfolding kmp_def kmp_SPEC_def I_outer_def I_in_na_def
  apply (refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(i,_,pos). length t - i + (if pos = None then 1 else 0))"]
    WHILEIT_rule[where R="measure (\<lambda>(j,_::nat option). length s - j)"]
    )
  apply (all \<open>clarsimp;(auto; fail)?\<close>)
  subgoal by (metis add_Suc_right all_positions_sublist less_antisym)
  subgoal using less_antisym by blast
  subgoal for i jout j using j_le_\<ff>_le[of j s] by simp
  subgoal for i jout j using shift_safe[of i s t j] by fastforce
  subgoal for i jout j using reuse_matches[of j s t i] \<ff>_le by simp
  subgoal by (auto split: option.splits) (metis sublist_lengths add_less_cancel_right leI le_less_trans)
  done

subsubsection\<open>Storing the @{const \<ff>}-values\<close>
text\<open>We refine the algorithm to compute the @{const \<ff>}-values only once at the start:\<close>
definition compute_\<ff>s_SPEC :: "'a list \<Rightarrow> nat list nres" where
  "compute_\<ff>s_SPEC s \<equiv> SPEC (\<lambda>\<ff>s. length \<ff>s = length s + 1 \<and> (\<forall>j\<le>length s. \<ff>s!j = \<ff> s j))"

definition "kmp1 s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  \<ff>s \<leftarrow> compute_\<ff>s_SPEC (butlast s); \<comment> \<open>At the last char, we abort instead.\<close>
  ASSERT (length \<ff>s = length s);
  (_,_,pos) \<leftarrow> WHILEIT (I_outer s t) (\<lambda>(i,j,pos). i + length s \<le> length t \<and> pos=None) (\<lambda>(i,j,pos). do {
    ASSERT (i + length s \<le> length t);
    (j,pos) \<leftarrow> WHILEIT (I_in_na s t i) (\<lambda>(j,pos). t!(i+j) = s!j \<and> pos=None) (\<lambda>(j,pos). do {
      let j=j+1;
      if j=length s then RETURN (j,Some i) else RETURN (j,None)
    }) (j,pos);
    if pos=None then do {
      ASSERT (j < length \<ff>s \<and> \<ff>s!j \<le> j);
      let i = i + (j - \<ff>s!j + 1);
      let j = max 0 (\<ff>s!j - 1); \<comment> \<open>\<open>max\<close> not necessary\<close>
      RETURN (i,j,None)
    } else RETURN (i,j,Some i)
  }) (i,j,pos);

  RETURN pos
}"

lemma \<ff>_butlast[simp]: "j < length s \<Longrightarrow> \<ff> (butlast s) j = \<ff> s j"
  by (cases j) (simp_all add: take_butlast)

lemma kmp1_refine: "kmp1 s t \<le> kmp s t"
  apply (rule refine_IdD)
  unfolding kmp1_def kmp_def Let_def compute_\<ff>s_SPEC_def nres_monad_laws
  apply (intro ASSERT_refine_right ASSERT_refine_left)
   apply simp
  apply (rule Refine_Basic.intro_spec_refine)
  apply refine_rcg
                apply refine_dref_type
                apply auto
  done

text\<open>Next, an algorithm that satisfies @{const compute_\<ff>s_SPEC}:\<close>
subsection\<open>Computing @{const \<ff>}\<close>
subsubsection\<open>Invariants\<close>

definition "I_out_cb s \<equiv> \<lambda>(\<ff>s,i,j).
  length s + 1 = length \<ff>s \<and>
  (\<forall>jj<j. \<ff>s!jj = \<ff> s jj) \<and>
  \<ff>s!(j-1) = i \<and>
  0 < j"
definition "I_in_cb s j \<equiv> \<lambda>i.
  if j=1 then i=0 \<comment> \<open>first iteration\<close>
  else
    strict_border (take (i-1) s) (take (j-1) s) \<and>
    \<ff> s j \<le> i + 1"

subsubsection\<open>Algorithm\<close>

text\<open>Again, we follow Seidl@{cite GAD}, p.582. Apart from the +1-shift, we make another modification:
Instead of directly setting @{term \<open>\<ff>s!1\<close>}, we let the first loop-iteration (if there is one) do that for us.
This allows us to remove the precondition @{prop \<open>s \<noteq> []\<close>}, as the index bounds are respected even in that corner case.\<close>

definition compute_\<ff>s :: "'a list \<Rightarrow> nat list nres" where
  "compute_\<ff>s s = do {
  let \<ff>s=replicate (length s + 1) 0; \<comment> \<open>only the first 0 is needed\<close>
  let i=0;
  let j=1;
  (\<ff>s,_,_) \<leftarrow> WHILEIT (I_out_cb s) (\<lambda>(\<ff>s,_,j). j < length \<ff>s) (\<lambda>(\<ff>s,i,j). do {
    i \<leftarrow> WHILEIT (I_in_cb s j) (\<lambda>i. i>0 \<and> s!(i-1) \<noteq> s!(j-1)) (\<lambda>i. do {
      ASSERT (i-1 < length \<ff>s);
      let i=\<ff>s!(i-1);
      RETURN i
    }) i;
    ASSERT (i < length \<ff>s);
    let i=i+1;
    ASSERT (j < length \<ff>s);
    let \<ff>s=\<ff>s[j:=i];
    let j=j+1;
    RETURN (\<ff>s,i,j)
  }) (\<ff>s,i,j);

  RETURN \<ff>s
}"

subsubsection\<open>Correctness\<close>
lemma take_length_ib[simp]:
  assumes "0 < j" "j \<le> length s"
    shows "take (length (intrinsic_border (take j s))) s = intrinsic_border (take j s)"
proof -
  from assms have "prefix (intrinsic_border (take j s)) (take j s)"
    by (metis intrinsic_borderI' border_def list.size(3) neq0_conv not_less strict_border_def take_eq_Nil)
  also have "prefix (take j s) s"
    by (simp add: \<open>j \<le> length s\<close> take_is_prefix)
  finally show ?thesis
    by (metis append_eq_conv_conj prefixE)
qed

lemma ib_singleton[simp]: "intrinsic_border [z] = []"
  by (metis intrinsic_border_less length_Cons length_greater_0_conv less_Suc0 list.size(3))

lemma border_butlast: "border xs ys \<Longrightarrow> border (butlast xs) (butlast ys)"
  apply (auto simp: border_def)
   apply (metis butlast_append prefixE prefix_order.eq_refl prefix_prefix prefixeq_butlast)
  apply (metis Sublist.suffix_def append.right_neutral butlast.simps(1) butlast_append)
  done

corollary strict_border_butlast: "xs \<noteq> [] \<Longrightarrow> strict_border xs ys \<Longrightarrow> strict_border (butlast xs) (butlast ys)"
  unfolding strict_border_def by (simp add: border_butlast less_diff_conv)

lemma border_take_lengths: "i \<le> length s \<Longrightarrow> border (take i s) (take j s) \<Longrightarrow> i \<le> j"
  using border_length_le by fastforce

lemma border_step: "border xs ys \<longleftrightarrow> border (xs@[ys!length xs]) (ys@[ys!length xs])"
  apply (auto simp: border_def suffix_def)
  using append_one_prefix prefixE apply fastforce
  using append_prefixD apply blast
  done

corollary strict_border_step: "strict_border xs ys \<longleftrightarrow> strict_border (xs@[ys!length xs]) (ys@[ys!length xs])"
  unfolding strict_border_def using border_step by auto

lemma ib_butlast: "length w \<ge> 2 \<Longrightarrow> length (intrinsic_border w) \<le> length (intrinsic_border (butlast w)) + 1"
proof -
  assume "length w \<ge> 2"
  then have "w \<noteq> []" by auto
  then have "strict_border (intrinsic_border w) w"
    by (fact intrinsic_borderI')
  with \<open>2 \<le> length w\<close> have "strict_border (butlast (intrinsic_border w)) (butlast w)"
    by (metis One_nat_def border_bot.bot.not_eq_extremum butlast.simps(1) len_greater_imp_nonempty length_butlast lessI less_le_trans numerals(2) strict_border_butlast zero_less_diff)
  then have "length (butlast (intrinsic_border w)) \<le> length (intrinsic_border (butlast w))"
    using intrinsic_border_max by blast
  then show ?thesis
    by simp
qed

lemma take_Suc0:
  "l\<noteq>[] \<Longrightarrow> take (Suc 0) l = [l!0]"
  "0 < length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  "Suc n \<le> length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  by (cases l, auto)+

corollary \<ff>_Suc(*rm*): "Suc i \<le> length w \<Longrightarrow> \<ff> w (Suc i) \<le> \<ff> w i + 1"
  apply (cases i)
  apply (simp_all add: take_Suc0)
  by (metis One_nat_def Suc_eq_plus1 Suc_to_right butlast_take diff_is_0_eq ib_butlast length_take min.absorb2 nat.simps(3) not_less_eq_eq numerals(2))

lemma \<ff>_step_bound(*rm*):
  assumes "j \<le> length w"
  shows "\<ff> w j \<le> \<ff> w (j-1) + 1"
  using assms[THEN j_le_\<ff>_le] \<ff>_Suc assms
  by (metis One_nat_def Suc_pred le_SucI not_gr_zero trans_le_add2)

lemma border_take_\<ff>: "border (take (\<ff> s i - 1) s ) (take i s)"
  apply (cases i, simp_all)
  by (metis intrinsic_borderI' border_order.eq_iff border_order.less_imp_le border_positions nat.simps(3) nat_le_linear positions_border take_all take_eq_Nil take_length_ib zero_less_Suc)

corollary \<ff>_strict_borderI: "y = \<ff> s (i-1) \<Longrightarrow> strict_border (take (i-1) s) (take (j-1) s) \<Longrightarrow> strict_border (take (y-1) s) (take (j-1) s)"
  using border_order.less_le_not_le border_order.order.trans border_take_\<ff> by blast

corollary strict_border_take_\<ff>: "0 < i \<Longrightarrow> i \<le> length s \<Longrightarrow> strict_border (take (\<ff> s i - 1) s ) (take i s)"
  by (meson border_order.less_le_not_le border_take_\<ff> border_take_lengths j_le_\<ff>_le' leD)

lemma \<ff>_is_max: "j \<le> length s \<Longrightarrow> strict_border b (take j s) \<Longrightarrow> \<ff> s j \<ge> length b + 1"
  by (metis \<ff>.elims add_le_cancel_right add_less_same_cancel2 border_length_r_less intrinsic_border_max length_take min_absorb2 not_add_less2)

theorem skipping_ok:
  assumes j_bounds[simp]: "1 < j" "j \<le> length s"
    and mismatch: "s!(i-1) \<noteq> s!(j-1)"
    and greater_checked: "\<ff> s j \<le> i + 1"
    and "strict_border (take (i-1) s) (take (j-1) s)"
  shows "\<ff> s j \<le> \<ff> s (i-1) + 1"
proof (rule ccontr)
  assume "\<not>\<ff> s j \<le> \<ff> s (i-1) + 1"
  then have i_bounds: "0 < i" "i \<le> length s"
    using greater_checked assms(5) take_Nil by fastforce+
  then have i_less_j: "i < j"
    using assms(5) border_length_r_less nz_le_conv_less by auto
  from \<open>\<not>\<ff> s j \<le> \<ff> s (i-1) + 1\<close> greater_checked consider
    (tested) "\<ff> s j = i + 1" \<comment> \<open>This contradicts @{thm mismatch}\<close> |
    (skipped) "\<ff> s (i-1) + 1 < \<ff> s j" "\<ff> s j \<le> i"
      \<comment> \<open>This contradicts @{thm \<ff>_is_max[of "i-1" s]}\<close>
    by linarith
  then show False
  proof cases
    case tested
    then have "\<ff> s j - 1 = i" by simp
    moreover note border_positions[OF border_take_\<ff>[of s j, unfolded this]]
    ultimately have "take j s ! (i-1) = s!(j-1)" using i_bounds i_less_j by simp
    with \<open>i < j\<close> have "s!(i-1) = s!(j-1)"
      by (simp add: less_imp_diff_less)
    with mismatch show False..
  next
    case skipped
    let ?border = "take (i-1) s"
      \<comment> \<open>This border of @{term \<open>take (j-1) s\<close>} could not be extended to a border of @{term \<open>take j s\<close>} due to the mismatch.\<close>
    let ?impossible = "take (\<ff> s j - 2) s"
      \<comment> \<open>A strict border longer than @{term \<open>intrinsic_border ?border\<close>}, a contradiction.\<close>
    have "length (take j s) = j"
      by simp
    have "\<ff> s j - 2 < i - 1"
      using skipped by linarith
    then have less_s: "\<ff> s j - 2 < length s" "i - 1 < length s"
      using \<open>i < j\<close> j_bounds(2) by linarith+
    then have strict: "length ?impossible < length ?border"
      using \<open>\<ff> s j - 2 < i - 1\<close> by auto
    moreover {
      have "prefix ?impossible (take j s)"
        using prefix_length_prefix take_is_prefix
        by (metis (no_types, lifting) \<open>length (take j s) = j\<close> j_bounds(2) diff_le_self j_le_\<ff>_le length_take less_s(1) min_simps(2) order_trans)
      moreover have "prefix ?border (take j s)"
        by (metis (no_types, lifting) \<open>length (take j s) = j\<close> diff_le_self i_less_j le_trans length_take less_or_eq_imp_le less_s(2) min_simps(2) prefix_length_prefix take_is_prefix)
      ultimately have "prefix ?impossible ?border"
        using strict less_imp_le_nat prefix_length_prefix by blast
    } moreover {
      have "suffix (take (\<ff> s j - 1) s) (take j s)" using border_take_\<ff>
        by (auto simp: border_def)
      note suffix_butlast[OF this]
      then have "suffix ?impossible (take (j-1) s)"
        by (metis One_nat_def j_bounds(2) butlast_take diff_diff_left \<ff>_le len_greater_imp_nonempty less_or_eq_imp_le less_s(2) one_add_one)
      then have "suffix ?impossible (take (j-1) s)" "suffix ?border (take (j-1) s)"
        using assms(5) by auto
      from suffix_length_suffix[OF this strict[THEN less_imp_le]]
        have "suffix ?impossible ?border".
    }
    ultimately have "strict_border ?impossible ?border"
      unfolding strict_border_def[unfolded border_def] by blast
    note \<ff>_is_max[of "i-1" s, OF _ this]
    then have "length (take (\<ff> s j - 2) s) + 1 \<le> \<ff> s (i-1)"
      using less_imp_le_nat less_s(2) by blast
    then have "\<ff> s j - 1 \<le> \<ff> s (i-1)"
      by (simp add: less_s(1))
    then have "\<ff> s j \<le> \<ff> s (i-1) + 1"
      using le_diff_conv by blast
    with skipped(1) show False
      by linarith
  qed
qed

lemma extend_border:
  assumes "j \<le> length s"
  assumes "s!(i-1) = s!(j-1)"
  assumes "strict_border (take (i-1) s) (take (j-1) s)"
  assumes "\<ff> s j \<le> i + 1"
  shows "\<ff> s j = i + 1"
proof -
  from assms(3) have pos_in_range: "i - 1 < length s " "length (take (i-1) s) = i - 1"
    using border_length_r_less min_less_iff_conj by auto
  with strict_border_step[THEN iffD1, OF assms(3)] have "strict_border (take (i-1) s @ [s!(i-1)]) (take (j-1) s @ [s!(i-1)])"
    by (metis assms(3) border_length_r_less length_take min_less_iff_conj nth_take)
  with pos_in_range have "strict_border (take i s) (take (j-1) s @ [s!(i-1)])"
    by (metis Suc_eq_plus1 Suc_pred add.left_neutral border_bot.bot.not_eq_extremum border_order.less_asym neq0_conv take_0 take_Suc_conv_app_nth)
  then have "strict_border (take i s) (take (j-1) s @ [s!(j-1)])"
    by (simp only: \<open>s!(i-1) = s!(j-1)\<close>)
  then have "strict_border (take i s) (take j s)"
    by (metis One_nat_def Suc_pred assms(1,3) diff_le_self less_le_trans neq0_conv nz_le_conv_less strict_border_imp_nonempty take_Suc_conv_app_nth take_eq_Nil)
  with \<ff>_is_max[OF assms(1) this] have "\<ff> s j \<ge> i + 1"
    using Suc_leI by fastforce
  with \<open>\<ff> s j \<le> i + 1\<close> show ?thesis
    using le_antisym by presburger
qed

lemma compute_\<ff>s_correct: "compute_\<ff>s s \<le> compute_\<ff>s_SPEC s"
  unfolding compute_\<ff>s_SPEC_def compute_\<ff>s_def I_out_cb_def I_in_cb_def
  apply (simp, refine_vcg
    WHILEIT_rule[where R="measure (\<lambda>(\<ff>s,i,j). length s + 1 - j)"]
    WHILEIT_rule[where R="measure id"] \<comment> \<open>@{term \<open>i::nat\<close>} decreases with every iteration.\<close>
    )
  apply (clarsimp_all, fold One_nat_def)
  subgoal for b j by (rule strict_border_take_\<ff>, auto)
  subgoal by (metis Suc_eq_plus1 \<ff>_step_bound less_Suc_eq_le)
  subgoal by fastforce
  subgoal
    by (metis (no_types, lifting) One_nat_def Suc_lessD Suc_pred border_length_r_less \<ff>_strict_borderI length_take less_Suc_eq less_Suc_eq_le min.absorb2)
  subgoal for b j i
    by (metis (no_types, lifting) One_nat_def Suc_diff_1 Suc_eq_plus1 Suc_leI border_take_lengths less_Suc_eq_le less_antisym skipping_ok strict_border_def)
  subgoal by (metis Suc_diff_1 border_take_lengths j_le_\<ff>_le less_Suc_eq_le strict_border_def)
  subgoal by (metis Suc_eq_plus1 \<ff>_le border_order.less_irrefl diff_Suc_1 extend_border less_SucI less_Suc_eq_le take_Nil zero_less_Suc)
  subgoal for b j i jj
    by (metis Suc_eq_plus1 Suc_eq_plus1_left add.right_neutral extend_border \<ff>_eq_0_iff_j_eq_0 j_le_\<ff>_le le_zero_eq less_Suc_eq less_Suc_eq_le nth_list_update_eq nth_list_update_neq)
  subgoal by linarith
  done

subsubsection\<open>Index shift\<close>
text\<open>To avoid inefficiencies, we refine @{const compute_\<ff>s} to take @{term s}
instead of @{term \<open>butlast s\<close>} (it still only uses @{term \<open>butlast s\<close>}).\<close>
definition compute_butlast_\<ff>s :: "'a list \<Rightarrow> nat list nres" where
  "compute_butlast_\<ff>s s = do {
  let \<ff>s=replicate (length s) 0;
  let i=0;
  let j=1;
  (\<ff>s,_,_) \<leftarrow> WHILEIT (I_out_cb (butlast s)) (\<lambda>(b,i,j). j < length b) (\<lambda>(\<ff>s,i,j). do {
    ASSERT (1\<le>j \<and> j < length \<ff>s);
    i \<leftarrow> WHILEIT (I_in_cb (butlast s) j) (\<lambda>i. i>0 \<and> s!(i-1) \<noteq> s!(j-1)) (\<lambda>i. do {
      ASSERT (1\<le>i \<and> i-1 < length \<ff>s);
      let i=\<ff>s!(i-1);
      RETURN i
    }) i;
    ASSERT (length \<ff>s = length s);
    ASSERT (i < length \<ff>s);
    let i=i+1;
    ASSERT (j < length \<ff>s);
    let \<ff>s=\<ff>s[j:=i];
    let j=j+1;
    RETURN (\<ff>s,i,j)
  }) (\<ff>s,i,j);

  RETURN \<ff>s
}"

lemma compute_\<ff>s_inner_bounds:
  assumes "I_out_cb s (\<ff>s,ix,j)"
  assumes "j < length \<ff>s"
  assumes "I_in_cb s j i"
  shows "1\<le>j" "i-1 < length s" "j-1 < length s"
  using assms by (auto simp: I_out_cb_def I_in_cb_def split: if_splits)

lemma compute_butlast_\<ff>s_refine[refine]:
  assumes "(s,s') \<in> br butlast ((\<noteq>) [])"
  shows "compute_butlast_\<ff>s s \<le> \<Down> Id (compute_\<ff>s_SPEC s')"
proof -
  have "compute_butlast_\<ff>s s \<le> \<Down> Id (compute_\<ff>s s')"
    unfolding compute_butlast_\<ff>s_def compute_\<ff>s_def
    apply (refine_rcg)
              apply (refine_dref_type)
    using assms apply (clarsimp_all simp: in_br_conv)
     apply (metis Suc_pred length_greater_0_conv replicate_Suc)
     apply (simp add: I_out_cb_def)
     apply (metis One_nat_def compute_\<ff>s_inner_bounds(2-) nth_butlast)
     apply (simp add: I_out_cb_def)
     done

  also note compute_\<ff>s_correct
  finally show ?thesis by simp
qed

subsection\<open>Conflation\<close>
text\<open>We replace @{const compute_\<ff>s_SPEC} with @{const compute_butlast_\<ff>s}\<close>
definition "kmp2 s t \<equiv> do {
  ASSERT (s \<noteq> []);
  let i=0;
  let j=0;
  let pos=None;
  \<ff>s \<leftarrow> compute_butlast_\<ff>s s;
  ASSERT (length \<ff>s = length s);
  (_,_,pos) \<leftarrow> monadic_WHILEIT (I_outer s t)
    (\<lambda>(i,j,pos). do { ASSERT(i\<le>length t); RETURN (i + length s \<le> length t \<and> pos=None)} )
    (\<lambda>(i,j,pos). do {
      ASSERT (i + length s \<le> length t \<and> pos=None);
      (j,pos) \<leftarrow> monadic_WHILEIT (I_in_na s t i)
        (\<lambda>(j,pos). do { ASSERT(pos=None \<longrightarrow> i+j<length t \<and> j<length s); RETURN (pos=None \<and> t!(i+j) = s!j) })
        (\<lambda>(j,pos). do {
          ASSERT (j<length s);
          let j=j+1;
          if j=length s then RETURN (j,Some i) else RETURN (j,None)
        }) (j,pos);
      if pos=None then do {
        ASSERT (j < length \<ff>s \<and> \<ff>s!j \<le> j);
        let i = i + (j - \<ff>s!j + 1);
        let j = op_nat_sub_ovf (\<ff>s!j) 1; \<comment> \<open>Explicitly select 0-saturating subtraction\<close>
        RETURN (i,j,None)
      } else RETURN (i,j,Some i)
    }) (i,j,pos);

  RETURN pos
}"

text\<open>Using @{thm [source] compute_butlast_\<ff>s_refine} (it has attribute @{attribute refine}), the proof is trivial:\<close>
lemma kmp2_refine: "kmp2 s t \<le> kmp1 s t"
  apply (rule refine_IdD)
  unfolding kmp2_def kmp1_def
  apply refine_rcg
                  apply refine_dref_type
                  apply (auto simp: in_br_conv I_outer_def I_in_na_def split: option.splits)
  done

lemma kmp2_correct: "s \<noteq> []
  \<Longrightarrow> kmp2 s t \<le> kmp_SPEC s t"
proof -
  assume "s \<noteq> []"
  have "kmp2 s t \<le> kmp1 s t" by (fact kmp2_refine)
  also have "... \<le> kmp s t" by (fact kmp1_refine)
  also have "... \<le> kmp_SPEC s t" by (fact kmp_correct[OF \<open>s \<noteq> []\<close>])
  finally show ?thesis.
qed

text\<open>For convenience, we also remove the precondition:\<close>
definition "kmp3 s t \<equiv> do {
  if s=[] then RETURN (Some 0) else kmp2 s t
}"

lemma kmp3_correct: "kmp3 s t \<le> kmp_SPEC s t"
  unfolding kmp3_def by (simp add: kmp2_correct) (simp add: kmp_SPEC_def)

section \<open>Refinement to Imperative/HOL\<close>

(* TODO: Use monadic_WHILEIT also in compute_\<ff>s *)
lemmas in_bounds_aux = compute_\<ff>s_inner_bounds[of "butlast s" for s, simplified]

subsection \<open>Setup\<close>
text \<open>We fix a 64 bit type for string positions,
  and an 8 bit type for string content (characters)
\<close>

type_synonym size_t = 64
abbreviation "size_t_assn \<equiv> snat_assn' TYPE(size_t)"

abbreviation word_assn' :: "'a::len itself \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> llvm_amemory \<Rightarrow> bool" where "word_assn' _ \<equiv> word_assn"
abbreviation "char_assn \<equiv> word_assn' TYPE(8)"

text \<open>A string is represented as array with length value\<close>
abbreviation "string_assn \<equiv> larray_assn' TYPE(size_t) char_assn"

text \<open>Also the lookup table is represented as array with length value.\<close>
(* TODO: Do we ever need length of lookup table?
  We do, but could easily change algorithm such that it does not lookup this length!
*)
abbreviation "tab_assn \<equiv> larray_assn' TYPE(size_t) size_t_assn"
(*abbreviation "tab_assn \<equiv> array_assn size_t_assn" *)

subsection \<open>Refinement of Lookup Table Computation\<close>
sepref_definition compute_butlast_\<ff>s_impl is compute_butlast_\<ff>s
  :: "[\<lambda>s. length s < max_snat LENGTH(size_t)]\<^sub>a (string_assn)\<^sup>k \<rightarrow> tab_assn"
  unfolding compute_butlast_\<ff>s_def
  apply (rewrite in "WHILEIT _ \<hole>" short_circuit_conv)+
  supply [[goals_limit = 1]]
  apply (annot_snat_const "TYPE(size_t)")
  apply (rewrite larray.fold_replicate_init)
  supply in_bounds_aux[dest]
  apply sepref
  done

(*prepare_code_thms (LLVM) [llvm_code] compute_butlast_\<ff>s_impl_def*)
declare compute_butlast_\<ff>s_impl_def[llvm_code]

llvm_deps compute_butlast_\<ff>s_impl
export_llvm compute_butlast_\<ff>s_impl is "KMP_compute_table"

declare compute_butlast_\<ff>s_impl.refine[sepref_fr_rules]

sepref_register compute_\<ff>s

subsection \<open>Refinement of Main Algorithm\<close>

abbreviation "result_assn \<equiv> snat_option_assn' TYPE(size_t)"

sepref_definition kmp_impl is "uncurry kmp3"
  :: "[\<lambda>(s,t). length s + length t < max_snat LENGTH(size_t) ]\<^sub>a
      (string_assn)\<^sup>k *\<^sub>a (string_assn)\<^sup>k \<rightarrow> result_assn"
  unfolding kmp3_def kmp2_def
  apply (rewrite in "RETURN \<hole>" in "monadic_WHILEIT (I_in_na _ _ _) \<hole>" short_circuit_conv)
  supply [[goals_limit = 3]]
  apply (annot_snat_const "TYPE(size_t)")

  apply sepref_dbg_keep
  done

(*prepare_code_thms (LLVM) [llvm_code] kmp_impl_def*)
declare kmp_impl_def[llvm_code]

export_llvm
  compute_butlast_\<ff>s_impl is "kmp_compute_table"
  kmp_impl is "kmp"
  file "code/kmp.ll"

section \<open>Overall Correctness Theorem\<close>

lemmas kmp_impl_correct' = kmp_impl.refine[FCOMP kmp3_correct']

text \<open>The following theorem relates the final Imperative HOL algorithm to its specification,
  using, beyond basic HOL concepts
    \<^item> Hoare triples for LLVM;
    \<^item> The assertion @{const larray_assn} to specify array-lists, which we use to represent the input strings of the algorithm;
    \<^item> The @{const sublist_at} function that we defined in section \ref{sec:spec}.
  \<close>

theorem kmp_impl_correct:
  "llvm_htriple
    (larray_assn id_assn s si ** larray_assn id_assn t ti ** \<up>(length s + length t < max_snat 64))
    (kmp_impl si ti)
    (\<lambda>i. larray_assn id_assn s si ** larray_assn id_assn t ti
      ** \<up>(if i=-1 then \<nexists>i. sublist_at s t i
          else i\<ge>0 \<and> sublist_at s t (unat i) \<and> (\<forall>ii<unat i. \<not> sublist_at s t ii)))
    "
proof -
  have 1: "snat_option_assn' TYPE(size_t) a c = \<up>(if c=-1 then a = None else a = Some (unat c) \<and> snat_invar c)" for a c
    unfolding snat.option_assn_def
    unfolding snat_rel_def pure_def snat.rel_def in_br_conv
    by (auto simp: pred_lift_extract_simps snat_eq_unat)

  note R = kmp_impl_correct'[THEN hfrefD, THEN hn_refineD, of "(s,t)" "(si,ti)", simplified]
  note R = R[unfolded kmp_SPEC_def 1, simplified]
  note [vcg_rules] = R

  show ?thesis
   apply vcg'
   done

qed

thm hnr_bind[of \<Gamma> m\<^sub>i \<Gamma>\<^sub>1 R\<^sub>1 m f\<^sub>i \<Gamma>\<^sub>2 R\<^sub>2 f R\<^sub>x \<Gamma>' free]

thm kmp_impl_def

end


(* Author: Tobias Nipkow *)

section \<open>Red-Black Tree Implementation of Sets\<close>

theory RBT_Set
imports
  Complex_Main
  RBT
  Cmp
  Isin2
begin

definition empty :: "'a rbt" where
"empty = Leaf"

fun ins :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"ins x Leaf = R Leaf x Leaf" |
"ins x (B l a r) =
  (case cmp x a of
     LT \<Rightarrow> baliL (ins x l) a r |
     GT \<Rightarrow> baliR l a (ins x r) |
     EQ \<Rightarrow> B l a r)" |
"ins x (R l a r) =
  (case cmp x a of
    LT \<Rightarrow> R (ins x l) a r |
    GT \<Rightarrow> R l a (ins x r) |
    EQ \<Rightarrow> R l a r)"

definition insert :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"insert x t = paint Black (ins x t)"

fun color :: "'a rbt \<Rightarrow> color" where
"color Leaf = Black" |
"color (Node _ (_, c) _) = c"

fun del :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"del x Leaf = Leaf" |
"del x (Node l (a, _) r) =
  (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) a r else R (del x l) a r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l a (del x r) else R l a (del x r) |
     EQ \<Rightarrow> join l r)"

definition delete :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"delete x t = paint Black (del x t)"

subsection "Functional Correctness Proofs"

lemma inorder_paint: "inorder(paint c t) = inorder t"
by(cases t) (auto)

lemma inorder_baliL:
  "inorder(baliL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma inorder_baliR:
  "inorder(baliR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma inorder_ins:
  "sorted(inorder t) \<Longrightarrow> inorder(ins x t) = ins_list x (inorder t)"
by(induction x t rule: ins.induct)
  (auto simp: ins_list_simps inorder_baliL inorder_baliR)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by (simp add: insert_def inorder_ins inorder_paint)

lemma inorder_baldL:
  "inorder(baldL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldL.cases)
  (auto simp:  inorder_baliL inorder_baliR inorder_paint)

lemma inorder_baldR:
  "inorder(baldR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldR.cases)
  (auto simp:  inorder_baliL inorder_baliR inorder_paint)

lemma inorder_join:
  "inorder(join l r) = inorder l @ inorder r"
by(induction l r rule: join.induct)
  (auto simp: inorder_baldL inorder_baldR split: tree.split color.split)

lemma inorder_del:
 "sorted(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
by(induction x t rule: del.induct)
  (auto simp: del_list_simps inorder_join inorder_baldL inorder_baldR)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by (auto simp: delete_def inorder_del inorder_paint)

subsection \<open>Structural invariants\<close>

lemma neq_Black[simp]: "(c \<noteq> Black) = (c = Red)"
by (cases c) auto

text\<open>The proofs are due to Markus Reiter and Alexander Krauss.\<close>

fun bheight :: "'a rbt \<Rightarrow> nat" where
"bheight Leaf = 0" |
"bheight (Node l (x, c) r) = (if c = Black then bheight l + 1 else bheight l)"

fun invc :: "'a rbt \<Rightarrow> bool" where
"invc Leaf = True" |
"invc (Node l (a,c) r) =
  ((c = Red \<longrightarrow> color l = Black \<and> color r = Black) \<and> invc l \<and> invc r)"

text \<open>Weaker version:\<close>
abbreviation invc2 :: "'a rbt \<Rightarrow> bool" where
"invc2 t \<equiv> invc(paint Black t)"

fun invh :: "'a rbt \<Rightarrow> bool" where
"invh Leaf = True" |
"invh (Node l (x, c) r) = (bheight l = bheight r \<and> invh l \<and> invh r)"

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
by (cases t rule: tree2_cases) simp+

definition rbt :: "'a rbt \<Rightarrow> bool" where
"rbt t = (invc t \<and> invh t \<and> color t = Black)"

lemma color_paint_Black: "color (paint Black t) = Black"
by (cases t) auto

lemma paint2: "paint c2 (paint c1 t) = paint c2 t"
by (cases t) auto

lemma invh_paint: "invh t \<Longrightarrow> invh (paint c t)"
by (cases t) auto

lemma invc_baliL:
  "\<lbrakk>invc2 l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invc_baliR:
  "\<lbrakk>invc l; invc2 r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

lemma bheight_baliL:
  "bheight l = bheight r \<Longrightarrow> bheight (baliL l a r) = Suc (bheight l)"
by (induct l a r rule: baliL.induct) auto

lemma bheight_baliR:
  "bheight l = bheight r \<Longrightarrow> bheight (baliR l a r) = Suc (bheight l)"
by (induct l a r rule: baliR.induct) auto

lemma invh_baliL:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invh_baliR:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

text \<open>All in one:\<close>

lemma inv_baliR: "\<lbrakk> invh l; invh r; invc l; invc2 r; bheight l = bheight r \<rbrakk>
 \<Longrightarrow> invc (baliR l a r) \<and> invh (baliR l a r) \<and> bheight (baliR l a r) = Suc (bheight l)"
by (induct l a r rule: baliR.induct) auto

lemma inv_baliL: "\<lbrakk> invh l; invh r; invc2 l; invc r; bheight l = bheight r \<rbrakk>
 \<Longrightarrow> invc (baliL l a r) \<and> invh (baliL l a r) \<and> bheight (baliL l a r) = Suc (bheight l)"
by (induct l a r rule: baliL.induct) auto

subsubsection \<open>Insertion\<close>

lemma invc_ins: "invc t \<longrightarrow> invc2 (ins x t) \<and> (color t = Black \<longrightarrow> invc (ins x t))"
by (induct x t rule: ins.induct) (auto simp: invc_baliL invc_baliR invc2I)

lemma invh_ins: "invh t \<Longrightarrow> invh (ins x t) \<and> bheight (ins x t) = bheight t"
by(induct x t rule: ins.induct)
  (auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

theorem rbt_insert: "rbt t \<Longrightarrow> rbt (insert x t)"
by (simp add: invc_ins invh_ins color_paint_Black invh_paint rbt_def insert_def)

text \<open>All in one:\<close>

lemma inv_ins: "\<lbrakk> invc t; invh t \<rbrakk> \<Longrightarrow>
  invc2 (ins x t) \<and> (color t = Black \<longrightarrow> invc (ins x t)) \<and>
  invh(ins x t) \<and> bheight (ins x t) = bheight t"
by (induct x t rule: ins.induct) (auto simp: inv_baliL inv_baliR invc2I)

theorem rbt_insert2: "rbt t \<Longrightarrow> rbt (insert x t)"
by (simp add: inv_ins color_paint_Black invh_paint rbt_def insert_def)

subsubsection \<open>Deletion\<close>

lemma bheight_paint_Red:
  "color t = Black \<Longrightarrow> bheight (paint Red t) = bheight t - 1"
by (cases t) auto

lemma invh_baldL_invc:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
by (induct l a r rule: baldL.induct)
   (auto simp: invh_baliR invh_paint bheight_baliR bheight_paint_Red)

lemma invh_baldL_Black:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  color r = Black \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
by (induct l a r rule: baldL.induct) (auto simp add: invh_baliR bheight_baliR)

lemma invc_baldL: "\<lbrakk>invc2 l; invc r; color r = Black\<rbrakk> \<Longrightarrow> invc (baldL l a r)"
by (induct l a r rule: baldL.induct) (simp_all add: invc_baliR)

lemma invc2_baldL: "\<lbrakk> invc2 l; invc r \<rbrakk> \<Longrightarrow> invc2 (baldL l a r)"
by (induct l a r rule: baldL.induct) (auto simp: invc_baliR paint2 invc2I)

lemma invh_baldR_invc:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1;  invc l \<rbrakk>
  \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l"
by(induct l a r rule: baldR.induct)
  (auto simp: invh_baliL bheight_baliL invh_paint bheight_paint_Red)

lemma invc_baldR: "\<lbrakk>invc l; invc2 r; color l = Black\<rbrakk> \<Longrightarrow> invc (baldR l a r)"
by (induct l a r rule: baldR.induct) (simp_all add: invc_baliL)

lemma invc2_baldR: "\<lbrakk> invc l; invc2 r \<rbrakk> \<Longrightarrow>invc2 (baldR l a r)"
by (induct l a r rule: baldR.induct) (auto simp: invc_baliL paint2 invc2I)

lemma invh_join:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk>
  \<Longrightarrow> invh (join l r) \<and> bheight (join l r) = bheight l"
by (induct l r rule: join.induct)
   (auto simp: invh_baldL_Black split: tree.splits color.splits)

lemma invc_join:
  "\<lbrakk> invc l; invc r \<rbrakk> \<Longrightarrow>
  (color l = Black \<and> color r = Black \<longrightarrow> invc (join l r)) \<and> invc2 (join l r)"
by (induct l r rule: join.induct)
   (auto simp: invc_baldL invc2I split: tree.splits color.splits)

text \<open>All in one:\<close>

lemma inv_baldL:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r; invc2 l; invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r
  \<and> invc2 (baldL l a r) \<and> (color r = Black \<longrightarrow> invc (baldL l a r))"
by (induct l a r rule: baldL.induct)
   (auto simp: inv_baliR invh_paint bheight_baliR bheight_paint_Red paint2 invc2I)

lemma inv_baldR:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1; invc l; invc2 r \<rbrakk>
   \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l
  \<and> invc2 (baldR l a r) \<and> (color l = Black \<longrightarrow> invc (baldR l a r))"
by (induct l a r rule: baldR.induct)
   (auto simp: inv_baliL invh_paint bheight_baliL bheight_paint_Red paint2 invc2I)

lemma inv_join:
  "\<lbrakk> invh l; invh r; bheight l = bheight r; invc l; invc r \<rbrakk>
  \<Longrightarrow> invh (join l r) \<and> bheight (join l r) = bheight l
  \<and> invc2 (join l r) \<and> (color l = Black \<and> color r = Black \<longrightarrow> invc (join l r))"
by (induct l r rule: join.induct)
   (auto simp: invh_baldL_Black inv_baldL invc2I split: tree.splits color.splits)

lemma neq_LeafD: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x c r. t = Node l (x,c) r"
by(cases t rule: tree2_cases) auto

lemma inv_del: "\<lbrakk> invh t; invc t \<rbrakk> \<Longrightarrow>
   invh (del x t) \<and>
   (color t = Red \<longrightarrow> bheight (del x t) = bheight t \<and> invc (del x t)) \<and>
   (color t = Black \<longrightarrow> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
by(induct x t rule: del.induct)
  (auto simp: inv_baldL inv_baldR inv_join dest!: neq_LeafD)

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete x t)"
by (metis delete_def rbt_def color_paint_Black inv_del invh_paint)

text \<open>Overall correctness:\<close>

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = rbt
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp add: rbt_def empty_def)
next
  case 6 thus ?case by (simp add: rbt_insert)
next
  case 7 thus ?case by (simp add: rbt_delete)
qed

subsection \<open>Height-Size Relation\<close>

lemma rbt_height_bheight_if: "invc t \<Longrightarrow> invh t \<Longrightarrow>
  height t \<le> 2 * bheight t + (if color t = Black then 0 else 1)"
by(induction t) (auto split: if_split_asm)

lemma rbt_height_bheight: "rbt t \<Longrightarrow> height t / 2 \<le> bheight t "
by(auto simp: rbt_def dest: rbt_height_bheight_if)

lemma bheight_size_bound:  "invc t \<Longrightarrow> invh t \<Longrightarrow> 2 ^ (bheight t) \<le> size1 t"
by (induction t) auto

lemma rbt_height_le: assumes "rbt t" shows "height t \<le> 2 * log 2 (size1 t)"
proof -
  have "2 powr (height t / 2) \<le> 2 powr bheight t"
    using rbt_height_bheight[OF assms] by (simp)
  also have "\<dots> \<le> size1 t" using assms
    by (simp add: powr_realpow bheight_size_bound rbt_def)
  finally have "2 powr (height t / 2) \<le> size1 t" .
  hence "height t / 2 \<le> log 2 (size1 t)"
    by (simp add: le_log_iff size1_size del: divide_le_eq_numeral1(1))
  thus ?thesis by simp
qed

end


theory Peterson
imports Main
begin

text {*
The Peterson mutual exclusion algorithm (for 2 processes numbered 0 and 1). Code for process i:
while (true)
  v1: idle_i = false
  v2: turn = (i+1) mod 2
  v3: await idle_[(i+1) mod 2] or turn = i
  v4: critical section
  v5: idle_i = true *}

section {* Specification of the algorithm *}

typedecl State
  -- "The state of the system"

type_synonym 'a StateFun = "State \<Rightarrow> 'a"
-- "The type of variables"

datatype label1 = p1_l1 | p1_l2 | p1_l3 | p1_l4
datatype label2 = p2_l1 | p2_l2 | p2_l3 | p2_l4

datatype Proc = P1 | P2

(*The variables*)
consts
  pc1       ::       "label1 StateFun"
  pc2       ::       "label2 StateFun"
  flag1     ::       "bool StateFun"
  flag2     ::       "bool StateFun"
  turn      ::       "Proc StateFun"

definition unchanged :: "('a StateFun) \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool" where
  "unchanged \<equiv> \<lambda> fun s s' . fun s = fun s'"

definition transition :: "(State \<times> State) set" where
  "transition \<equiv>
      {(s,s').
        (pc1 s = p1_l1 \<and> pc1 s' = p1_l2 \<and> flag1 s' = True \<and> unchanged (\<lambda> s . (pc2 s, flag2 s, turn s)) s s')
        \<or>(pc1 s = p1_l2 \<and> pc1 s' = p1_l3 \<and> turn s' = P2  \<and> unchanged (\<lambda> s .(pc2 s, flag1 s, flag2 s)) s s')
        \<or>(pc1 s = p1_l3 \<and> pc1 s' = p1_l4 \<and> (flag2 s = False \<or> turn s = P1)  \<and> unchanged (\<lambda> s . (pc2 s, flag1 s, flag2 s, turn s)) s s')
        \<or>(pc1 s = p1_l4 \<and> pc1 s' = p1_l1 \<and> flag1 s' = False  \<and> unchanged (\<lambda> s . (pc2 s, flag1 s, flag2 s, turn s)) s s')

        \<or>(pc2 s = p2_l1 \<and> pc2 s' = p2_l2 \<and> flag2 s' = True \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, turn s)) s s')
        \<or>(pc2 s = p2_l2 \<and> pc2 s' = p2_l3 \<and> turn s' = P1 \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, flag2 s)) s s')
        \<or>(pc2 s = p2_l3 \<and> pc2 s' = p2_l4 \<and> (flag1 s = False \<or> turn s = P2) \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, flag2 s, turn s)) s s')
        \<or>(pc2 s = p2_l4 \<and> pc2 s' = p2_l1 \<and> flag2 s' = False \<and> unchanged (\<lambda> s . (pc1 s, flag1 s, turn s)) s s')
    }"

definition initial :: "State set" where
  "initial \<equiv> {s.
  pc1 s = p1_l1
  \<and> pc2 s = p2_l1
  \<and> flag1 s = False
  \<and> flag2 s = False
  \<and> turn s = P1}"

definition safe :: "State set" where
  -- "Definition of the safety property of the algorithm"
  "safe \<equiv> {s. \<not> (pc1 s = p1_l4 \<and> pc2 s = p2_l4) }"

section {*Safety proof*}

definition ind_inv :: "State set \<Rightarrow> bool" where
-- "The definition of an inductive state invariant"
  "ind_inv p \<equiv> initial \<subseteq> p \<and> (\<forall> s s'. (s : p \<and> (s,s') \<in> transition) \<longrightarrow> s' : p)"

subsection {* Four invariants that imply the safety property *}

definition inv1_p1 :: "State set" where
  "inv1_p1 \<equiv> {s. pc1 s : {p1_l2, p1_l3, p1_l4} \<longrightarrow> (flag1 s = True)}"

definition inv1_p2 :: "State set" where
  "inv1_p2 \<equiv> {s. pc2 s : {p2_l2, p2_l3, p2_l4} \<longrightarrow> (flag2 s = True)}"

definition inv2_p1 :: "State set" where
  "inv2_p1 \<equiv> {s. pc1 s = p1_l4 \<longrightarrow> (flag2 s = False \<or> turn s = P1 \<or> pc2 s = p2_l2)}"

definition inv2_p2 :: "State set" where
  "inv2_p2 \<equiv> {s. pc2 s = p2_l4 \<longrightarrow> (flag1 s = False \<or> turn s = P2 \<or> pc1 s = p1_l2)}"

lemma invariants_inductive: "ind_inv inv1_p1 \<and> ind_inv inv2_p2 \<and> ind_inv inv1_p2 \<and> ind_inv inv2_p1"
  -- "Proof that the invariants are inductive"
unfolding ind_inv_def initial_def inv1_p1_def inv1_p2_def inv2_p1_def inv2_p2_def transition_def unchanged_def
by auto

theorem safety: "inv1_p1 Int inv1_p2 Int inv2_p1 Int inv2_p2 \<subseteq> safe"
  -- "Proof that the invariants imply the safety property"
unfolding inv1_p1_def inv1_p2_def inv2_p1_def inv2_p2_def safe_def
by auto

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Surjective\<close>
theory SBinary_Relations_Surjective
  imports
    SBinary_Relation_Functions
begin

consts set_surjective_at :: "'a \<Rightarrow> set \<Rightarrow> bool"

overloading
  set_surjective_at_pred \<equiv> "set_surjective_at :: (set \<Rightarrow> bool) \<Rightarrow> set \<Rightarrow> bool"
  set_surjective_at_set \<equiv> "set_surjective_at :: set \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_surjective_at_pred P R \<equiv> \<forall>y. P y \<longrightarrow> y \<in> rng R"
  definition "set_surjective_at_set B R \<equiv> set_surjective_at (mem_of B) R"
end

lemma set_surjective_at_set_iff_set_surjective_at [iff]:
  "set_surjective_at B R \<longleftrightarrow> set_surjective_at (mem_of B) R"
  unfolding set_surjective_at_set_def by simp

lemma set_surjective_atI [intro]:
  assumes "\<And>y. P y \<Longrightarrow> y \<in> rng R"
  shows "set_surjective_at P R"
  unfolding set_surjective_at_pred_def using assms by blast

lemma set_surjective_atE [elim]:
  assumes "set_surjective_at P R"
  and "P y"
  obtains x where "\<langle>x, y\<rangle> \<in> R"
  using assms unfolding set_surjective_at_pred_def by blast

lemma antimono_set_surjective_at_pred:
  "antimono (\<lambda>P. set_surjective_at (P :: set \<Rightarrow> bool) R)"
  by (intro antimonoI) fastforce

lemma mono_set_surjective_at_set:
  "mono (\<lambda>R. set_surjective_at (P :: set \<Rightarrow> bool) R)"
  by (intro monoI) fastforce

lemma subset_rng_if_set_surjective_at [simp]:
  "set_surjective_at B R \<Longrightarrow> B \<subseteq> rng R"
  by auto

lemma set_surjective_at_compI:
  fixes P :: "set \<Rightarrow> bool"
  assumes surj_R: "set_surjective_at (dom S) R"
  and surj_S: "set_surjective_at P S"
  shows "set_surjective_at P (S \<circ> R)"
proof
  fix y assume "P y"
  then obtain x where "\<langle>x, y\<rangle> \<in> S" using surj_S by auto
  moreover then have "x \<in> dom S" by auto
  moreover then obtain z where "\<langle>z, x\<rangle> \<in> R" using surj_R by auto
  ultimately show "y \<in> rng (S \<circ> R)" by blast
qed

end


chapter \<open>Instantiating the Framework with a simple While-Language\<close>

section \<open>Commands\<close>

theory Com imports Main begin

subsection \<open>Variables and Values\<close>

type_synonym vname = string \<comment> \<open>names for variables\<close>

datatype val
  = Bool bool      \<comment> \<open>Boolean value\<close>
  | Intg int       \<comment> \<open>integer value\<close>

abbreviation "true == Bool True"
abbreviation "false == Bool False"

subsection \<open>Expressions and Commands\<close>

datatype bop = Eq | And | Less | Add | Sub     \<comment> \<open>names of binary operations\<close>

datatype expr
  = Val val                                          \<comment> \<open>value\<close>
  | Var vname                                        \<comment> \<open>local variable\<close>
  | BinOp expr bop expr    ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)  \<comment> \<open>binary operation\<close>

fun binop :: "bop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val option"
where "binop Eq v\<^sub>1 v\<^sub>2               = Some(Bool(v\<^sub>1 = v\<^sub>2))"
  | "binop And (Bool b\<^sub>1) (Bool b\<^sub>2)  = Some(Bool(b\<^sub>1 \<and> b\<^sub>2))"
  | "binop Less (Intg i\<^sub>1) (Intg i\<^sub>2) = Some(Bool(i\<^sub>1 < i\<^sub>2))"
  | "binop Add (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 + i\<^sub>2))"
  | "binop Sub (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 - i\<^sub>2))"
  | "binop bop v\<^sub>1 v\<^sub>2                = None"

datatype cmd
  = Skip
  | LAss vname expr        ("_:=_" [70,70] 70)  \<comment> \<open>local assignment\<close>
  | Seq cmd cmd            ("_;;/ _" [61,60] 60)
  | Cond expr cmd cmd      ("if '(_') _/ else _" [80,79,79] 70)
  | While expr cmd         ("while '(_') _" [80,79] 70)

fun num_inner_nodes :: "cmd \<Rightarrow> nat" ("#:_")
where "#:Skip              = 1"
  | "#:(V:=e)              = 2"       (* zusätzlicher Skip-Knoten *)
  | "#:(c\<^sub>1;;c\<^sub>2)            = #:c\<^sub>1 + #:c\<^sub>2"
  | "#:(if (b) c\<^sub>1 else c\<^sub>2) = #:c\<^sub>1 + #:c\<^sub>2 + 1"
  | "#:(while (b) c)       = #:c + 2" (* zusätzlicher Skip-Knoten *)

lemma num_inner_nodes_gr_0:"#:c > 0"
by(induct c) auto

lemma [dest]:"#:c = 0 \<Longrightarrow> False"
by(induct c) auto

subsection \<open>The state\<close>

type_synonym state = "vname \<rightharpoonup> val"

fun "interpret" :: "expr \<Rightarrow> state \<Rightarrow> val option"
where Val: "interpret (Val v) s = Some v"
  | Var: "interpret (Var V) s = s V"
  | BinOp: "interpret (e\<^sub>1\<guillemotleft>bop\<guillemotright>e\<^sub>2) s =
    (case interpret e\<^sub>1 s of None \<Rightarrow> None
                         | Some v\<^sub>1 \<Rightarrow> (case interpret e\<^sub>2 s of None \<Rightarrow> None
                                                           | Some v\<^sub>2 \<Rightarrow> (
      case binop bop v\<^sub>1 v\<^sub>2 of None \<Rightarrow> None | Some v \<Rightarrow> Some v)))"

end


(*  Title:      JinjaDCI/Common/Auxiliary.thy

    Author:     David von Oheimb, Tobias Nipkow, Susannah Mansky
    Copyright   1999 TU Muenchen, 2019-20 UIUC

    Based on the Jinja theory Common/Auxiliary.thy by David von Oheimb and Tobias Nipkow
*)

chapter \<open> Jinja Source Language \label{cha:j} \<close>

section \<open> Auxiliary Definitions \<close>

theory Auxiliary imports Main begin
(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
(*<*)by arith(*>*)

notation Some  ("(\<lfloor>_\<rfloor>)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]
(*>*)

subsection \<open>@{text distinct_fst}\<close>

definition distinct_fst  :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
(*>*)

lemma distinct_fst_appendD:
 "distinct_fst(kxs @ kxs') \<Longrightarrow> distinct_fst kxs \<and> distinct_fst kxs'"
(*<*)by(induct kxs, auto)(*>*)

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

subsection \<open> Using @{term list_all2} for relations \<close>

definition fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text \<open> Convenience lemmas \<close>
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

subsection \<open> Auxiliary properties of @{text "map_of"} function \<close>

lemma map_of_set_pcs_notin: "C \<notin> (\<lambda>t. snd (fst t)) ` set FDTs \<Longrightarrow> map_of FDTs (F, C) = None"
(*<*)by (metis image_eqI image_image map_of_eq_None_iff snd_conv)(*>*)

lemma map_of_insertmap_SomeD':
  "map_of fs F = Some y \<Longrightarrow> map_of (map (\<lambda>(F, y). (F, D, y)) fs) F = Some(D,y)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_neq_None:
  "Ca \<noteq> D \<Longrightarrow> map_of (map (\<lambda>(F, y). ((F, Ca), y)) fs) (F, D) = None"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remap_insertmap:
  "map_of (map ((\<lambda>((F, D), b, T). (F, D, b, T)) \<circ> (\<lambda>(F, y). ((F, D), y))) fs)
    = map_of (map (\<lambda>(F, y). (F, D, y)) fs)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_SomeD:
  "map_of (map (\<lambda>(F, y). ((F, D), y)) fs) (F, D) = Some T \<Longrightarrow> map_of fs F = Some T"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_filtered_SomeD:
"map_of fs (F,D) = Some (a, T) \<Longrightarrow> Q ((F,D),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). ((F,D), P T)) (filter Q fs))
        (F,D) = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remove_filtered_SomeD:
"map_of fs (F,C) = Some (a, T) \<Longrightarrow> Q ((F,C),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). (F, P T)) [((F, D), b, T)\<leftarrow>fs . Q ((F, D), b, T) \<and> D = C])
        F = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_Some_None_split:
assumes "t = map (\<lambda>(F, y). ((F, C), y)) fs @ t'" "map_of t' (F, C) = None" "map_of t (F, C) = Some y"
shows "map_of (map (\<lambda>((F, D), b, T). (F, D, b, T)) t) F = Some (C, y)"
(*<*)
proof -
  have "map_of (map (\<lambda>(F, y). ((F, C), y)) fs) (F, C) = Some y" using assms by auto
  then have "\<forall>p. map_of fs F = Some p \<or> Some y \<noteq> Some p"
    by (metis map_of_reinsert_SomeD)
  then have "\<forall>f b p pa. ((f ++ map_of (map (\<lambda>(a, p). (a, b::'b, p)) fs)) F = Some p \<or> Some (b, pa) \<noteq> Some p)
     \<or> Some y \<noteq> Some pa"
    by (metis (no_types) map_add_find_right map_of_insertmap_SomeD')
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
                     ++ map_of (map (\<lambda>(a, p). (a, C, p)) fs)) F = Some (C, y)"
    by blast
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
      ++ map_of (map ((\<lambda>((a, b), c, d). (a, b, c, d)) \<circ> (\<lambda>(a, y). ((a, C), y))) fs)) F = Some (C, y)"
    by (simp add: map_of_remap_insertmap)
  then show ?thesis using assms by auto
qed
(*>*)

end