header {* Address Graph  *}

theory Graph
imports Main
begin

text {*
This theory introduces the graph to be marked as a relation next on
nodes (addresses). We assume that we have a special node nil (the
null address). We have a node root from which we start marking the graph.
We also assume that nil is not related by next to any node and any node is
not related by next to nil.
 *}

locale node =
  fixes nil    :: "'node"
  fixes root   :: "'node"

locale graph = node +
  fixes "next" :: "('node \<times> 'node) set"
  assumes next_not_nil_left: "(!! x . (nil, x) \<notin> next)"
  assumes next_not_nil_right: "(!! x . (x, nil) \<notin> next)"
begin

text {*
On lists of nodes we introduce two operations similar to
existing hd and tl for getting the head and the tail of
a list. The new function head applied to a nonempty list
returns the head of the list, and it reurns nil when
applied to the empty list. The function tail returns the
tail of the list when applied to a non-empty list, and
it returns the empty list otherwise.
*}
  definition
    "head S \<equiv> (if S = [] then nil else (hd S))"

  definition
    "tail (S::'a list) \<equiv> (if S = [] then [] else (tl S))"

  theorem head_not_nil [simp]:
    "(head S \<noteq> nil) = (head S = hd S \<and> tail S = tl S \<and> hd S \<noteq> nil \<and> S \<noteq> [])"
    by (simp add: head_def tail_def)

  theorem nonempty_head [simp]:
    "head (x # S) = x"
    by (simp add: head_def)

  theorem nonempty_tail [simp]:
    "tail (x # S) = S"
    by (simp add: tail_def)

  definition (in graph)
    "reach x \<equiv> {y . (x, y) \<in> next\<^sup>* \<and> y \<noteq> nil}"

  theorem (in graph) reach_nil [simp]: "reach nil = {}"
    apply (simp add: reach_def, safe)
    apply (drule rtrancl_induct)
    by auto

  theorem (in graph)  reach_next: "b \<in> reach a \<Longrightarrow> (b, c) \<in> next \<Longrightarrow> c \<in> reach a"
    apply (simp add: reach_def)
    by auto

  definition (in graph)
    "path S mrk \<equiv> {x . (\<exists> s . s \<in> S \<and> (s, x) \<in> next O (next \<inter> ((-mrk)\<times>(-mrk)))\<^sup>* )}"
  end

end


(*<*)
theory SWA
  imports Main
begin
(*>*)

section \<open>Sliding Window Algorithm\<close>

datatype 'a tree =
  Leaf
| Node (l: nat) (r: nat) (val: "'a option") (lchild: "'a tree") (rchild: "'a tree")
where
  "l Leaf = 0"
| "r Leaf = 0"
| "val Leaf = None"
| "lchild Leaf = Leaf"
| "rchild Leaf = Leaf"

lemma neq_Leaf_if_l_gt0: "0 < l t \<Longrightarrow> t \<noteq> Leaf"
  by auto

primrec discharge :: "'a tree \<Rightarrow> 'a tree" where
  "discharge Leaf = Leaf"
| "discharge (Node i j _ t u) = Node i j None t u"

instantiation option :: (semigroup_add) semigroup_add begin

fun plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "plus_option None _ = None"
| "plus_option _ None = None"
| "plus_option (Some a) (Some b) = Some (a + b)"

instance proof
  fix a b c :: "'a option"
  show "a + b + c = a + (b + c)"
    by (induct a b rule: plus_option.induct; cases c)
      (auto simp: algebra_simps)
qed

end

fun combine :: "'a :: semigroup_add tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "combine t Leaf = t"
| "combine Leaf t = t"
| "combine t u = Node (l t) (r u) (val t + val u) (discharge t) u"

lemma combine_non_Leaves: "\<lbrakk>t \<noteq> Leaf; u \<noteq> Leaf\<rbrakk> \<Longrightarrow> combine t u = Node (l t) (r u) (val t + val u) (discharge t) u"
proof -
  assume assms: "t \<noteq> Leaf" "u \<noteq> Leaf"
  from assms have "combine t u = Node (l (Node (l t) (r t) (val t) (lchild t) (rchild t))) (r (Node (l u) (r u) (val u) (lchild u) (rchild u))) (val (Node (l t) (r t) (val t) (lchild t) (rchild t)) + val (Node (l u) (r u) (val u) (lchild u) (rchild u))) (discharge (Node (l t) (r t) (val t) (lchild t) (rchild t))) (Node (l u) (r u) (val u) (lchild u) (rchild u))"
    by (metis (no_types) combine.simps(3) tree.exhaust_sel)
  with assms show ?thesis
    by simp
qed

lemma r_combine_non_Leaves: "\<lbrakk>t \<noteq> Leaf; u \<noteq> Leaf\<rbrakk> \<Longrightarrow> r (combine t u) = r u"
  by (simp add: combine_non_Leaves)

type_synonym window = "nat \<times> nat"

definition window :: "'a list \<Rightarrow> window \<Rightarrow> bool" where
  "window as = (\<lambda>(l, r). 0 < l \<and> l \<le> r \<and> r \<le> length as)"

definition windows :: "'a list \<Rightarrow> window list \<Rightarrow> bool" where
  "windows as ws = ((\<forall>w \<in> set ws. window as w) \<and>
    sorted (map fst ws) \<and> sorted (map snd ws))"

function reusables :: "'a tree \<Rightarrow> window \<Rightarrow> 'a tree list" where
  "reusables t w = (if fst w > r t then [] else if fst w = l t then [t]
     else let v = lchild t; u = rchild t in if fst w \<ge> l u then
       reusables u w else u # reusables v w)"
  by auto
termination
  by (relation "measure (\<lambda>p. size (fst p))")
    (auto simp: lchild_def rchild_def split: tree.splits)

declare reusables.simps[simp del]

lemma reusables_Leaf[simp]: "0 < fst w \<Longrightarrow> reusables Leaf w = []"
  by (simp add: reusables.simps)

primrec well_shaped :: "'a tree \<Rightarrow> bool" where
  "well_shaped Leaf = True"
| "well_shaped (Node i j _ t u) = (i \<le> j \<and> (i = j \<longrightarrow> t = Leaf \<and> u = Leaf) \<and>
    (i < j \<longrightarrow> t \<noteq> Leaf \<and> u \<noteq> Leaf \<and> well_shaped t \<and> well_shaped u \<and>
      i = l t \<and> j = r u \<and> Suc (r t) = l u))"

lemma l_lchild_eq_l_if_well_shaped[simp]:
  "\<lbrakk>well_shaped t; l t < r t\<rbrakk> \<Longrightarrow> l (lchild t) = l t"
  by (induct t) auto

lemma r_rchild_eq_r_if_well_shaped[simp]:
  "\<lbrakk>well_shaped t; l t < r t\<rbrakk> \<Longrightarrow> r (rchild t) = r t"
  by (induct t) auto

lemma r_lchild_eq_l_rchild_if_well_shaped:
  "\<lbrakk>well_shaped t; l t < r t\<rbrakk> \<Longrightarrow> r (lchild t) = l (rchild t) - 1"
  by (induct t) auto

lemma r_lchild_le_r: "well_shaped t \<Longrightarrow> r (lchild t) \<le> r t"
proof (induct t)
  case (Node i j a t1 t2)
  then show ?case
    by auto
      (metis Suc_eq_plus1_left order.trans le_add2 tree.exhaust_sel well_shaped.simps(2))
qed simp

lemma well_shaped_lchild[simp]: "well_shaped t \<Longrightarrow> well_shaped (lchild t)"
  by (induct t) auto

lemma well_shaped_rchild[simp]: "well_shaped t \<Longrightarrow> well_shaped (rchild t)"
  by (induct t) auto

definition adjacent where
  "adjacent w ts = (Leaf \<notin> set ts \<and>
     list_all2 (\<lambda>t u. l t = Suc (r u)) (butlast ts) (tl ts) \<and>
     (ts = [] \<or> (l (last ts) = fst w \<and> r (hd ts) = snd w)))"

lemma adjacent_Nil[simp]: "adjacent w []"
  unfolding adjacent_def by simp

lemma adjacent_Cons: "adjacent w (t # ts) =
  (t \<noteq> Leaf \<and> r t = snd w \<and> (case ts of [] \<Rightarrow> l t = fst w
     | u # us \<Rightarrow> adjacent (fst w, r u) ts \<and> l t = Suc (r u)))"
  unfolding adjacent_def by (auto split: list.splits)

lemma adjacent_ConsI: "\<lbrakk>t \<noteq> Leaf; r t = snd w;
  (case ts of [] \<Rightarrow> l t = fst w
     | u # us \<Rightarrow> adjacent (fst w, r u) ts \<and> l t = Suc (r u))\<rbrakk> \<Longrightarrow>
  adjacent w (t # ts)"
  by (simp add: adjacent_Cons)

lemma adjacent_singleton: "t \<noteq> Leaf \<Longrightarrow> adjacent (l t, r t) [t]"
  unfolding adjacent_def by simp

lemma append_Cons_eq_append_append: "xs @ y # ys = xs @ [y] @ ys"
  by simp

lemma list_all2_append_singletonI: "\<lbrakk>list_all2 P xs ys; P x y\<rbrakk> \<Longrightarrow> list_all2 P (xs @ [x]) (ys @ [y])"
  by (simp add: list_all2_appendI)

lemma list_all2_Cons_append_singletonI: "\<lbrakk>xs \<noteq> []; list_all2 P (x # butlast xs) ys; P (last xs) y\<rbrakk> \<Longrightarrow> list_all2 P (x # xs) (ys @ [y])"
  using list_all2_append_singletonI by fastforce

lemma adjacent_appendI: "\<lbrakk>0 < fst w; fst w \<le> snd w;
  (case us of [] \<Rightarrow> adjacent w ts
    | u # us' \<Rightarrow> adjacent (Suc (r u), snd w) ts \<and> adjacent (fst w, (case ts of [] \<Rightarrow> snd w | ts \<Rightarrow> r u)) (u # us'))\<rbrakk> \<Longrightarrow>
  adjacent w (ts @ us)"
  unfolding adjacent_def butlast_append
  by (auto simp: intro: list_all2_Cons_append_singletonI
    list_all2_appendI[OF list_all2_Cons_append_singletonI, simplified] split: list.splits if_splits)

lemma adjacent_Cons_implies_adjacent: "adjacent (a, b) (t # ts) \<Longrightarrow> adjacent (a, l t - Suc 0) ts"
  by (cases ts) (simp_all add: adjacent_def)

lemma (in semigroup_add) fold_add_add: "fold (+) xs (x + y) = fold (+) xs x + y"
  by (induct xs arbitrary: x) (auto simp: add_assoc[symmetric])

context
  fixes as :: "'a :: semigroup_add list"
  and ws :: "window list"
begin

abbreviation atomic where
  "atomic i \<equiv> Node i i (Some (nth as (i - 1))) Leaf Leaf"

definition atomics :: "nat \<Rightarrow> nat \<Rightarrow> 'a tree list" where
  "atomics i j \<equiv> map atomic (rev [i ..< Suc j])"

definition slide :: "'a tree \<Rightarrow> window \<Rightarrow> 'a tree" where
  "slide t w =
    (let
      ts = atomics (max (fst w) (Suc (r t))) (snd w);
      ts' = reusables t w
    in fold combine (ts @ ts') Leaf)"

primrec iterate :: "'a tree \<Rightarrow> window list \<Rightarrow> 'a list" where
  "iterate t [] = []"
| "iterate t (w # xs) = (let t' = slide t w in the (val t') # iterate t' xs)"

definition sliding_window :: "'a list" where
  "sliding_window = iterate Leaf ws"

section \<open>Correctness\<close>

abbreviation sum where
  "sum i j \<equiv> fold (+) (rev (map (nth as) [i - 1 ..< j - 1])) (nth as (j - 1))"

primrec well_valued0 :: "'a tree \<Rightarrow> bool" where
  "well_valued0 Leaf = True"
| "well_valued0 (Node i j a t u) = (0 < i \<and> j \<le> length as \<and> (a \<noteq> None \<longrightarrow> a = Some (sum i j)) \<and>
    well_valued0 t \<and> well_valued0 u \<and> (u = Leaf \<or> val u \<noteq> None))"

abbreviation well_valued :: "'a tree \<Rightarrow> bool" where
  "well_valued t \<equiv> (well_valued0 t \<and> (t \<noteq> Leaf \<longrightarrow> val t \<noteq> None))"

definition valid :: "'a tree \<Rightarrow> bool" where
  "valid t = (well_shaped t \<and> well_valued t)"

lemma valid_Leaf: "valid Leaf"
  unfolding valid_def by auto

lemma add_sum:
  assumes "i > 0" "j \<ge> i" "k > j"
  shows "sum i j + sum (Suc j) k = sum i k"
proof -
  have *: "[i - 1 ..< k - 1] = [i - 1..< j] @ [j..< k - 1]"
    using assms upt_add_eq_append[of "i - 1" "j - 1" "k - j"]
    by (cases j) (auto simp: upt_conv_Cons)
  then show ?thesis using assms
    by (cases j) (auto simp: fold_add_add)
qed

lemma well_valued0_rchild_if_well_valued0[simp]: "well_valued0 t \<Longrightarrow> well_valued0 (rchild t)"
  by (induct t) auto

lemma well_valued0_lchild_if_well_valued0[simp]: "well_valued0 t \<Longrightarrow> well_valued0 (lchild t)"
  by (induct t) auto

lemma valid_rchild_if_valid: "valid t \<Longrightarrow> valid (rchild t)"
  by (metis tree.exhaust_sel tree.sel(9) valid_def well_shaped_rchild well_valued0.simps(2))

lemma val_eq_Some_sum_if_valid_neq_Leaf: "\<lbrakk>valid t; t \<noteq> Leaf\<rbrakk> \<Longrightarrow> val t = Some (sum (l t) (r t))"
  by (auto simp: valid_def foldr_conv_fold)
    (metis One_nat_def option.distinct(1) option.inject tree.exhaust_sel well_valued0.simps(2))

subsection \<open>Correctness of the Slide Function\<close>

(* fact (b) part 1 *)
lemma adjacent_atomics: "adjacent (i, j) (atomics i j)"
  unfolding adjacent_def atomics_def
  by (auto 0 1 simp: last_map last_rev nth_tl
    map_butlast[symmetric] list_all2_conv_all_nth nth_Cons' rev_nth nth_append)

(* fact (b) part 2 *)
lemma valid_atomics: "\<lbrakk>t \<in> set (atomics i j); 0 < i; j \<le> length as\<rbrakk> \<Longrightarrow> valid t"
  unfolding atomics_def
  by (auto simp: valid_def)

lemma reusables_neq_Nil_if_well_shaped_and_overlapping:
  "\<lbrakk>well_shaped t; l t \<le> fst w; r t \<le> snd w; fst w \<le> r t\<rbrakk> \<Longrightarrow> reusables t w \<noteq> []"
  by (induction t w rule: reusables.induct) (simp add: reusables.simps Let_def)

lemma reusables_lchild_neq_Nil_under_some_conditions:
  "\<lbrakk>well_shaped t; l t \<le> fst w; r t \<le> snd w; fst w \<noteq> l t; r t \<ge> fst w; l (rchild t) > fst w\<rbrakk> \<Longrightarrow>
    reusables (lchild t) w \<noteq> []"
  using r_lchild_eq_l_rchild_if_well_shaped[of "t"] r_lchild_le_r[of t]
  by (intro reusables_neq_Nil_if_well_shaped_and_overlapping) auto

(* fact (a) part 1 *)
lemma adjacent_reusables: "\<lbrakk>0 < fst w; well_shaped t; l t \<le> fst w; r t \<le> snd w\<rbrakk> \<Longrightarrow>
  adjacent (fst w, r t) (reusables t w)"
proof (induction t w rule: reusables.induct)
  case (1 t w)
  show ?case
  proof (cases "fst w > r t")
    case False
    with 1 show ?thesis
    proof (cases "fst w = l t")
      case False
      then show ?thesis
      proof (cases "fst w \<ge> l (rchild t)")
        case True
        with 1 \<open>fst w \<noteq> l t\<close> show ?thesis by (subst reusables.simps) auto
      next
        case False
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> obtain x xs where *: "reusables (lchild t) w = x # xs"
          by (cases "reusables (lchild t) w") (auto simp: reusables_lchild_neq_Nil_under_some_conditions)
        with 1(2-6) \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> \<open>\<not> l (rchild t) \<le> fst w\<close>
        have "adjacent (fst w, r (lchild t)) (x # xs)"
          by (simp add: adjacent_Cons r_lchild_le_r dual_order.trans)
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> * show ?thesis
          by (subst reusables.simps)
            (auto simp add: Let_def adjacent_Cons r_lchild_eq_l_rchild_if_well_shaped)
      qed
    qed (auto simp: reusables.simps intro!: adjacent_singleton)
  qed (auto simp: reusables.simps)
qed

lemma valid_rchild_if_well_valued0: "\<lbrakk>well_shaped t; well_valued0 t\<rbrakk> \<Longrightarrow> valid (rchild t)"
  by (metis tree.exhaust_sel tree.sel(9) valid_def well_shaped_rchild well_valued0.simps(2))

lemma valid_reusables_under_some_conditions:
  "\<lbrakk>0 < fst w; well_valued0 t; well_shaped t; l t < fst w; r t \<le> snd w\<rbrakk> \<Longrightarrow>
    \<forall>t' \<in> set (reusables t w). valid t'"
proof (induction t w rule: reusables.induct)
  case (1 t w)
  show ?case
  proof (cases "fst w > r t")
    case False
    with 1 show ?thesis
    proof (cases "fst w = l t")
    next
      case False
      then show ?thesis
      proof (cases "fst w \<ge> l (rchild t)")
        case True
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> have *: "Ball (set (reusables (rchild t) w)) valid"
          by (metis (no_types, lifting) ball_empty dual_order.strict_trans2 leI le_neq_implies_less list.set(1) r_rchild_eq_r_if_well_shaped reusables.simps set_ConsD valid_rchild_if_well_valued0 well_shaped_rchild well_valued0_rchild_if_well_valued0)
        from 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> True have "reusables t w = reusables (rchild t) w"
          by (subst reusables.simps)
            simp
        with 1 * show ?thesis
          by simp
      next
        case False
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> have *: "Ball (set (reusables (lchild t) w)) valid"
          by (metis dual_order.strict_trans2 l_lchild_eq_l_if_well_shaped leI order_trans r_lchild_le_r well_shaped_lchild well_valued0_lchild_if_well_valued0)
        with 1 have valid_rchild: "valid (rchild t)"
          by (simp add: valid_rchild_if_well_valued0)
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> False have "reusables t w = rchild t # reusables (lchild t) w"
          by (subst reusables.simps) presburger
        with 1 \<open>fst w \<noteq> l t\<close> \<open>\<not> fst w > r t\<close> False * valid_rchild show ?thesis
          by (metis set_ConsD)
      qed
    qed (auto simp: reusables.simps)
  qed (auto simp: reusables.simps)
qed

(* fact (a) part 2 *)
lemma valid_reusables:
  assumes "0 < fst w" "valid t" "l t \<le> fst w" "r t \<le> snd w"
  shows "\<forall>t' \<in> set (reusables t w). valid t'"
proof (cases "l t < fst w")
  case True
  with assms show ?thesis
    using valid_def valid_reusables_under_some_conditions by blast
next
  case False
  with assms show ?thesis
    by (simp add: reusables.simps)
qed

lemma combine_valid_Nodes_aux:
  assumes prems: "0 < l a" "a \<noteq> Leaf" "z \<noteq> Leaf" "l z = Suc (r a)" "well_shaped a" "well_shaped z"
    "well_valued0 a" "val a = Some va" "well_valued0 z" "val z = Some vz"
  shows "va + vz = fold (+) (rev (map ((!) as) [l a - Suc 0..<r z - Suc 0])) (as ! (r z - Suc 0))"
proof -
  from prems have "l a > 0" by simp
  moreover from prems have "r a \<ge> l a"
    by (metis tree.collapse well_shaped.simps(2))
  moreover have "r z > r a"
    by (metis Suc_le_lessD prems(3) prems(4) prems(6) tree.collapse well_shaped.simps(2))
  ultimately have *: "sum (l a) (r a) + sum (Suc (r a)) (r z) = sum (l a) (r z)"
    by (frule add_sum)
  from prems have "va = sum (l a) (r a)"
    by (metis option.discI option.inject tree.collapse well_valued0.simps(2))
  moreover from prems have "vz = sum (Suc (r a)) (r z)"
    by (metis option.discI option.inject prems(2) prems(3) prems(8) prems(9) tree.collapse well_valued0.simps(2))
  moreover have "fold (+) (rev (map ((!) as) [l a - Suc 0..<r z - Suc 0])) (as ! (r z - Suc 0)) = sum (l a) (r z)"
    by simp
  ultimately show ?thesis
    using * by (auto simp: add_sum)
qed

lemma discharge_is_Leaf[simp]: "discharge a = Leaf \<longleftrightarrow> a = Leaf"
  by (cases a) auto

lemma well_shaped_discharge[simp]: "well_shaped a \<Longrightarrow> well_shaped (discharge a)"
  by (cases a) auto

lemma well_valued0_discharge[simp]: "well_valued0 a \<Longrightarrow> well_valued0 (discharge a)"
  by (cases a) auto

lemma l_discharge[simp]: "l (discharge a) = l a"
  by (cases a) auto

lemma r_discharge[simp]: "r (discharge a) = r a"
  by (cases a) auto

lemma well_shaped_lr: "well_shaped a \<Longrightarrow> l a \<le> r a"
  by (cases a) auto

lemma well_valued0_r: "well_valued0 a \<Longrightarrow> a \<noteq> Leaf \<Longrightarrow> r a \<le> length as"
  by (cases a) auto

lemma valid_combine_if_valid: "\<lbrakk>0 < l a; valid a; valid z; a \<noteq> Leaf; z \<noteq> Leaf; l z = Suc (r a)\<rbrakk> \<Longrightarrow>
  valid (combine a z)"
  by (force simp add: valid_def combine_non_Leaves combine_valid_Nodes_aux
    dest: well_shaped_lr well_valued0_r)

lemma combine_neq_Leaf_if_both_non_Leaf: "\<lbrakk>a \<noteq> Leaf; z \<noteq> Leaf\<rbrakk> \<Longrightarrow>
  combine a z \<noteq> Leaf"
  by (simp add: combine_non_Leaves)

(* generalized version of fact (c) *)
lemma valid_fold_combine: "\<lbrakk>0 < fst w; ts = h # ts'; \<forall>t \<in> set ts. valid t; adjacent (fst w, l h - 1) ts';
    valid z; z \<noteq> Leaf; l z = (case ts' of [] \<Rightarrow> fst w | t\<^sub>1 # ts'' \<Rightarrow> Suc (r t\<^sub>1)); r z = snd w\<rbrakk> \<Longrightarrow>
      valid (fold combine ts' z) \<and>
      l (fold combine ts' z) = fst w \<and> r (fold combine ts' z) = snd w"
proof (induction ts' arbitrary: z ts h)
  case Nil
  then show ?case by simp
next
  case (Cons a ts')
  moreover from Cons(3-4) have "valid a" by simp
  moreover from Cons(5) have "adjacent (fst w, l a - Suc 0) ts'"
    unfolding adjacent_Cons by (auto split: list.splits)
  moreover from Cons(2-6,8) have "valid (combine a z)"
    unfolding adjacent_Cons
    by (intro valid_combine_if_valid) (auto split: list.splits)
  moreover from Cons(5,7) have "combine a z \<noteq> Leaf"
    by (intro combine_neq_Leaf_if_both_non_Leaf) (simp_all add: adjacent_Cons)
  moreover from Cons(5,7) have "l (combine a z) = (case ts' of [] \<Rightarrow> fst w | t\<^sub>1 # ts'' \<Rightarrow> Suc (r t\<^sub>1))"
    by (auto simp add: adjacent_def combine_non_Leaves split: list.splits)
  moreover from Cons(5,7,9) have "r (combine a z) = snd w"
    by (subst r_combine_non_Leaves) (auto simp add: adjacent_def)
  ultimately show ?case
    by simp
qed

(* fact (c) *)
lemma valid_fold_combine_Leaf:
  assumes "0 < fst w" "ts = h # ts'" "\<forall>t \<in> set ts. valid t" "adjacent w ts"
  shows "valid (fold combine ts Leaf) \<and>
  l (fold combine ts Leaf) = fst w \<and> r (fold combine ts Leaf) = snd w"
proof -
  from assms(2) have "fold combine ts Leaf = fold combine ts' h"
    by simp
  moreover have "valid (fold combine ts' h) \<and>
    l (fold combine ts' h) = fst w \<and> r (fold combine ts' h) = snd w"
  proof (rule valid_fold_combine)
    from assms show "0 < fst w" "ts = h # ts'" "\<forall>t \<in> set ts. valid t" "valid h" "h \<noteq> Leaf" "r h = snd w"
      "l h = (case ts' of [] \<Rightarrow> fst w | t\<^sub>1 # ts'' \<Rightarrow> Suc (r t\<^sub>1))"
      by (simp_all add: adjacent_Cons list.case_eq_if)
    from assms show "adjacent (fst w, l h - 1) ts'"
      by (metis One_nat_def adjacent_Cons_implies_adjacent prod.collapse)
  qed
  ultimately show ?thesis by simp
qed

lemma adjacent_atomics_nonempty_reusables:
  fixes x :: "'a tree" and xs :: "'a tree list"
  assumes a1: "0 < fst w"
      and a2: "l t \<le> fst w"
      and a3: "r t \<le> snd w"
      and a4: "valid t"
      and a5: "reusables t w = x # xs"
  shows "adjacent (Suc (r x), snd w) (atomics (max (fst w) (Suc (r t))) (snd w))"
proof -
  have f6: "\<forall>p ts. adjacent p ts = ((Leaf::'a tree) \<notin> set ts \<and> list_all2 (\<lambda>t ta. l t = Suc (r ta)) (butlast ts) (tl ts) \<and> (ts = [] \<or> l (last ts) = fst p \<and> r (hd ts) = snd p))"
    using adjacent_def by blast
  then have f7: "Leaf \<notin> set (atomics (max (fst w) (Suc (r t))) (snd w)) \<and> list_all2 (\<lambda>t ta. l t = Suc (r ta)) (butlast (atomics (max (fst w) (Suc (r t))) (snd w))) (tl (atomics (max (fst w) (Suc (r t))) (snd w))) \<and> (atomics (max (fst w) (Suc (r t))) (snd w) = [] \<or> l (last (atomics (max (fst w) (Suc (r t))) (snd w))) = fst (max (fst w) (Suc (r t)), snd w) \<and> r (hd (atomics (max (fst w) (Suc (r t))) (snd w))) = snd (max (fst w) (Suc (r t)), snd w))"
    using adjacent_atomics by presburger
  have "adjacent (fst w, r t) (reusables t w)"
    using a4 a3 a2 a1 by (simp add: adjacent_reusables valid_def)
  then have f8: "r x = r t"
    using a5 by (simp add: adjacent_Cons)
  have "max (fst w) (Suc (r t)) = Suc (r t)"
    using a5 by (metis (no_types) Suc_n_not_le_n list.simps(3) max.bounded_iff max_def_raw not_le_imp_less reusables.simps)
  then show ?thesis
    using f8 f7 f6 by presburger
qed

lemma adjacent_Cons_r: "adjacent (a, r t) (x # xs) \<Longrightarrow> adjacent (a, r x) (x # xs)"
  by (simp add: adjacent_Cons)

lemma adjacent_Cons_r2:
  "adjacent (fst w, r t) (x # xs) \<Longrightarrow> 0 < fst w \<Longrightarrow> fst w \<le> snd w \<Longrightarrow> r t \<le> snd w \<Longrightarrow>
   atomics (max (fst w) (Suc (r t))) (snd w) = [] \<Longrightarrow>
   adjacent w (x # xs)"
  by (metis (no_types, lifting) atomics_def adjacent_def append_is_Nil_conv diff_Suc_Suc diff_zero le_Suc_eq list.simps(3) map_is_Nil_conv max_Suc_Suc max_def_raw prod.sel(1) prod.sel(2) rev_is_Nil_conv upt.simps(2))

lemma adjacent_append_atomics_reusables:
  "\<lbrakk>0 < fst w; fst w \<le> snd w; valid t; l t \<le> fst w; r t \<le> snd w\<rbrakk> \<Longrightarrow>
    adjacent w (atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w)"
  using adjacent_atomics_nonempty_reusables[of w t] reusables_neq_Nil_if_well_shaped_and_overlapping[of t w]
    adjacent_atomics[of "fst w" "snd w"] adjacent_reusables[of w t]
  by (intro adjacent_appendI) (auto simp: valid_def max.absorb1 atomize_not
    elim: adjacent_Cons_r adjacent_Cons_r2 split: list.splits nat.splits)

lemma valid_append_atomics_reusables: "\<lbrakk>0 < fst w; valid t; l t \<le> fst w; r t \<le> snd w; snd w \<le> length as\<rbrakk> \<Longrightarrow>
  \<forall>t \<in> set (atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w). valid t"
  by (auto simp only: set_append valid_reusables dest: valid_atomics split: if_splits)

lemma append_atomics_reusables_neq_Nil: "\<lbrakk>0 < fst w; fst w \<le> snd w; valid t; l t \<le> fst w; r t \<le> snd w\<rbrakk> \<Longrightarrow>
  atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w \<noteq> []"
  by (simp add: reusables_neq_Nil_if_well_shaped_and_overlapping valid_def atomics_def)

(* lemma 1 *)
lemma valid_slide:
  assumes "0 < fst w" "fst w \<le> snd w" "valid t" "l t \<le> fst w" "r t \<le> snd w" "snd w \<le> length as"
  shows "valid (slide t w) \<and> l (slide t w) = fst w \<and> r (slide t w) = snd w"
proof -
  from assms have non_empty: "atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w \<noteq> []"
    using append_atomics_reusables_neq_Nil by blast
  from assms have adjacent: "adjacent w (atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w)"
    using adjacent_append_atomics_reusables by blast
  from assms have valid: "\<forall>t \<in> set (atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w). valid t"
    using valid_append_atomics_reusables by blast
  have *: "slide t w = fold combine (atomics (max (fst w) (Suc (r t))) (snd w) @ reusables t w) Leaf"
    by (simp add: slide_def)
  from assms(1) non_empty adjacent valid show "valid (slide t w) \<and> l (slide t w) = fst w \<and> r (slide t w) = snd w"
    unfolding * neq_Nil_conv using valid_fold_combine_Leaf by blast
qed

subsection \<open>Correctness of the Sliding Window Algorithm\<close>

lemma iterate_eq_map_sum: "\<lbrakk>valid t; windows as xs; (case xs of [] \<Rightarrow> True | x # xs' \<Rightarrow> l t \<le> fst x \<and> r t \<le> snd x)\<rbrakk> \<Longrightarrow>
  iterate t xs = map (\<lambda>w. sum (fst w) (snd w)) xs"
  by (induction xs arbitrary: t)
    (auto simp: valid_slide windows_def window_def val_eq_Some_sum_if_valid_neq_Leaf neq_Leaf_if_l_gt0 split: list.split)

(* theorem 2: functional correctness *)
theorem correctness: "windows as ws \<Longrightarrow> sliding_window = map (\<lambda>w. sum (fst w) (snd w)) ws"
  by (auto simp only: sliding_window_def intro!: iterate_eq_map_sum)
    (auto simp: valid_def split: list.split)

end

(*<*)
value[code] "sliding_window [2,4,5,2 :: nat] [(1, 3), (1, 4), (2, 4)]"
value[code] "slide [2,4,5,2 :: nat] Leaf (1, 3)"
(*>*)

subsection \<open>Summary of the Correctness Proof\<close>

text \<open>We closely follow Basin et al.'s proof outline~\cite{BASIN2015186}.
  \begin{enumerate}
    \item Lemma 1, the correctness result about the function @{term SWA.slide}, is formalized
      by @{thm[source] SWA.valid_slide}. It follows from the following auxiliary facts:
      \begin{itemize}
        \item Fact (a) is formalized by @{thm[source] SWA.adjacent_reusables} and @{thm[source] SWA.valid_reusables}.
        \item Fact (b) is formalized by @{thm[source] SWA.adjacent_atomics} and @{thm[source] SWA.valid_atomics}.
        \item Fact (c) is formalized by @{thm[source] SWA.valid_fold_combine_Leaf}.
      \end{itemize}
    \item Theorem 2, the correctness result about the function @{term SWA.sliding_window}, is formalized
      by @{thm[source] SWA.correctness}.
  \end{enumerate}
\<close>

section \<open>Alternative Slide Interface and Additional Operations\<close>

subsection \<open>Alternative Slide Interface\<close>

text \<open>
  The slide operation above takes the \emph{entire} input sequence as a parameter. This is often
  impractical. We provide an alternative interface to the slide operation that takes only the
  \emph{new} elements as a parameter.
\<close>

abbreviation atomic' where
  "atomic' as b idx \<equiv> Node b b (Some (nth as idx)) Leaf Leaf"

abbreviation atomics' :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a tree list" where
  "atomics' as i j sidx \<equiv> map (\<lambda>b. atomic' as b (b - sidx)) (rev [i ..< Suc j])"

definition slide' :: "'a :: semigroup_add list \<Rightarrow> 'a tree \<Rightarrow> window \<Rightarrow> 'a tree" where
"slide' as t w =
    (let
      ts = atomics' as (max (fst w) (Suc (r t))) (snd w) (Suc (r t));
      ts' = reusables t w
    in fold combine (ts @ ts') Leaf)"

(* examples from paper *)
(*<*)
value[code] "slide' [2,4,5,2 :: nat] Leaf (1, 3)"
value[code] "slide' [2,4,5,2 :: nat] Leaf (1, 4)"
value[code] "slide' [2,4,5,2 :: nat] Leaf (2, 4)"
value[code] "slide' [2 :: nat] (slide' [2,4,5 :: nat] Leaf (1, 3)) (1, 4)"
value[code] "slide' [] (slide' [2 :: nat] (slide' [2,4,5 :: nat] Leaf (1, 3)) (1, 4)) (2, 4)"
value[code] "slide' [2,4,5 :: nat] Leaf (1, 3)"
value[code] "slide' [2 :: nat] (slide' [2,4,5 :: nat] Leaf (1, 3)) (2, 4)"
(*>*)

lemma slide_eq_slide':
  assumes "0 < fst w" "fst w \<le> snd w" "valid as t" "r t = length as" "l t \<le> fst w" "r t \<le> snd w" "snd w \<le> length (as @ as')"
  shows "slide (as @ as') t w = slide' as' t w"
proof (cases "r t = snd w")
  case True
  with assms have *: "atomics' (as @ as') (max (fst w) (Suc (r t))) (snd w) 1 = []"
    by simp
  from True assms have "atomics' as' (max (fst w) (Suc (r t))) (snd w) (Suc (r t)) = []"
    by simp
  with * show ?thesis
    unfolding slide_def slide'_def atomics_def by simp
next
  case False
  with assms have "r t < snd w"
    by simp
  with assms have "atomic' (as @ as') (snd w) (snd w - Suc 0) = atomic' as' (snd w) (snd w - Suc (length as))"
    by (simp add: leD nth_append)
  with assms have *: "\<forall>i. i \<in> set ([max (fst w) (Suc (length as))..<snd w]) \<longrightarrow> atomic' (as @ as') i (i - Suc 0) = atomic' as' i (i - Suc (length as))"
    by (auto simp: nth_append)
  then have "map (\<lambda>i. atomic' (as @ as') i (i - Suc 0)) (rev [max (fst w) (Suc (length as))..<snd w]) = map (\<lambda>b. atomic' as' b (b - Suc (r t))) (rev [max (fst w) (Suc (r t))..<snd w])"
    by (simp add: assms(4))
  with assms have "atomics' (as @ as') (max (fst w) (Suc (r t))) (snd w) 1 = atomics' as' (max (fst w) (Suc (r t))) (snd w) (Suc (r t))"
    by (auto simp: nth_append)
  then show ?thesis
    unfolding slide_def slide'_def atomics_def
    by presburger
qed

lemma sum_eq_sum_append: "\<lbrakk>0 < i; i \<le> j; j \<le> length as\<rbrakk> \<Longrightarrow> sum as i j = sum (as @ as') i j"
proof -
  assume assms: "0 < i" "i \<le> j" "j \<le> length as"
  then have *: "rev (map ((!) as) [i - Suc 0..<j - Suc 0]) = rev (map ((!) (as@as')) [i - Suc 0..<j - Suc 0])"
    by (auto simp: nth_append)
  from assms have "as ! (j - Suc 0) = (as @ as') ! (j - Suc 0)"
    by (auto simp: nth_append)
  then show ?thesis
    by (simp add: *)
qed

lemma well_valued0_append: "\<lbrakk>well_shaped t; well_valued0 as t\<rbrakk> \<Longrightarrow> well_valued0 (as @ as') t"
proof (induction t)
  case (Node i j a t1 t2)
  then show ?case
    using sum_eq_sum_append
    by (auto 4 0)
qed simp

lemma valid_append: "valid as t \<Longrightarrow> valid (as @ as') t"
  unfolding valid_def
  by (auto intro: well_valued0_append)

lemma valid_slide_append: "\<lbrakk>0 < fst w; fst w \<le> snd w; valid as t; l t \<le> fst w; r t \<le> snd w; snd w \<le> length as + length as'\<rbrakk> \<Longrightarrow>
  valid (as @ as') (slide (as @ as') t w) \<and> l (slide (as @ as') t w) = fst w \<and> r (slide (as @ as') t w) = snd w"
  by (auto simp: valid_append valid_slide)

(* correctness of alternative slide interface *)
theorem valid_slide':
  assumes "0 < fst w" "fst w \<le> snd w" "valid as t" "length as = r t" "length as' \<ge> snd w - r t" "l t \<le> fst w" "r t \<le> snd w"
  shows "valid (as @ as') (slide' as' t w) \<and> l (slide' as' t w) = fst w \<and> r (slide' as' t w) = snd w"
proof -
  from assms have "valid (as @ as') (slide (as @ as') t w) \<and> l (slide (as @ as') t w) = fst w \<and> r (slide (as @ as') t w) = snd w"
    using valid_slide_append by (metis add_le_cancel_left le_add_diff_inverse)
  with assms show ?thesis
    using slide_eq_slide' by (metis add_le_cancel_left le_add_diff_inverse length_append)
qed

subsection \<open>Updating all Values in the Tree\<close>

text \<open>
  So far, we have assumed that the sequence is fixed. However, under certain conditions,
  SWA can be applied even if the sequence changes. In particular, if a function that distributes
  over the associative operation is mapped onto the sequence, validity of the tree can be preserved
  by mapping the same function onto the tree using @{term map_tree}.
\<close>

lemma map_tree_eq_Leaf_iff: "map_tree f t = Leaf \<longleftrightarrow> t = Leaf"
  by simp

lemma l_map_tree_eq_l[simp]: "l (map_tree f t) = l t"
  by (cases t)
    (auto split: option.splits)

lemma r_map_tree_eq_r[simp]: "r (map_tree f t) = r t"
  by (cases t)
    (auto split: option.splits)

lemma val_map_tree_neq_None: "val t \<noteq> None \<Longrightarrow> val (map_tree f t) \<noteq> None"
  by (cases t) auto

lemma well_shaped_map_tree: "well_shaped t \<Longrightarrow> well_shaped (map_tree f t)"
  by (induction t)
    (auto split: option.split)

lemma fold_distr: "(\<forall>x y. f (x + y) = f x + f y) \<Longrightarrow> f (fold (+) list e) = fold (+) (map f list) (f e)"
  by (induction list arbitrary: e) auto

lemma map_rev_map_nth_eq: "\<forall>x \<in> set xs. x < length as \<Longrightarrow> map f (rev (map ((!) as) xs)) = rev (map ((!) (map f as)) xs)"
  by (simp add: rev_map)

lemma f_nth_eq_map_f_nth: "\<lbrakk>as \<noteq> []; length as \<ge> n\<rbrakk> \<Longrightarrow> f (as ! (n - Suc 0)) = map f as ! (n - Suc 0)"
  by (cases "n = length as") auto

lemma well_valued0_map_map_tree:
   "\<lbrakk>\<forall>x y. f (x + y) = f x + f y; well_shaped t; well_valued0 as t; r t \<le> length as; as \<noteq> []\<rbrakk> \<Longrightarrow>
     well_shaped (map_tree f t) \<and> well_valued0 (map f as) (map_tree f t)"
proof (rule conjI[OF well_shaped_map_tree], assumption, induction t)
  case (Node i j a t1 t2)
  then have "map f (rev (map ((!) as) [l t1 - Suc 0..<r t2 - Suc 0])) =
    rev (map ((!) (map f as)) [l t1 - Suc 0..<r t2 - Suc 0])"
    by (subst map_rev_map_nth_eq) auto
  moreover from Node have "r t1 \<le> length as"
    by (cases t1) auto
  ultimately show ?case using Node(3-7)
    by (auto simp: fold_distr[of f] val_map_tree_neq_None
      well_shaped_map_tree intro!: Node(1,2))
qed simp

lemma valid_map_map_tree:
  assumes "\<forall>x y. f (x + y) = f x + f y" "valid as t" "r t \<le> length as"
  shows "valid (map f as) (map_tree f t)"
proof (cases "as \<noteq> []")
  case True
  with assms show ?thesis
    by (metis map_tree_eq_Leaf_iff val_map_tree_neq_None valid_def well_valued0_map_map_tree)
next
  case False
  with assms show ?thesis
    by (metis le_zero_eq list.size(3) tree.exhaust_sel map_tree_eq_Leaf_iff valid_Leaf valid_def well_shaped.simps(2) well_valued0.simps(2))
qed

lemma valid_Nil_iff: "valid [] t \<longleftrightarrow> t = Leaf"
  unfolding valid_def
proof
  assume "well_shaped t \<and> well_valued [] t"
  then show "t = Leaf"
    by (metis le_neq_implies_less list.size(3) not_less_zero tree.collapse well_shaped.simps(2) well_valued0.simps(2))
qed simp

subsection \<open>Updating the Rightmost Leaf of the Tree\<close>

text \<open>
  We provide a function to update the rightmost leaf of the tree. This may be used in an online
  setting where the input sequence is not known in advance to update the latest observed element
  using the same associative operation used in SWA. We show that validity of the tree is preserved
  in this case.
\<close>

fun update_rightmost :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "update_rightmost _ Leaf = Leaf"
| "update_rightmost f (Node i j a t u) = Node i j (map_option f a) t (update_rightmost f u)"

lemma update_rightmost_eq_Leaf_iff: "update_rightmost f t = Leaf \<longleftrightarrow> t = Leaf"
  by (cases t)
    (auto split: option.splits)

lemma l_update_rightmost_eq_l[simp]: "l (update_rightmost f t) = l t"
  by (cases t)
    (auto split: option.splits)

lemma r_update_rightmost_eq_r[simp]: "r (update_rightmost f t) = r t"
  by (cases t)
    (auto split: option.splits)

lemma val_update_rightmost_neq_None: "val t \<noteq> None \<Longrightarrow> val (update_rightmost f t) \<noteq> None"
  by (cases t) auto

lemma well_shaped_update_rightmost: "well_shaped t \<Longrightarrow> well_shaped (update_rightmost f t)"
  by (induction t)
    (auto simp: update_rightmost_eq_Leaf_iff split: option.split)

lemma sum_eq_sum_prepend: "\<lbrakk>0 < i; i \<le> j; length xs < i; length ys = length xs\<rbrakk> \<Longrightarrow> sum (xs @ as) i j = sum (ys @ as) i j"
proof -
  assume assms: "0 < i" "i \<le> j" "length xs < i" "length ys = length xs"
  then have *: "rev (map ((!) (xs @ as)) [i - Suc 0..<j - Suc 0]) = rev (map ((!) (ys @ as)) [i - Suc 0..<j - Suc 0])"
    by (auto simp: nth_append)
  from assms have "(xs @ as) ! (j - Suc 0) = (ys @ as) ! (j - Suc 0)"
    by (auto simp: nth_append)
  then show ?thesis
    by (simp add: *)
qed

lemma well_valued0_prepend: "\<lbrakk>length xs \<le> l t - 1; length ys = length xs; well_shaped t; well_valued0 (xs @ as) t\<rbrakk> \<Longrightarrow> well_valued0 (ys @ as) t"
proof (induction t)
  case (Node i j a t1 t2)
  then have well_valued0_t1: "well_valued0 (ys @ as) t1"
    by auto
  from Node have "well_valued0 (ys @ as) t2"
  proof (cases a)
    case None
    with Node show ?thesis
      by auto
        (metis One_nat_def Suc_pred diff_Suc_1 le_Suc_eq le_Suc_ex trans_le_add1 tree.exhaust_sel well_shaped.simps(2))
  next
    case (Some a')
    with Node show ?thesis
      by auto
        (metis One_nat_def diff_Suc_1 diff_le_self le_trans tree.exhaust_sel well_shaped.simps(2))
  qed
  with Node well_valued0_t1 show ?case
  proof -
    have f1: "0 < i \<and> j \<le> length (xs @ as) \<and> (a = None \<or> a = Some (SWA.sum (xs @ as) i j)) \<and> well_valued0 (xs @ as) t1 \<and> well_valued0 (xs @ as) t2 \<and> (t2 = Leaf \<or> val t2 \<noteq> None)"
      by (meson \<open>well_valued0 (xs @ as) (Node i j a t1 t2)\<close> well_valued0.simps(2))
    then have f2: "j \<le> length (ys @ as)"
      by (simp add: \<open>length ys = length xs\<close>)
    have "a = None \<or> a = Some (SWA.sum (ys @ as) i j)"
      using f1 by (metis Node.prems(1) Node.prems(2) Node.prems(3) One_nat_def Suc_pred le_imp_less_Suc sum_eq_sum_prepend tree.sel(2) well_shaped.simps(2))
    then show ?thesis
      using f2 f1 \<open>well_valued0 (ys @ as) t2\<close> well_valued0.simps(2) well_valued0_t1 by blast
  qed
qed simp

lemma valid_prepend: "\<lbrakk>length xs \<le> l t - 1; length ys = length xs; valid (xs @ as) t\<rbrakk> \<Longrightarrow> valid (ys @ as) t"
  unfolding valid_def
  by (auto intro: well_valued0_prepend)

lemma take_eq_append_take_take_drop: "m \<le> n \<Longrightarrow> take n xs = take m xs @ take (n-m) (drop m xs)"
proof (induction xs)
  case (Cons a xs)
  then show ?case
    by (metis le_add_diff_inverse take_add)
qed simp

lemma well_valued0_take_r: "\<lbrakk>well_shaped t; well_valued0 as t\<rbrakk> \<Longrightarrow> well_valued0 (take (r t) as) t"
proof (induction t)
  case (Node i j a t1 t2)
  from Node have well_valued0_t1: "well_valued0 (take j as) t1"
  proof -
    from Node have "r t1 \<le> j"
      using r_lchild_le_r by (metis tree.sel(4) tree.sel(8))
    with Node have "take j as = take (r t1) as @ take (j - r t1) (drop (r t1) as)"
      using take_eq_append_take_take_drop[of "r t1" j as] by simp
    with Node show ?thesis
      by (auto intro!: well_valued0_append)
  qed
  from Node have well_valued0_t2: "well_valued0 (take j as) t2"
    by auto
  from Node have sum_eq: "fold (+) (rev (map ((!) as) [l t1 - Suc 0..<r t2 - Suc 0])) (as ! (r t2 - Suc 0)) =
      fold (+) (rev (map ((!) (take (r t2) as)) [l t1 - Suc 0..<r t2 - Suc 0])) (as ! (r t2 - Suc 0))"
    by (intro arg_cong[where f="\<lambda>xs. fold _ xs _"]) auto
  from Node well_valued0_t1 well_valued0_t2 sum_eq show ?case
    by auto
qed simp

lemma valid_take_r: "valid as t \<Longrightarrow> valid (take (r t) as) t"
  unfolding valid_def
  by (auto intro: well_valued0_take_r)

lemma well_valued0_butlast: "\<lbrakk>well_shaped t; well_valued0 as t; r t < length as\<rbrakk> \<Longrightarrow> well_valued0 (butlast as) t"
proof (induction t)
  case (Node i j a t1 t2)
  then  have r_le_length: "j \<le> length (butlast as)"
    by simp
  from Node have "i > 0"
    by simp
  with r_le_length Node have sum_eq: "sum as i j = sum (butlast as) i j"
    by (metis append_butlast_last_id le_zero_eq less_imp_le_nat list.size(3) neq_iff
      sum_eq_sum_append well_shaped.simps(2))
  from Node have "r t1 < length as"
    by (metis dual_order.strict_trans2 r_lchild_le_r tree.sel(8))
  with Node r_le_length show ?case
    by (metis (no_types, lifting) dual_order.strict_iff_order sum_eq tree.sel(10) tree.sel(4)
      well_shaped.simps(2) well_shaped_rchild well_valued0.simps(2))
qed simp

lemma well_valued0_append_butlast_lchild: "\<lbrakk>well_shaped t; well_valued0 as t\<rbrakk> \<Longrightarrow>
  well_valued0 (butlast as @ [last as + x]) (lchild t)"
proof (cases t)
  case (Node i j a t1 t2)
  assume assms: "well_shaped t" "well_valued0 as t"
  from Node assms have "r t1 < length as"
    by (fastforce dest: well_shaped_lr)
  with Node assms show ?thesis
    by (auto simp: well_valued0_butlast well_valued0_append)
qed simp

lemma sum_update_rightmost: "\<lbrakk>0 < i; i \<le> j; length as = j\<rbrakk> \<Longrightarrow>
  sum as i j + x = sum (butlast as @ [last as + x]) i j"
  by (cases as)
    (auto simp: nth_append[abs_def] fold_add_add last_conv_nth nth_Cons' nth_butlast
     intro!: arg_cong2[where f="(+)"] arg_cong[where f="\<lambda>xs. fold _ xs _"])

lemma well_valued0_update_rightmost: "\<lbrakk>well_shaped t; well_valued0 as t; length as = r t\<rbrakk> \<Longrightarrow>
  well_valued0 (butlast as @ [last as + x]) (update_rightmost (\<lambda>a. a + x) t)"
proof (induction t)
  case Leaf
  then show ?case
    by (auto simp add: valid_Leaf)
next
  case (Node i j a t1 t2)
  moreover
  from Node have well_valued0_t1: "well_valued0 (butlast as @ [last as + x]) t1"
    using well_valued0_append_butlast_lchild by (metis tree.sel(8))
  moreover
  from Node have well_valued0_t2:
    "well_valued0 (butlast as @ [last as + x]) (update_rightmost ((\<lambda>a. a + x)) t2)"
    by (metis \<open>well_valued0 (butlast as @ [last as + x]) t1\<close> dual_order.strict_iff_order
      tree.sel(4) update_rightmost.simps(1) well_shaped.simps(2) well_valued0.simps(2))
  ultimately show ?case
    using sum_update_rightmost
    by (cases a) (auto simp: val_update_rightmost_neq_None)
qed

(* correctness of update_rightmost *)
lemma valid_update_rightmost: "\<lbrakk>valid as t; length as = r t\<rbrakk> \<Longrightarrow>
  valid (butlast as @ [last as + x]) (update_rightmost (\<lambda>a. a + x) t)"
  unfolding valid_def
  using well_valued0_update_rightmost
  by (metis update_rightmost.simps(1) val_update_rightmost_neq_None well_shaped_update_rightmost)

(*<*)
end
(*>*)


(*  Title:      HOL/Isar_Examples/Fibonacci.thy
    Author:     Gertrud Bauer
    Copyright   1999 Technische Universitaet Muenchen

The Fibonacci function.  Original
tactic script by Lawrence C Paulson.

Fibonacci numbers: proofs of laws taken from

  R. L. Graham, D. E. Knuth, O. Patashnik.
  Concrete Mathematics.
  (Addison-Wesley, 1989)
*)

section \<open>Fib and Gcd commute\<close>

theory Fibonacci
  imports "HOL-Computational_Algebra.Primes"
begin

text_raw \<open>\<^footnote>\<open>Isar version by Gertrud Bauer. Original tactic script by Larry
  Paulson. A few proofs of laws taken from @{cite "Concrete-Math"}.\<close>\<close>

subsection \<open>Fibonacci numbers\<close>

fun fib :: "nat \<Rightarrow> nat"
  where
    "fib 0 = 0"
  | "fib (Suc 0) = 1"
  | "fib (Suc (Suc x)) = fib x + fib (Suc x)"

text \<open>Alternative induction rule.\<close>

theorem fib_induct: "P 0 \<Longrightarrow> P 1 \<Longrightarrow> (\<And>n. P (n + 1) \<Longrightarrow> P n \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
  for n :: nat
  by (induct rule: fib.induct) simp_all

subsection \<open>Fib and gcd commute\<close>

text \<open>A few laws taken from @{cite "Concrete-Math"}.\<close>

lemma fib_add: "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
  (is "?P n")
  \<comment> \<open>see @{cite \<open>page 280\<close> "Concrete-Math"}\<close>
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  have "fib (n + 2 + k + 1)
    = fib (n + k + 1) + fib (n + 1 + k + 1)" by simp
  also assume "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n" (is " _ = ?R1")
  also assume "fib (n + 1 + k + 1) = fib (k + 1) * fib (n + 1 + 1) + fib k * fib (n + 1)"
    (is " _ = ?R2")
  also have "?R1 + ?R2 = fib (k + 1) * fib (n + 2 + 1) + fib k * fib (n + 2)"
    by (simp add: add_mult_distrib2)
  finally show "?P (n + 2)" .
qed

lemma coprime_fib_Suc: "coprime (fib n) (fib (n + 1))"
  (is "?P n")
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  assume P: "coprime (fib (n + 1)) (fib (n + 1 + 1))"
  have "fib (n + 2 + 1) = fib (n + 1) + fib (n + 2)"
    by simp
  also have "\<dots> = fib (n + 2) + fib (n + 1)"
    by simp
  also have "gcd (fib (n + 2)) \<dots> = gcd (fib (n + 2)) (fib (n + 1))"
    by (rule gcd_add2)
  also have "\<dots> = gcd (fib (n + 1)) (fib (n + 1 + 1))"
    by (simp add: gcd.commute)
  also have "\<dots> = 1"
    using P by simp
  finally show "?P (n + 2)"
    by (simp add: coprime_iff_gcd_eq_1)
qed

lemma gcd_mult_add: "(0::nat) < n \<Longrightarrow> gcd (n * k + m) n = gcd m n"
proof -
  assume "0 < n"
  then have "gcd (n * k + m) n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat add.commute)
  also from \<open>0 < n\<close> have "\<dots> = gcd m n"
    by (simp add: gcd_non_0_nat)
  finally show ?thesis .
qed

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  then have "gcd (fib m) (fib (n + m)) = gcd (fib (n + k + 1)) (fib (k + 1))"
    by (simp add: gcd.commute)
  also have "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
    by (rule fib_add)
  also have "gcd \<dots> (fib (k + 1)) = gcd (fib k * fib n) (fib (k + 1))"
    by (simp add: gcd_mult_add)
  also have "\<dots> = gcd (fib n) (fib (k + 1))"
    using coprime_fib_Suc [of k] gcd_mult_left_right_cancel [of "fib (k + 1)" "fib k" "fib n"]
    by (simp add: ac_simps)
  also have "\<dots> = gcd (fib m) (fib n)"
    using Suc by (simp add: gcd.commute)
  finally show ?thesis .
qed

lemma gcd_fib_diff: "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)" if "m \<le> n"
proof -
  have "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib (n - m + m))"
    by (simp add: gcd_fib_add)
  also from \<open>m \<le> n\<close> have "n - m + m = n"
    by simp
  finally show ?thesis .
qed

lemma gcd_fib_mod: "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" if "0 < m"
proof (induct n rule: nat_less_induct)
  case hyp: (1 n)
  show ?case
  proof -
    have "n mod m = (if n < m then n else (n - m) mod m)"
      by (rule mod_if)
    also have "gcd (fib m) (fib \<dots>) = gcd (fib m) (fib n)"
    proof (cases "n < m")
      case True
      then show ?thesis by simp
    next
      case False
      then have "m \<le> n" by simp
      from \<open>0 < m\<close> and False have "n - m < n"
        by simp
      with hyp have "gcd (fib m) (fib ((n - m) mod m))
          = gcd (fib m) (fib (n - m))" by simp
      also have "\<dots> = gcd (fib m) (fib n)"
        using \<open>m \<le> n\<close> by (rule gcd_fib_diff)
      finally have "gcd (fib m) (fib ((n - m) mod m)) =
          gcd (fib m) (fib n)" .
      with False show ?thesis by simp
    qed
    finally show ?thesis .
  qed
qed

theorem fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"
  (is "?P m n")
proof (induct m n rule: gcd_nat_induct)
  fix m n :: nat
  show "fib (gcd m 0) = gcd (fib m) (fib 0)"
    by simp
  assume n: "0 < n"
  then have "gcd m n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat)
  also assume hyp: "fib \<dots> = gcd (fib n) (fib (m mod n))"
  also from n have "\<dots> = gcd (fib n) (fib m)"
    by (rule gcd_fib_mod)
  also have "\<dots> = gcd (fib m) (fib n)"
    by (rule gcd.commute)
  finally show "fib (gcd m n) = gcd (fib m) (fib n)" .
qed

end


theory BinarySearch2
imports
  Main
  "../State_Monad_HL"
begin

section\<open>Binary Search\<close>
text\<open>This is proof of the binary search algorithm. It is inspired by the proof of the same algorithm in "Verification of Sequential and Concurrent Programs".
     The algorithm is straightforward; it searches recursively after a specific value in a sorted list of numbers. It halves the size of the array it is looking at for each iteration (using the fact that the array is sorted).
     If the number exists in the array it will be found - which in this case means that @{text mid} is the index that is storing the value.\<close>

subsection\<open>Definition of the environment\<close>
record env =
  right :: "nat"
  left  :: "nat"
  arr   :: "nat list"
  mid   :: "nat"
  val   :: "nat"

subsubsection\<open>Monad update functions\<close>
text\<open>Each of the definitions takes an environment and a value of one of the variables. They update the value of the variable and outputs a new environment.\<close>
definition right_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "right_Env s v = s \<lparr> right := v \<rparr>"
definition left_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "left_Env s v = s \<lparr> left := v \<rparr>"
definition arr_Env:: "env \<Rightarrow> nat list  \<Rightarrow> env" where "arr_Env s v = s \<lparr> arr := v \<rparr>"
definition mid_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "mid_Env s v = s \<lparr> mid := v \<rparr>"
definition val_Env:: "env \<Rightarrow> nat \<Rightarrow> env" where "val_Env s v = s \<lparr> val := v \<rparr>"

subsubsection\<open>Theorems about how the update functions changes the environment\<close>
theorem put_right_rule: "spec (\<lambda>x. p () (x \<lparr> right := v \<rparr>)) (put right_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def right_Env_def)

theorem put_left_rule: "spec (\<lambda>x. p () (x \<lparr> left := v \<rparr>)) (put left_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def left_Env_def)

theorem put_arr_rule: "spec (\<lambda>x. p () (x \<lparr> arr := v \<rparr>)) (put arr_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def arr_Env_def)

theorem put_mid_rule: "spec (\<lambda>x. p () (x \<lparr> mid := v \<rparr>)) (put mid_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def mid_Env_def)

theorem put_val_rule: "spec (\<lambda>x. p () (x \<lparr> val := v \<rparr>)) (put val_Env v) p"
  by (simp add: spec_def put_def get_state_def put_state_def val_Env_def)

subsection\<open>Definitions of the methods\<close>
definition update_left where
  "update_left \<equiv> do{
    mid \<leftarrow> get mid;
    put left_Env (mid)
  }"

definition update_right where
  "update_right \<equiv> do{
    mid \<leftarrow> get mid;
    put right_Env (mid)
  }"

text\<open>This method will update either the @{text right} or @{text left} variable, if @{text mid} is not the index that is pointing to @{text val}. If @{text mid} is pointing at @{text val} it will do nothing.\<close>
definition update_range where
"update_range \<equiv> do{
                    (mid, xs, v) \<leftarrow> get (\<lambda>e. (mid e, arr e, val e));
                    (if xs ! mid < v then do {
                        update_left
                    }else (if (xs ! mid > v) then do{
                        update_right
                    }else skip
                    ))
                }"

fun BinarySearch:: "nat  \<Rightarrow> (env, unit) state" where
  case0:"BinarySearch 0  = skip"|
  caseN:"BinarySearch (Suc n) = do {
                        (l, r) \<leftarrow> get (\<lambda>e. (left e, right e));
                        put mid_Env ((r + l) div 2);
                        (if (l < r) then do{
                          update_range;
                          BinarySearch n
                         }
                       else skip
                      )}"

text\<open>The definiton of how to set up the state-monad/environment with the right values based on an array.\<close>
definition init_env:: "nat list \<Rightarrow> nat \<Rightarrow> env" where
  "init_env l v \<equiv> \<lparr>right = length l,  left = 0, arr = sort(l), mid = 0, val = v\<rparr>"

definition init_env2:: "nat list \<Rightarrow> nat \<Rightarrow> env" where
  "init_env2 l v \<equiv> env.make (length l) 0 (sort l) 0 v"

value \<open>snd(run_state (BinarySearch 6) (init_env [0,3,2,1,5,8] 8))\<close>

subsection\<open>Definition of pre- and postcondition\<close>
text\<open>This method states the invariants of the environment. It is also used as the pre- and post-condition of the function.
    The main thing to note here is that @{text mid} should be a valid index in @{text arr} and all values outside the range of @{text left} and @{text right} should be different (greater or smaller than @{text val}.)\<close>
definition env_invariant:: "env \<Rightarrow> bool" where
"env_invariant e \<equiv> sorted(arr e) \<and> left e \<le> right e \<and> right e \<le> length (arr e) \<and> left e \<le> mid e
    \<and> mid e \<le> right e  \<and> (\<forall>x:: nat. x < left e \<longrightarrow> arr e ! x < val e) \<and> (\<forall>x. x > right e \<and> x < length (arr e) \<longrightarrow>  arr e ! x> val e)"

text\<open>This is the post-condition of binary-search. It is taken from the book "Verification of Sequential and Concurrent Programs" on page 145.
  It states that the variable @{text mid} should be a valid index in the array
   and that if the value we are searching for is inside the array, it should be at position @{text mid}.\<close>
definition q where
"q e \<equiv> left e \<le> mid e \<and> mid e \<le> right e \<and> (arr e ! mid e = val e \<longrightarrow>
  (\<exists>x. x \<ge> left e \<and> x \<le> right e \<and> x \<le> length (arr e) \<and> arr e  ! x = val e))"

text\<open>The definitions of the pre-condition for each of the three definitions. They are all basically extending the basic pre-condition @{text env_invariant} with the infromation that can be infered from the conditional-statements.\<close>
definition update_range_pre where
"update_range_pre e \<equiv> env_invariant e \<and> mid e = (left e + right e) div 2  \<and> right e > left e"

definition update_left_pre where
"update_left_pre e \<equiv> update_range_pre e \<and> arr e ! mid e < val e"

definition update_right_pre where
"update_right_pre e \<equiv> update_range_pre e \<and> arr e ! mid e > val e"

subsection\<open>Aux lemmas\<close>
text\<open>This lemmas are useful to prove that the update of @{text mid} will still be between @{text left} and @{text right}\<close>
lemma isSmaller: "(x::nat) < y \<Longrightarrow> (y + x) div 2 < y"
  by linarith

lemma isGreater1: "(x::nat) < y \<Longrightarrow> ((y + x) div 2) \<ge> x"
  by linarith

lemma sorted_smaller: "sorted xs \<and>
        m < length xs \<and>
        xs ! m < v \<Longrightarrow>
        (\<forall>x < m. xs ! x < v)"
  by (meson le_less_trans sorted_iff_nth_mono_less)

subsection\<open>Proofs of the definitions\<close>
lemma update_left_spec: "spec (update_left_pre) update_left (GG (env_invariant))"
  unfolding update_range_pre_def env_invariant_def GG_def update_left_pre_def
  apply(simp add: update_left_def)
  apply(intro get_rule; intro allI; simp)
  apply(intro conj_rule_right)
  apply (simp_all add: spec_def put_def put_state_def get_state_def left_Env_def)
  by (metis add.commute sorted_smaller isSmaller less_le_trans)

lemma update_right_spec: "spec (update_right_pre) update_right (GG (env_invariant))"
  unfolding env_invariant_def GG_def update_right_pre_def update_range_pre_def
  apply(simp add: update_right_def)
  apply(intro get_rule; intro allI; simp)
  apply(intro conj_rule_right)
  apply (simp_all add: spec_def put_def put_state_def get_state_def right_Env_def)
  by (metis less_le_trans sorted_iff_nth_mono_less)

lemma update_range_spec: "spec (update_range_pre) update_range (GG (env_invariant))"
  unfolding  GG_def
  apply(simp add: update_range_def)
  apply(intro get_rule; intro allI; clarify)
  apply(intro cond_rule)
  apply (smt GG_def Pair_inject case_prodI2 case_prod_conv spec_def update_left_pre_def update_left_spec)
  apply (smt GG_def Pair_inject case_prodI2 case_prod_conv spec_def update_right_pre_def update_right_spec)
  by(simp add: skip_def spec_def env_invariant_def update_range_pre_def)

section\<open>Proof of BinarySearch\<close>
text\<open>This proof shows how it satisfies the invariants on the environment. It is one of the key-proofs.\<close>
lemma inv_binarySearch: "spec (env_invariant) (BinarySearch n) (GG (env_invariant))"
  unfolding  GG_def
  apply(induction n rule: BinarySearch.induct)
  apply(simp add: spec_def skip_def)
  apply(simp only: caseN)
  apply(intro get_rule; intro allI; clarify)
  apply(intro seq_rule[of _ _ "(\<lambda>x y. env_invariant y \<and> mid y = (left y + right y) div 2)"])
   apply (simp add: spec_def put_def put_state_def get_state_def mid_Env_def env_invariant_def)
  apply linarith
  apply(intro allI)
  apply(intro cond_rule; simp)
  apply(intro seq_rule[of _ _ "(\<lambda>x y. env_invariant y)"])
  apply(simp add: update_range_def)
  apply(intro get_rule; intro allI; clarify)
  apply(intro cond_rule; simp)
  apply(simp add: update_left_def)
  apply(intro get_rule; intro allI; simp)
  apply(simp add: env_invariant_def)
  apply(intro conj_rule_right)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply (metis (no_types, hide_lams) add.commute isSmaller leI less_le_trans sorted_smaller)
  apply (simp add: spec_def put_def put_state_def get_state_def left_Env_def)
  apply(simp add: update_right_def)
  apply(intro get_rule; intro allI; simp)
  apply(simp add: env_invariant_def)
  apply(intro conj_rule_right)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (simp add: spec_def put_def put_state_def get_state_def right_Env_def env_invariant_def)
  apply (metis less_le_trans sorted_iff_nth_mono_less)
  apply(simp add: spec_def skip_def)
  apply blast
  by(simp add: spec_def skip_def)

subsection\<open>Proof of lemma of pre-condition\<close>
text\<open>These proofs show how the @{text init_env} implies/satisfies the invariant on the environment\<close>
lemma empty_range: "(\<forall>i. i > length xs \<and> i \<le> length xs  \<longrightarrow> xs ! i = v)"
  using not_le by blast

lemma init_env_implies_env_inariant: "e = init_env xs v \<Longrightarrow> env_invariant e"
  unfolding init_env_def env_invariant_def
  using empty_range by force

lemma env_inv_implies_q: "env_invariant e \<Longrightarrow> q e"
  unfolding q_def env_invariant_def
  using order_trans by auto

text\<open>This lemma states that pre-condition @{text p1} is enough to show that @{text mid} will point to the value we are looking for if it exists in the array. \<close>
lemma binarySearch_main: "spec (env_invariant) (BinarySearch n) (GG (q))"
  unfolding GG_def
  apply(induction n rule: BinarySearch.induct)
  apply(simp add: spec_def skip_def env_inv_implies_q)
  by (metis GG_def inv_binarySearch env_inv_implies_q strengthen_rule)

text\<open>I can some times be useful to show the correctness of a function using rewriting of the pre-condition to show that the pre-condition and potentially some additional assumptions imply the post-condition. This strategy consists of two proofs:
\begin{enumerate}
\item A proof of the implication from the pre-condition to the post-condition
\item A proof of how the function you want to prove satisfied/keeps the invariant/pre-condition.
\end{enumerate}

I have also learned some valuable lessons about the use of quantifiers.
The universal quantifier should always contain an implication, while the existential should use conjunction instead.
This concerns in this theory the ranges from which the quantified variables are taken from.
\begin{itemize}
\item \<forall>x \<in> A. P(x) is in Isabelle \<forall> x. x \<in> A \<longrightarrow> P(x)
\item \<exists>x \<in> A. P(x) is in Isabelle \<exists> x. x \<in> A /\ P(x)
\end{itemize}
When working with quantifiers and arrays, it is important to make sure that all variables that are satisfying the predicates of the range are also valid indexes in the array. This does often require an addition predicate about the quantified variable should be in the array (less than the length of the array)

I will also like to add that some algorithms are easier constructed using a syntax that contains a while-loop.

It is easier to prove something where all variables are stored in the state-monad and not being passed around in the program.
This makes all functions simpler and has the benefit that the state of the program can be expected and used in pre- and post-conditions.
\<close>

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Explicit Formulas for Roots\<close>

text \<open>We provide algorithms which use the explicit formulas to
  compute the roots of polynomials of degree up to 2. For polynomials of degree
  3 and 4 have a look at the AFP entry "Cubic-Quartic-Equations".\<close>

theory Explicit_Roots
imports
  Polynomial_Interpolation.Missing_Polynomial
  Sqrt_Babylonian.Sqrt_Babylonian
begin

lemma roots0: assumes p: "p \<noteq> 0" and p0: "degree p = 0"
  shows "{x. poly p x = 0} = {}"
  using degree0_coeffs[OF p0] p by auto

definition roots1 :: "'a :: field poly \<Rightarrow> 'a" where
  "roots1 p = (- coeff p 0 / coeff p 1)"

lemma roots1: fixes p :: "'a :: field poly"
  assumes p1: "degree p = 1"
  shows "{x. poly p x = 0} = {roots1 p}"
  using degree1_coeffs[OF p1] unfolding roots1_def
  by (auto simp: add_eq_0_iff nonzero_neg_divide_eq_eq2)

lemma roots2: fixes p :: "'a :: field_char_0 poly"
  assumes p2: "p = [: c, b, a :]" and a: "a \<noteq> 0"
  shows "{x. poly p x = 0} = { - ( b / (2 * a)) + e | e. e^2 = ( b / (2 * a))^2 - c/a}" (is "?l = ?r")
proof -
  define b2a where "b2a = b / (2 * a)"
  {
    fix x
    have "(x \<in> ?l) = (x * x * a + x * b + c = 0)" unfolding p2 by (simp add: field_simps)
    also have "\<dots> = ((x * x + 2 * x * b2a) + c/a = 0)" using a by (auto simp: b2a_def field_simps)
    also have "x * x + 2 * x * b2a = (x * x + 2 * x * b2a + b2a^2) - b2a^2" by simp
    also have "\<dots> = (x + b2a) ^ 2 - b2a ^ 2"
      by (simp add: field_simps power2_eq_square)
    also have "(\<dots> + c / a = 0) = ((x + b2a) ^ 2 = b2a^2 - c/a)" by algebra
    also have "\<dots> = (x \<in> ?r)" unfolding b2a_def[symmetric] by (auto simp: field_simps)
    finally have "(x \<in> ?l) = (x \<in> ?r)" .
  }
  thus ?thesis by auto
qed

definition croots2 :: "complex poly \<Rightarrow> complex list" where
  "croots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a;
    e = csqrt bac
    in
     remdups [- b2a + e, - b2a - e])"

definition complex_rat :: "complex \<Rightarrow> bool" where
  "complex_rat x = (Re x \<in> \<rat> \<and> Im x \<in> \<rat>)"

lemma croots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (croots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "set (croots2 p) = {- b2a + csqrt bac, - b2a - csqrt bac}"
    unfolding croots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric]
    by (auto split: if_splits)
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    using power2_eq_iff by fastforce
qed

definition rroots2 :: "real poly \<Rightarrow> real list" where
  "rroots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a
  in if bac = 0 then [- b2a] else if bac < 0 then []
    else let e = sqrt bac
    in
     [- b2a + e, - b2a - e])"

definition rat_roots2 :: "rat poly \<Rightarrow> rat list" where
  "rat_roots2 p = (let a = coeff p 2; b = coeff p 1; c = coeff p 0; b2a = b / (2 * a);
    bac = b2a^2 - c/a
  in map (\<lambda> e. - b2a + e) (sqrt_rat bac))"

lemma rroots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (rroots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "set (rroots2 p) = (if bac < 0 then {} else {- b2a + sqrt bac, - b2a - sqrt bac})"
    unfolding rroots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric]
    by (auto split: if_splits)
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    by auto
qed

lemma rat_roots2: assumes "degree p = 2"
  shows "{x. poly p x = 0} = set (rat_roots2 p)"
proof -
  from degree2_coeffs[OF assms] obtain a b c
  where p: "p = [:c, b, a:]" and a: "a \<noteq> 0" by auto
  note main = roots2[OF p a]
  have 2: "2 = Suc (Suc 0)" by simp
  have coeff: "coeff p 2 = a" "coeff p 1 = b" "coeff p 0 = c" unfolding p by (auto simp: 2)
  let ?b2a = "b / (2 * a)"
  define b2a where "b2a = ?b2a"
  let ?bac = "b2a^2 - c/a"
  define bac where "bac = ?bac"
  have roots: "(rat_roots2 p) = (map (\<lambda> e. -b2a + e) (sqrt_rat bac))"
    unfolding rat_roots2_def Let_def coeff b2a_def[symmetric] bac_def[symmetric] by auto
  show ?thesis unfolding roots main b2a_def[symmetric] bac_def[symmetric]
    by (auto simp: power2_eq_square)
qed

text \<open>Determinining roots of complex polynomials of degree up to 2.\<close>

definition croots :: "complex poly \<Rightarrow> complex list" where
  "croots p = (if p = 0 \<or> degree p > 2 then []
    else (if degree p = 0 then [] else if degree p = 1 then [roots1 p]
    else croots2 p))"

lemma croots: assumes "p \<noteq> 0" "degree p \<le> 2"
  shows "set (croots p) = {x. poly p x = 0}"
  using assms unfolding croots_def
  using roots0[of p] roots1[of p] croots2[of p]
  by (auto split: if_splits)

text \<open>Determinining roots of real polynomials of degree up to 2.\<close>

definition rroots :: "real poly \<Rightarrow> real list" where
  "rroots p = (if p = 0 \<or> degree p > 2 then []
    else (if degree p = 0 then [] else if degree p = 1 then [roots1 p]
    else rroots2 p))"

lemma rroots: assumes "p \<noteq> 0" "degree p \<le> 2"
  shows "set (rroots p) = {x. poly p x = 0}"
  using assms unfolding rroots_def
  using roots0[of p] roots1[of p] rroots2[of p]
  by (auto split: if_splits)

end


theory TwoProdFMA
imports
  test_utils
  "$AFP/IEEE_Floating_Point/FloatProperty"
begin

subsection \<open>Fused Multiply-Add (FMA)\<close>

--\<open>FMA returns the float closest to the exact result of a*b+c\<close>
definition "fma_float a b c = Float (Val a * Val b + Val c)"

code_printing constant "fma_float :: float \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" \<rightharpoonup>
  (SML) "Real.*+ ((_), (_), (_))"
declare fma_float_def [code del]

--\<open>This definition might not work in all special cases, consider

value [code] "fma_float Plus_zero (float_neg Plus_zero) (float_neg Plus_zero)"

However, it should suffice for our purposes.\<close>
(*ToDo: ML? *)

subsection \<open>Implementation\<close>

definition twoProdFMA :: "float \<Rightarrow> float \<Rightarrow> float \<times> float" where
  "twoProdFMA a b = (let
    p = a * b;
    e = fma_float a b (float_neg p)
    in (p, e))"

subsection \<open>Properties\<close>

lemma twoProdFMA_correct1_eq:
  assumes "(p, e) = twoProdFMA a b"
  shows "p = a * b"
  using assms by (metis prod.inject twoProdFMA_def)

lemma twoProdFMA_correct1:
  assumes "(p, e) = twoProdFMA a b"
  assumes "Finite (a * b)"
  shows "p \<doteq> (a * b)"
  using assms float_eq twoProdFMA_correct1_eq by blast

lemma twoProdFMA_correct2:
  assumes "(p, e) = twoProdFMA a b"
  assumes "Finite (a * b)"
  --\<open>a*b must be representable as the sum of two floats.
    A sufficient condition is (from HFPA):\<close>
  assumes "Exponent a + Exponent b \<ge>
    - bias float_format + fracwidth float_format + 1"
  shows "Val p + Val e = Val a * Val b"
  sorry

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_NStoogeSortIsSort
  imports "../../Test_Base"
begin

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

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "Nat list => Nat list"
  and nstoogesort :: "Nat list => Nat list"
  and nstooge1sort1 :: "Nat list => Nat list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort xs) = (isort xs))"
  oops

end


theory SINVAR_Dependability
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Dependability *}

type_synonym dependability_level = nat

definition default_node_properties :: "dependability_level"
  where  "default_node_properties \<equiv> 0"

text {* Less-equal other nodes depend on the output of a node than its dependability level. *}
fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (num_reachable G e1) \<le> (nP e1))"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

text{* It does not matter whether we iterate over all edges or all nodes. We chose all edges because it is in line with the other models.  *}
  fun sinvar_nodes :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
    "sinvar_nodes G nP = (\<forall> v \<in> nodes G. (num_reachable G v) \<le> (nP v))"

  theorem sinvar_edges_nodes_iff: "valid_graph G \<Longrightarrow>
    sinvar_nodes G nP = sinvar G nP"
  proof(unfold sinvar_nodes.simps sinvar.simps, rule iffI)
    assume a1: "valid_graph G"
      and  a2: "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v"

      from a1[simplified valid_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
      from f1 a2 have "\<forall>v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      thus "\<forall>(e1, _) \<in> edges G. num_reachable G e1 \<le> nP e1" by auto
    next
    assume a1: "valid_graph G"
      and  a2: "\<forall>(e1, _)\<in>edges G. num_reachable G e1 \<le> nP e1"

      from a2 have g1: "\<forall> v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      from FiniteGraph.succ_tran_empty[OF a1] num_reachable_zero_iff[OF a1, symmetric]
      have g2: "\<forall> v. v \<notin> (fst ` edges G) \<longrightarrow> num_reachable G v \<le> nP v" by (metis le0)

      from g1 g2 show "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v" by metis
  qed

  lemma num_reachable_le_nodes: "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> num_reachable G v \<le> card (nodes G)"
    apply(simp add: num_reachable_def)
    using succ_tran_subseteq_nodes card_seteq  nat_le_linear valid_graph.finiteV by metis

  text{* nP is valid if all dependability level are greater equal the total number of nodes in the graph *}
  lemma "\<lbrakk> valid_graph G; \<forall>v \<in> nodes G. nP v \<ge> card (nodes G) \<rbrakk> \<Longrightarrow> sinvar G nP"
    apply(subst sinvar_edges_nodes_iff[symmetric], simp)
    apply(simp add:)
    using num_reachable_le_nodes by (metis le_trans)

  text{* Generate a valid configuration to start from: *}
   text{* Takes arbitrary configuration, returns a valid one *}
   fun fix_nP :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "fix_nP G nP = (\<lambda>v. if num_reachable G v \<le> (nP v) then (nP v) else num_reachable G v)"

   text{* @{const fix_nP} always gives you a valid solution *}
   lemma fix_nP_valid: "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> sinvar G (fix_nP G nP)"
      by(subst sinvar_edges_nodes_iff[symmetric], simp_all)

   text{* furthermore, it gives you a minimal solution, i.e. if someone supplies a configuration with a value lower than
          calculated by @{const fix_nP}, this is invalid! *}
   lemma fix_nP_minimal_solution: "\<lbrakk> valid_graph G; \<exists> v \<in> nodes G. (nP v) < (fix_nP G (\<lambda>_. 0)) v \<rbrakk> \<Longrightarrow> \<not> sinvar G nP"
      apply(subst sinvar_edges_nodes_iff[symmetric], simp)
      apply(simp)
      apply(clarify)
      apply(rule_tac x="v" in bexI)
       apply(simp_all)
      done

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
apply (simp add: succ_tran_def)
by (metis (lifting, no_types) Collect_cong Range.intros Range_empty Range_insert mem_Collect_eq singleton_conv singleton_iff trancl.r_into_trancl trancl_range)

(*
lemma card_less_equal_trancl: "finite A \<Longrightarrow> card {e2. (aa, e2) \<in> (A - X)\<^sup>+} \<le> card {e2. (aa, e2) \<in> (A)\<^sup>+}"
apply(subgoal_tac "{e2. (aa, e2) \<in> (A - X)\<^sup>+} \<subseteq> {e2. (aa, e2) \<in> (A)\<^sup>+}")
apply(rule card_mono)
defer
apply(simp)
apply (metis (lifting) Collect_mono Diff_subset trancl_mono)
by (metis (lifting) Range_iff finite_Range mem_Collect_eq rev_finite_subset subsetI trancl_range)
*)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
and verify_globals = verify_globals
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF valid_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
 apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
done

interpretation Dependability: SecurityInvariant_ACS
where default_node_properties = SINVAR_Dependability.default_node_properties
and sinvar = SINVAR_Dependability.sinvar
and verify_globals = verify_globals
  unfolding SINVAR_Dependability.default_node_properties_def
  apply unfold_locales
   apply simp
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp split: split_split_asm split_split)
   apply (simp add:graph_ops)
   apply(clarify)
   apply (metis gr0I le0)
  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: split_split_asm split_split)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: valid_graph_def)
  apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 0, vertex_2 := 0)" in exI, simp)
  apply(rule conjI)
   apply(simp add: unique_default_example num_reachable_def)
  apply(rule_tac x="vertex_1" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(simp add: unique_default_example num_reachable_def)
  apply(simp add: succ_tran_def unique_default_example_simp1 unique_default_example_simp2)
  done

  lemma TopoS_Dependability: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar verify_globals receiver_violation default_node_properties

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_StoogeSortSorts
imports "../../Test_Base"
begin

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

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

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

theorem property0 :
  "ordered (stoogesort xs)"
  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_bin_nat_times_comm
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x y) = (times y x))"
  oops

end


theory NgFHOL_nonpol imports Main
begin

(* A nonpolymorphic Embedding of Negative Free Higher-Order Logic (NgFHOL) in HOL *)

text \<open> Negative Free Higher-Order Logic \<close>

  typedecl i (* — Type for individuals *)

  consts fExistenceI :: "i \<Rightarrow> bool" ("E\<^sup>i") (* — Existence/definedness predicate for individuals *)
  consts fExistenceP :: "(i \<Rightarrow> bool) \<Rightarrow> bool" ("E\<^sup>p") (* — Existence/definedness predicate for predicates *)

  consts fUndefI :: "i" ("\<^bold>e\<^sup>i") (* Distinguished symbol for undefinedness amongst the individuals *)
  axiomatization where fUndefIAxiom: "\<not>E\<^sup>i \<^bold>e\<^sup>i"

  consts fFalsehoodB :: "bool" ("\<^bold>e\<^sup>b") (* Distinguished error value among the booleans *)
  axiomatization where fFalsehoodBAxiom: "\<^bold>e\<^sup>b = False"

  (*
  axiomatization where fNonemptyDomainI: "\<exists>x. E\<^sup>i x"
  axiomatization where fNonemptyDomainP: "\<exists>x. E\<^sup>p x"
  *)

  definition fIdentityI :: "i \<Rightarrow> i \<Rightarrow> bool" (infixr "\<^bold>=" 56) (* — Free identity *)
    where "\<phi> \<^bold>= \<psi> \<equiv> E\<^sup>i \<phi> \<and> E\<^sup>i \<psi> \<and> (\<phi> = \<psi>)"

  definition fNot :: "bool \<Rightarrow> bool" ("\<^bold>\<not>_" [52]53) (* — Free negation *)
    where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
  definition fOr :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<or>" 51) (* — Free disjunction *)
    where "\<phi> \<^bold>\<or> \<psi> \<equiv> \<phi> \<or> \<psi>"

  definition fForallI :: "(i \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<forall>\<^sup>i") (* — Free universal quantification over individuals guarded by predicate E *)
    where "\<^bold>\<forall>\<^sup>i\<Phi> \<equiv> \<forall>x. E\<^sup>i x \<longrightarrow> \<Phi> x"
  definition fForallIBinder:: "(i \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<forall>\<^sup>i" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>ix. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>i\<phi>"
  definition fForallP :: "((i \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<forall>\<^sup>p") (* — Free universal quantification over predicates guarded by predicate E *)
    where "\<^bold>\<forall>\<^sup>p\<Phi> \<equiv> \<forall>x. E\<^sup>p x \<longrightarrow> \<Phi> x"
  definition fForallPBinder:: "((i \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<forall>\<^sup>p" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>px. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>p\<phi>"

  definition fThatI :: "(i \<Rightarrow> bool) \<Rightarrow> i" ("\<^bold>I") (* — Free definite description for individuals guarded by predicate E *)
    where "\<^bold>I\<Phi> \<equiv> if \<exists>x. E\<^sup>i x \<and> \<Phi> x \<and> (\<forall>y. (E\<^sup>i y \<and> \<Phi> y) \<longrightarrow> (y = x))
                 then THE x. E\<^sup>i x \<and> \<Phi> x
                 else \<^bold>e\<^sup>i"
  definition fThatIBinder:: "(i \<Rightarrow> bool) \<Rightarrow> i" (binder "\<^bold>I" [8]9) (* — Binder notation *)
    where "\<^bold>Ix. \<phi> x \<equiv> \<^bold>I\<phi>"

  definition fPredicateI1 :: "(i \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> bool" ("\<^sup>i") (* — Free predicate taking an individual guarded by predicate E *)
    where "\<^sup>iP x \<equiv> E\<^sup>i x \<and> P x"
  definition fPredicateI2 :: "(i \<Rightarrow> i \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool" ("\<^sup>i\<^sup>i") (* — Free predicate taking two individuals guarded by predicate E *)
    where "\<^sup>i\<^sup>iP x y \<equiv> E\<^sup>i x \<and> E\<^sup>i y \<and> P x y"

  text \<open> Further logical constants can be defined as usual \<close>

  definition fAnd :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<and>" 52) (* — Free conjunction *)
    where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
  definition fImp :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<rightarrow>" 49) (* — Free implication *)
    where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<^bold>\<not>\<phi> \<^bold>\<or> \<psi>"
  definition fEquiv :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<leftrightarrow>" 50) (* — Free equivalence *)
    where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> \<phi> \<^bold>\<rightarrow> \<psi> \<^bold>\<and> \<psi> \<^bold>\<rightarrow> \<phi>"

  definition fExistsI :: "(i \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<exists>\<^sup>i") (* — Free existential quantification over individuals *)
    where "\<^bold>\<exists>\<^sup>i\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>\<^sup>i(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  definition fExistsIBinder :: "(i \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<exists>\<^sup>i" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>ix. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>i\<phi>"
  definition fExistsP :: "((i \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<exists>\<^sup>p") (* — Free existential quantification over predicates *)
    where "\<^bold>\<exists>\<^sup>p\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>\<^sup>p(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  definition fExistsPBinder :: "((i \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<exists>\<^sup>p" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>px. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>p\<phi>"

  (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
  named_theorems Defs declare fIdentityI_def[Defs] fNot_def[Defs] fOr_def[Defs] fForallI_def[Defs]
    fForallIBinder_def[Defs] fForallP_def[Defs] fForallPBinder_def[Defs] fThatI_def[Defs]
    fPredicateI1_def[Defs] fPredicateI2_def[Defs] fThatIBinder_def[Defs] fAnd_def[Defs]
    fImp_def[Defs] fEquiv_def[Defs] fExistsI_def[Defs] fExistsIBinder_def[Defs] fExistsP_def[Defs]
    fExistsPBinder_def[Defs]

text \<open> Some Tests \<close>

  lemma "(\<^bold>\<forall>\<^sup>ix. \<^sup>iP x) \<^bold>\<rightarrow>  \<^sup>iP x" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "((\<^bold>\<forall>\<^sup>ix. (\<^sup>iP x)) \<^bold>\<and> (E\<^sup>i x)) \<^bold>\<rightarrow> (\<^sup>iP x)" unfolding Defs by auto (* properly valid *)

  lemma "\<^sup>iP x \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>ix. \<^sup>iP x)" unfolding Defs by auto (* properly valid *)
  lemma "(x \<^bold>= x) \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>ix. (x \<^bold>= x))" unfolding Defs by auto (* properly valid *)
  lemma "(x \<^bold>= y) \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>ix. (x \<^bold>= y))" unfolding Defs by auto (* properly valid *)
  lemma "(\<^sup>iP x) \<^bold>\<and> (\<^bold>\<exists>\<^sup>ix. \<^sup>iP x)" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "(\<^sup>iP x) \<^bold>\<rightarrow> (E\<^sup>i x)" unfolding Defs by simp (* properly valid *)

  lemma "(\<^sup>iP x) \<^bold>\<or> (\<^bold>\<not>(\<^sup>iP x))" unfolding Defs by auto (* properly valid *)
  lemma "(\<^sup>iP x) \<^bold>\<and> (\<^bold>\<not>(\<^sup>iP x))" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<^bold>\<not>((\<^sup>iP x) \<^bold>\<and> (\<^bold>\<not>(\<^sup>iP x)))" unfolding Defs by auto (* properly valid *)

  consts fIndividual1 :: "i" ("i\<^sub>1")
  axiomatization where fUndefIndividual1Axiom: "\<^bold>\<not>(E\<^sup>i i\<^sub>1)"

  consts fIndividual2 :: "i" ("i\<^sub>2")
  axiomatization where fUndefIndividual2Axiom: "\<^bold>\<not>(E\<^sup>i i\<^sub>2)"

  lemma "x \<^bold>= x" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "i\<^sub>1 \<^bold>= i\<^sub>1" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<^bold>\<not>(i\<^sub>1 \<^bold>= i\<^sub>1)" unfolding Defs using fNot_def fUndefIndividual1Axiom by auto (* properly valid *)

  lemma "(\<^sup>iP i\<^sub>1)" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<^bold>\<not>(\<^sup>iP i\<^sub>1)" unfolding Defs using fNot_def fUndefIndividual1Axiom by auto

  lemma test_True: "True" by simp
  lemma test_False: "False" nitpick [satisfy, user_axioms=true] oops

text \<open> Prior's Theorem \<close>

  lemma "(Q (\<forall>p. (Q p \<longrightarrow> (\<not>p)))) \<longrightarrow> ((\<exists>p. Q p \<and> p) \<and> (\<exists>p. Q p \<and> (\<not>p)))" by blast

  consts fExistenceB :: "bool \<Rightarrow> bool" ("E\<^sup>b") (* — Existence/definedness predicate for booleans *)

  axiomatization where fTrueAxiom: "E\<^sup>b True"
  axiomatization where fFalseAxiom: "E\<^sup>b False"

  definition fForallB :: "(bool \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<forall>\<^sup>b") (* — Free universal quantification over booleans guarded by predicate E *)
    where "\<^bold>\<forall>\<^sup>b\<Phi> \<equiv> \<forall>x. E\<^sup>b x \<longrightarrow> \<Phi> x"
  definition fForallBBinder:: "(bool \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<forall>\<^sup>b" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>bx. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>b\<phi>"

  definition fExistsB :: "(bool \<Rightarrow> bool) \<Rightarrow> bool" ("\<^bold>\<exists>\<^sup>b") (* — Free existential quantification over booleans *)
    where "\<^bold>\<exists>\<^sup>b\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>\<^sup>b(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  definition fExistsBBinder :: "(bool \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<exists>\<^sup>b" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>bx. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>b\<phi>"

  definition fPredicateB1 :: "(bool \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> bool" ("\<^sup>b") (* — Free predicate taking a boolean guarded by predicate E *)
    where "\<^sup>bP x \<equiv> E\<^sup>b x \<and> P x"

  lemma "(\<^sup>bQ (\<^bold>\<forall>\<^sup>bp. (\<^sup>bQ p \<^bold>\<rightarrow> (\<^bold>\<not>p)))) \<^bold>\<rightarrow> ((\<^bold>\<exists>\<^sup>bp. \<^sup>bQ p \<^bold>\<and> p) \<^bold>\<and> (\<^bold>\<exists>\<^sup>bp. \<^sup>bQ p \<^bold>\<and> (\<^bold>\<not>p)))"
    unfolding Defs
    by (smt fPredicateB1_def fExistsBBinder_def fExistsB_def fForallBBinder_def fForallB_def fNot_def)