(* Title:      Containers/Collection_Order.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)

theory Collection_Order
imports
  Set_Linorder
  Containers_Generator
  "../Datatype_Order_Generator/Order_Generator"
begin

chapter {* Light-weight containers *}
text_raw {* \label{chapter:light-weight:containers} *}

section {* A linear order for code generation *}

subsection {* Optional linear orders *}

class corder =
  fixes corder :: "(('a \<Rightarrow> 'a \<Rightarrow> bool) * ('a \<Rightarrow> 'a \<Rightarrow> bool)) option"
  assumes corder: "\<And>less_eq less. corder = Some (less_eq, less) \<Longrightarrow> class.linorder less_eq less"
begin

lemma ID_corder: "\<And>less_eq less. ID corder = Some (less_eq, less) \<Longrightarrow> class.linorder less_eq less"
unfolding ID_def id_apply by(rule corder)

abbreviation cless_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "cless_eq \<equiv> fst (the (ID corder))"
abbreviation cless :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "cless \<equiv> snd (the (ID corder))"

end

syntax "_CORDER" :: "type => logic" ("(1CORDER/(1'(_')))")

parse_translation {*
let
  fun corder_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "corder"} $
       (Syntax.const @{type_syntax option} $
         (Syntax.const @{type_syntax prod} $
           (Syntax.const @{type_syntax fun} $ ty $
             (Syntax.const @{type_syntax fun} $ ty $ Syntax.const @{type_syntax bool})) $
           (Syntax.const @{type_syntax fun} $ ty $
             (Syntax.const @{type_syntax fun} $ ty $ Syntax.const @{type_syntax bool})))))
    | corder_tr ts = raise TERM ("corder_tr", ts);
in [(@{syntax_const "_CORDER"}, K corder_tr)] end
*}

typed_print_translation {*
let
  fun corder_tr' ctxt
    (Type (@{type_name option}, [Type (@{type_name prod}, [Type (@{type_name fun}, [T, _]), _])])) ts =
    Term.list_comb (Syntax.const @{syntax_const "_CORDER"} $ Syntax_Phases.term_of_typ ctxt T, ts)
  | corder_tr' _ _ _ = raise Match;
in [(@{const_syntax corder}, corder_tr')]
end
*}

context corder begin

lemma cless_eq_conv_cless:
  fixes a b :: "'a"
  assumes "ID CORDER('a) \<noteq> None"
  shows "cless_eq a b \<longleftrightarrow> cless a b \<or> a = b"
proof -
  from assms interpret linorder cless_eq "cless :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
    by(clarsimp simp add: ID_corder)
  show ?thesis by(rule le_less)
qed

end

definition is_corder :: "'a :: corder itself \<Rightarrow> bool"
where "is_corder _ \<longleftrightarrow> ID CORDER('a) \<noteq> None"

subsection {* Generator for the @{class corder}-class *}

text {*
This generator registers itself at the derive-manager for the class
@{class corder}. To be more precise, one can choose whether one does not want to
support a linear order by passing parameter "no", one wants to register an arbitrary type which
is already in class @{class linorder} using parameter "linorder", or
one wants to generate a new linear order by passing no parameter.
In the last case, one demands that the type is a datatype
and that all non-recursive types of that datatype are in class @{class linorder}.

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (no) corder}
\item \texttt{instantiation type :: (linorder,\ldots,linorder) corder}
\item \texttt{instantiation datatype :: (linorder,\ldots,linorder) (linorder) corder}
\end{itemize}

If the parameter "no" is not used, then the corresponding
@{term is_corder}-theorem is automatically generated and attributed with
\texttt{[simp, code-post]}.
*}

text {*
To create a new ordering, we just invoke the functionality provided by the order generator.
The only difference is the boilerplate-code, which for the order generator has to perform
the class instantiation for an order, whereas here we have to invoke the methods to
satisfy the corresponding locale for linear orders.
*}

text {*
This generator can be used for arbitrary types, not just datatypes.
When passing no parameters, we get same limitation as for the order generator.
For mutual recursive datatypes, only for the first mentioned datatype the instantiations
of the @{class corder} classes are derived.
*}

lemma corder_intro: "class.linorder le lt \<Longrightarrow> a = Some (le, lt)\<Longrightarrow> a = Some (le',lt') \<Longrightarrow>
  class.linorder le' lt'" by auto

ML_file "corder_generator.ML"

setup {*
  Corder_Generator.setup
*}

subsection {* Instantiations for HOL types *}

derive (linorder) corder unit
derive (linorder) corder bool
derive (linorder) corder nat
derive (linorder) corder int
derive (linorder) corder Enum.finite_1
derive (linorder) corder Enum.finite_2
derive (linorder) corder Enum.finite_3
derive (no) corder Enum.finite_4
derive (no) corder Enum.finite_5

derive (linorder) corder integer
derive (linorder) corder natural
derive (linorder) corder nibble
derive (linorder) corder char
derive (linorder) corder String.literal

instantiation sum :: (corder, corder) corder begin
definition "CORDER('a + 'b) =
  (case ID CORDER('a) of None \<Rightarrow> None
   | Some (leq_a, lt_a) \<Rightarrow>
     case ID CORDER('b) of None \<Rightarrow> None
     | Some (leq_b, lt_b) \<Rightarrow>
       Some
         (\<lambda>x y. case x of Inl xl \<Rightarrow> (case y of Inl yl \<Rightarrow> leq_a xl yl | _ \<Rightarrow> True)
                | Inr xr \<Rightarrow> (case y of Inr yr \<Rightarrow> leq_b xr yr | _ \<Rightarrow> False),
          \<lambda>x y. case x of Inl xl \<Rightarrow> (case y of Inl yl \<Rightarrow> lt_a xl yl | _ \<Rightarrow> True)
                | Inr xr \<Rightarrow> (case y of Inr yr \<Rightarrow> lt_b xr yr | _ \<Rightarrow> False)))"
instance
proof(intro_classes)
  fix leq lt
  assume "CORDER('a + 'b) = Some (leq, lt)"
  then obtain leq_a lt_a leq_b lt_b
    where a: "ID CORDER('a) = Some (leq_a, lt_a)"
    and b: "ID CORDER('b) = Some (leq_b, lt_b)"
    and leq: "\<And>x y. leq x y = (case x of Inl xl \<Rightarrow> (case y of Inl yl \<Rightarrow> leq_a xl yl | _ \<Rightarrow> True)
                               | Inr xr \<Rightarrow> (case y of Inr yr \<Rightarrow> leq_b xr yr | _ \<Rightarrow> False))"
    and lt: "\<And>x y. lt x y = (case x of Inl xl \<Rightarrow> (case y of Inl yl \<Rightarrow> lt_a xl yl | _ \<Rightarrow> True)
                             | Inr xr \<Rightarrow> (case y of Inr yr \<Rightarrow> lt_b xr yr | _ \<Rightarrow> False))"
    by(fastforce simp add: corder_sum_def split: option.split_asm)
  from a interpret a!: linorder leq_a lt_a by(rule ID_corder)
  from b interpret b!: linorder leq_b lt_b by(rule ID_corder)
  show "class.linorder leq lt"
    by(unfold_locales)(auto simp add: lt leq split: sum.splits)
qed
end

lemma is_corder_sum [simp, code_post]:
  "is_corder TYPE('a + 'b) \<longleftrightarrow> is_corder TYPE('a :: corder) \<and> is_corder TYPE('b :: corder)"
by(simp add: is_corder_def corder_sum_def ID_None ID_Some split: option.split)

instantiation prod :: (corder, corder) corder begin
definition "CORDER('a * 'b) =
  (case ID CORDER('a) of None \<Rightarrow> None
   | Some (leq_a, lt_a) \<Rightarrow>
     case ID CORDER('b) of None \<Rightarrow> None
     | Some (leq_b, lt_b) \<Rightarrow>
       Some (less_eq_prod leq_a lt_a leq_b, less_prod leq_a lt_a lt_b))"
instance
proof
  fix leq lt
  assume "CORDER('a * 'b) = Some (leq, lt)"
  then obtain leq_a lt_a leq_b lt_b
    where a: "ID CORDER('a) = Some (leq_a, lt_a)"
    and b: "ID CORDER('b) = Some (leq_b, lt_b)"
    and leq: "leq = less_eq_prod leq_a lt_a leq_b"
    and lt: "lt = less_prod leq_a lt_a lt_b"
    by(auto simp add: corder_prod_def split: option.split_asm prod.split_asm)
  from a b have "class.linorder leq_a lt_a" "class.linorder leq_b lt_b"
    by(blast intro: ID_corder)+
  thus "class.linorder leq lt" unfolding leq lt by(rule linorder_prod)
qed
end

lemma is_corder_prod [simp, code_post]:
  "is_corder TYPE('a \<times> 'b) \<longleftrightarrow> is_corder TYPE('a :: corder) \<and> is_corder TYPE('b :: corder)"
by(simp add: is_corder_def corder_prod_def ID_None ID_Some split: option.split)

instantiation list :: (corder) corder begin
definition "CORDER('a list) =
  map_option (\<lambda>(leq, lt). (\<lambda>xs ys. ord.lexordp_eq lt xs ys, ord.lexordp lt)) (ID CORDER('a))"
instance
proof
  fix leq lt
  assume "CORDER('a list) = Some (leq, lt)"
  then obtain leq_a lt_a where a: "ID CORDER('a) = Some (leq_a, lt_a)"
    and leq: "\<And>xs ys. leq xs ys \<longleftrightarrow> ord.lexordp_eq lt_a xs ys"
    and lt: "\<And>xs ys. lt xs ys \<longleftrightarrow> ord.lexordp lt_a xs ys"
    by(auto simp add: corder_list_def)
  from a interpret a!: linorder leq_a lt_a by(rule ID_corder)
  show "class.linorder leq lt" unfolding leq[abs_def] lt[abs_def]
    by(rule a.lexordp_linorder)
qed
end

lemma is_corder_list [simp, code_post]:
  "is_corder TYPE('a list) \<longleftrightarrow> is_corder TYPE('a :: corder)"
by(simp add: is_corder_def corder_list_def ID_def)

instantiation option :: (corder) corder begin
definition "CORDER('a option) =
  map_option (\<lambda>(leq, lt). (\<lambda>x y. case x of None \<Rightarrow> True | Some x' \<Rightarrow> case y of None \<Rightarrow> False | Some y' \<Rightarrow> leq x' y',
                           \<lambda>x y. case y of None \<Rightarrow> False | Some y' \<Rightarrow> case x of None \<Rightarrow> True | Some x' \<Rightarrow> lt x' y'))
    (ID CORDER('a))"
instance
proof
  fix leq lt
  assume "CORDER('a option) = Some (leq, lt)"
  then obtain leq_a lt_a where a: "ID CORDER('a) = Some (leq_a, lt_a)"
    and leq: "\<And>x y. leq x y \<longleftrightarrow> (case x of None \<Rightarrow> True | Some x' \<Rightarrow> case y of None \<Rightarrow> False | Some y' \<Rightarrow> leq_a x' y')"
    and lt: "\<And>x y. lt x y \<longleftrightarrow> (case y of None \<Rightarrow> False | Some y' \<Rightarrow> case x of None \<Rightarrow> True | Some x' \<Rightarrow> lt_a x' y')"
    by(auto simp add: corder_option_def)
  from a interpret a!: linorder leq_a lt_a by(rule ID_corder)
  show "class.linorder leq lt" by(unfold_locales)(auto simp add: leq lt split: option.splits)
qed
end

lemma is_corder_option [simp, code_post]:
  "is_corder TYPE('a option) \<longleftrightarrow> is_corder TYPE('a :: corder)"
by(simp add: is_corder_def corder_option_def ID_def)

derive (no) corder "fun"

lemma is_corder_fun [simp]: "\<not> is_corder TYPE('a \<Rightarrow> 'b)"
by(simp add: is_corder_def corder_fun_def ID_None)

instantiation set :: (corder) corder begin
definition "CORDER('a set) = map_option (\<lambda>(leq, lt). (ord.set_less_eq leq, ord.set_less leq)) (ID CORDER('a))"
instance by(intro_classes)(auto simp add: corder_set_def intro: linorder.set_less_eq_linorder ID_corder)
end

lemma is_corder_set [simp, code_post]:
  "is_corder TYPE('a set) \<longleftrightarrow> is_corder TYPE('a :: corder)"
by(simp add: is_corder_def corder_set_def ID_def)

definition cless_eq_set :: "'a :: corder set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del]: "cless_eq_set = fst (the (ID CORDER('a set)))"

definition cless_set :: "'a :: corder set \<Rightarrow> 'a set \<Rightarrow> bool"
where [simp, code del]: "cless_set = snd (the (ID CORDER('a set)))"

lemma corder_set_code [code]:
  "CORDER('a :: corder set) = (case ID CORDER('a) of None \<Rightarrow> None | Some _ \<Rightarrow> Some (cless_eq_set, cless_set))"
by(clarsimp simp add: corder_set_def ID_Some split: option.split)

derive (no) corder Predicate.pred

subsection {* Proper intervals *}

class cproper_interval = corder +
  fixes cproper_interval :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
  assumes cproper_interval:
  "\<lbrakk> ID CORDER('a) \<noteq> None; finite (UNIV :: 'a set) \<rbrakk>
  \<Longrightarrow> class.proper_interval cless cproper_interval"
begin

lemma ID_corder_interval:
  "\<lbrakk> ID CORDER('a) = Some (leq, lt); finite (UNIV :: 'a set) \<rbrakk>
  \<Longrightarrow> class.linorder_proper_interval leq lt cproper_interval"
using cproper_interval
by(simp add: ID_corder class.linorder_proper_interval_def)

end

instantiation unit :: cproper_interval begin
definition "cproper_interval = (proper_interval :: unit proper_interval)"
instance by(intro_classes)(simp add: cproper_interval_unit_def corder_unit_def ID_Some proper_interval_class.axioms)
end

instantiation bool :: cproper_interval begin
definition "cproper_interval = (proper_interval :: bool proper_interval)"
instance by(intro_classes)(simp add: cproper_interval_bool_def corder_bool_def ID_Some proper_interval_class.axioms)
end

instantiation nat :: cproper_interval begin
definition "cproper_interval = (proper_interval :: nat proper_interval)"
instance by intro_classes simp
end

instantiation int :: cproper_interval begin
definition "cproper_interval = (proper_interval :: int proper_interval)"
instance by intro_classes (simp add: cproper_interval_int_def corder_int_def ID_Some proper_interval_class.axioms)
end

instantiation integer :: cproper_interval begin
definition "cproper_interval = (proper_interval :: integer proper_interval)"
instance by intro_classes (simp add: cproper_interval_integer_def corder_integer_def ID_Some proper_interval_class.axioms)
end

instantiation natural :: cproper_interval begin
definition "cproper_interval = (proper_interval :: natural proper_interval)"
instance by intro_classes (simp add: cproper_interval_natural_def corder_natural_def ID_Some proper_interval_class.axioms)
end

instantiation nibble :: cproper_interval begin
definition "cproper_interval = (proper_interval :: nibble proper_interval)"
instance by intro_classes (simp add: cproper_interval_nibble_def corder_nibble_def ID_Some proper_interval_class.axioms)
end

instantiation char :: cproper_interval begin
definition "cproper_interval = (proper_interval :: char proper_interval)"
instance by intro_classes (simp add: cproper_interval_char_def corder_char_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_1 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_1 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_1_def corder_finite_1_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_2 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_2 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_2_def corder_finite_2_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_3 :: cproper_interval begin
definition "cproper_interval = (proper_interval :: Enum.finite_3 proper_interval)"
instance by intro_classes (simp add: cproper_interval_finite_3_def corder_finite_3_def ID_Some proper_interval_class.axioms)
end

instantiation Enum.finite_4 :: cproper_interval begin
definition "(cproper_interval :: Enum.finite_4 proper_interval) _ _ = undefined"
instance by intro_classes(simp add: corder_finite_4_def ID_None)
end

instantiation Enum.finite_5 :: cproper_interval begin
definition "(cproper_interval :: Enum.finite_5 proper_interval) _ _ = undefined"
instance by intro_classes(simp add: corder_finite_5_def ID_None)
end

instantiation sum :: (cproper_interval, cproper_interval) cproper_interval begin
fun cproper_interval_sum :: "('a + 'b) proper_interval" where
  "cproper_interval_sum None None \<longleftrightarrow> True"
| "cproper_interval_sum None (Some (Inl x)) \<longleftrightarrow> cproper_interval None (Some x)"
| "cproper_interval_sum None (Some (Inr y)) \<longleftrightarrow> True"
| "cproper_interval_sum (Some (Inl x)) None \<longleftrightarrow> True"
| "cproper_interval_sum (Some (Inl x)) (Some (Inl y)) \<longleftrightarrow> cproper_interval (Some x) (Some y)"
| "cproper_interval_sum (Some (Inl x)) (Some (Inr y)) \<longleftrightarrow> cproper_interval (Some x) None \<or> cproper_interval None (Some y)"
| "cproper_interval_sum (Some (Inr y)) None \<longleftrightarrow> cproper_interval (Some y) None"
| "cproper_interval_sum (Some (Inr y)) (Some (Inl x)) \<longleftrightarrow> False"
| "cproper_interval_sum (Some (Inr x)) (Some (Inr y)) \<longleftrightarrow> cproper_interval (Some x) (Some y)"
instance
proof
  assume "ID CORDER('a + 'b) \<noteq> None" "finite (UNIV :: ('a + 'b) set)"
  then obtain leq_a lt_a leq_b lt_b
    where A: "ID CORDER('a) = Some (leq_a, lt_a)" "finite (UNIV :: 'a set)"
    and B: "ID CORDER('b) = Some (leq_b, lt_b)" "finite (UNIV :: 'b set)"
    by(fastforce simp add: corder_sum_def ID_Some ID_None split: option.split_asm)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval] corder_sum_def ID_Some
    and [split] = sum.split
  show "class.proper_interval cless (cproper_interval :: ('a + 'b) proper_interval)"
  proof
    fix y :: "'a + 'b"
    show "cproper_interval None (Some y) = (\<exists>z. cless z y)"
      using A B by(cases y)(auto, case_tac z, auto)

    fix x :: "'a + 'b"
    show "cproper_interval (Some x) None = (\<exists>z. cless x z)"
      using A B by(cases x)(auto, case_tac z, auto)

    show "cproper_interval (Some x) (Some y) = (\<exists>z. cless x z \<and> cless z y)"
      using A B by(cases x)(case_tac [!] y, auto, case_tac [!] z, auto)
  qed simp
qed
end

instantiation prod :: (cproper_interval, cproper_interval) cproper_interval begin
fun cproper_interval_prod :: "('a \<times> 'b) proper_interval" where
  "cproper_interval_prod None None \<longleftrightarrow> True"
| "cproper_interval_prod None (Some (y1, y2)) \<longleftrightarrow> cproper_interval None (Some y1) \<or> cproper_interval None (Some y2)"
| "cproper_interval_prod (Some (x1, x2)) None \<longleftrightarrow> cproper_interval (Some x1) None \<or> cproper_interval (Some x2) None"
| "cproper_interval_prod (Some (x1, x2)) (Some (y1, y2)) \<longleftrightarrow>
   cproper_interval (Some x1) (Some y1) \<or>
   cless x1 y1 \<and> (cproper_interval (Some x2) None \<or> cproper_interval None (Some y2)) \<or>
   \<not> cless y1 x1 \<and> cproper_interval (Some x2) (Some y2)"
instance
proof
  assume "ID CORDER('a \<times> 'b) \<noteq> None" "finite (UNIV :: ('a \<times> 'b) set)"
  then obtain leq_a lt_a leq_b lt_b
    where A: "ID CORDER('a) = Some (leq_a, lt_a)" "finite (UNIV :: 'a set)"
    and B: "ID CORDER('b) = Some (leq_b, lt_b)" "finite (UNIV :: 'b set)"
    by(fastforce simp add: corder_prod_def ID_Some ID_None finite_prod split: option.split_asm)
  interpret a!: linorder leq_a lt_a by(rule ID_corder)(rule A)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval] corder_prod_def ID_Some
    and [split] = sum.split
  show "class.proper_interval cless (cproper_interval :: ('a \<times> 'b) proper_interval)" using A B
    by unfold_locales (auto 4 4)
qed
end

instantiation list :: (corder) cproper_interval begin
definition cproper_interval_list :: "'a list proper_interval"
where "cproper_interval_list xso yso = undefined"
instance by(intro_classes)(simp add: infinite_UNIV_listI)
end

lemma UNIV_literal_eq_range_STR: "UNIV = range STR"
by(auto intro: explode_inverse[symmetric])

lemma infinite_UNIV_literal: "\<not> finite (UNIV :: String.literal set)"
by(auto simp add: UNIV_literal_eq_range_STR infinite_UNIV_listI dest!: finite_imageD intro: inj_onI)

instantiation String.literal :: cproper_interval begin
definition cproper_interval_literal :: "String.literal proper_interval"
where "cproper_interval_literal xso yso = undefined"
instance by(intro_classes)(simp add: infinite_UNIV_literal)
end

instantiation option :: (cproper_interval) cproper_interval begin
fun cproper_interval_option :: "'a option proper_interval" where
  "cproper_interval_option None None \<longleftrightarrow> True"
| "cproper_interval_option None (Some x) \<longleftrightarrow> x \<noteq> None"
| "cproper_interval_option (Some x) None \<longleftrightarrow> cproper_interval x None"
| "cproper_interval_option (Some x) (Some None) \<longleftrightarrow> False"
| "cproper_interval_option (Some x) (Some (Some y)) \<longleftrightarrow> cproper_interval x (Some y)"
instance
proof
  assume "ID CORDER('a option) \<noteq> None" "finite (UNIV :: 'a option set)"
  then obtain leq_a lt_a
    where A: "ID CORDER('a) = Some (leq_a, lt_a)" "finite (UNIV :: 'a set)"
    by(auto simp add: corder_option_def ID_def)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval] corder_option_def ID_Some
  show "class.proper_interval cless (cproper_interval :: 'a option proper_interval)" using A
  proof(unfold_locales)
    fix x y :: "'a option"
    show "cproper_interval (Some x) None = (\<exists>z. cless x z)" using A
      by(cases x)(auto split: option.split intro: exI[where x="Some undefined"])

    show "cproper_interval (Some x) (Some y) = (\<exists>z. cless x z \<and> cless z y)" using A
      by(cases x y rule: option.exhaust[case_product option.exhaust])(auto cong: option.case_cong split: option.split)
  qed(auto split: option.splits)
qed
end

instantiation set :: (cproper_interval) cproper_interval begin
fun cproper_interval_set :: "'a set proper_interval" where
  [code]: "cproper_interval_set None None \<longleftrightarrow> True"
| [code]: "cproper_interval_set None (Some B) \<longleftrightarrow> (B \<noteq> {})"
| [code]: "cproper_interval_set (Some A) None \<longleftrightarrow> (A \<noteq> UNIV)"
| cproper_interval_set_Some_Some [code del]: -- {* Refine for concrete implementations *}
  "cproper_interval_set (Some A) (Some B) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> (\<exists>C. cless A C \<and> cless C B)"
instance
proof
  assume "ID CORDER('a set) \<noteq> None" "finite (UNIV :: 'a set set)"
  then obtain leq_a lt_a
    where A: "ID CORDER('a) = Some (leq_a, lt_a)" "finite (UNIV :: 'a set)"
    by(auto simp add: corder_set_def ID_def Finite_Set.finite_set)
  interpret a!: linorder leq_a lt_a by(rule ID_corder)(rule A)
  note [simp] = proper_interval.proper_interval_simps[OF cproper_interval] corder_set_def ID_Some
  show "class.proper_interval cless (cproper_interval :: 'a set proper_interval)" using A
    by unfold_locales auto
qed

lemma Complement_cproper_interval_set_Complement:
  fixes A B :: "'a set"
  assumes corder: "ID CORDER('a) \<noteq> None"
  shows "cproper_interval (Some (- A)) (Some (- B)) = cproper_interval (Some B) (Some A)"
using assms
by(clarsimp simp add: corder_set_def ID_Some)(metis double_complement linorder.Compl_set_less_Compl[OF ID_corder])

end

instantiation "fun" :: (type, type) cproper_interval begin
text {* No interval checks on functions needed because we have not defined an order on them. *}
definition "cproper_interval = (undefined :: ('a \<Rightarrow> 'b) proper_interval)"
instance by(intro_classes)(simp add: corder_fun_def ID_None)
end

end


text
\<open>This theory formalizes some of the results appearing in the paper "Stellar Consensus By Reduction"\<^cite>\<open>"disc_paper"\<close>.
We prove static properties of personal Byzantine quorum systems and Stellar quorum systems.\<close>

theory Stellar_Quorums
  imports Main
begin

section "Personal Byzantine quorum systems"

locale personal_quorums =
  fixes quorum_of :: "'node \<Rightarrow> 'node set \<Rightarrow> bool"
  assumes quorum_assm:"\<And> p p' . \<lbrakk>quorum_of p Q; p' \<in> Q\<rbrakk> \<Longrightarrow> quorum_of p' Q"
    \<comment> \<open>In other words, a quorum (of some participant) is a quorum of all its members.\<close>
begin

definition blocks where
  \<comment> \<open>Set @{term R} blocks participant @{term p}.\<close>
  "blocks R p \<equiv> \<forall> Q . quorum_of p Q \<longrightarrow> Q \<inter> R \<noteq> {}"

abbreviation blocked_by where "blocked_by R \<equiv> {p . blocks R p}"

lemma blocked_blocked_subset_blocked:
  "blocked_by (blocked_by R) \<subseteq> blocked_by R"
proof -
  have False if "p \<in> blocked_by (blocked_by R)" and "p \<notin> blocked_by R" for p
  proof -
    have "Q \<inter> blocked_by R \<noteq> {}" if "quorum_of p Q" for Q
      using \<open>p \<in> blocked_by (blocked_by R)\<close> that unfolding blocks_def by auto
    have "Q \<inter> R \<noteq> {}" if " quorum_of p Q" for Q
    proof -
      obtain p' where "p' \<in> blocked_by R" and "p' \<in> Q"
        by (meson Int_emptyI \<open>\<And>Q. quorum_of p Q \<Longrightarrow> Q \<inter> blocked_by R \<noteq> {}\<close> \<open>quorum_of p Q\<close>)
      hence "quorum_of p' Q"
        using quorum_assm that by blast
      with \<open>p' \<in> blocked_by R\<close> show "Q \<inter> R \<noteq> {}"
        using blocks_def by auto
    qed
    hence "p \<in> blocked_by R" by (simp add: blocks_def)
    thus False using that(2) by auto
  qed
  thus "blocked_by (blocked_by R) \<subseteq> blocked_by R"
    by blast
qed

end

text \<open>We now add the set of correct participants to the model.\<close>

locale with_w = personal_quorums quorum_of for quorum_of  :: "'node \<Rightarrow> 'node set \<Rightarrow> bool" +
  fixes W::"'node set" \<comment> \<open>@{term W} is the set of correct participants\<close>
begin

abbreviation B where "B \<equiv> -W"
  \<comment> \<open>@{term B} is the set of malicious participants.\<close>

definition quorum_of_set where "quorum_of_set S Q \<equiv> \<exists> p \<in> S . quorum_of p Q"

subsection "The set of participants not blocked by malicious participants"

definition L where "L \<equiv> W - (blocked_by B)"

lemma l2: "p \<in> L \<Longrightarrow> \<exists> Q  \<subseteq> W. quorum_of p Q"
  unfolding L_def blocks_def using DiffD2 by auto

lemma l3: \<comment>  \<open>If a participant is not blocked by the malicious participants, then it has a quorum consisting exclusively of correct
participants which are not blocked by the malicious participants.\<close>
  assumes "p \<in> L" shows "\<exists> Q \<subseteq> L . quorum_of p Q"
proof -
  have False if "\<And> Q . quorum_of p Q \<Longrightarrow> Q \<inter> (-L) \<noteq> {}"
  proof -
    obtain Q where "quorum_of p Q" and "Q \<subseteq> W"
      using l2 \<open>p \<in> L\<close> by auto
    have "Q \<inter> (-L) \<noteq> {}"  using that \<open>quorum_of p Q\<close> by simp
    obtain p' where "p' \<in> Q \<inter> (-L)" and "quorum_of p' Q"
      using \<open>Q \<inter> - L \<noteq> {}\<close> \<open>quorum_of p Q\<close> inf.left_idem quorum_assm by fastforce
    hence "Q \<inter> B \<noteq> {}" unfolding L_def
      using CollectD Compl_Diff_eq Int_iff inf_le1 personal_quorums.blocks_def personal_quorums_axioms subset_empty by fastforce
    thus False using \<open>Q \<subseteq> W\<close> by auto
  qed
  thus ?thesis by (metis disjoint_eq_subset_Compl double_complement)
qed

subsection "Consensus clusters and intact sets"

definition is_intertwined where
  \<comment> \<open>This definition is not used in this theory,
    but we include it to formalize the notion of intertwined set appearing in the DISC paper.\<close>
  "is_intertwined S \<equiv> S \<subseteq> W
    \<and> (\<forall> Q Q' . quorum_of_set S Q \<and> quorum_of_set S Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"

definition is_cons_cluster where
  \<comment> \<open>Consensus clusters\<close>
  "is_cons_cluster C \<equiv> C \<subseteq> W \<and> (\<forall> p \<in> C . \<exists> Q \<subseteq> C . quorum_of p Q)
      \<and> (\<forall> Q Q' . quorum_of_set C Q \<and> quorum_of_set C Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"

definition strong_consensus_cluster where
  "strong_consensus_cluster I \<equiv> I \<subseteq> W \<and> (\<forall> p \<in> I . \<exists> Q \<subseteq> I . quorum_of p Q)
      \<and> (\<forall> Q Q' . quorum_of_set I Q \<and> quorum_of_set I Q' \<longrightarrow> I \<inter> Q \<inter> Q' \<noteq> {})"

lemma strong_consensus_cluster_imp_cons_cluster:
\<comment> \<open>Every intact set is a consensus cluster\<close>
  shows "strong_consensus_cluster I \<Longrightarrow> is_cons_cluster I"
  unfolding strong_consensus_cluster_def is_cons_cluster_def
  by blast

lemma cons_cluster_neq_cons_cluster:
  \<comment> \<open>Some consensus clusters are not strong consensus clusters and have no superset that is a strong consensus cluster.\<close>
  shows "is_cons_cluster I \<and> (\<forall> J . I \<subseteq> J \<longrightarrow> \<not>strong_consensus_cluster J)" nitpick[falsify=false, card 'node=3, expect=genuine]
  oops

text \<open>Next we show that the union of two consensus clusters that intersect is a consensus cluster.\<close>

theorem cluster_union:
  assumes "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
  shows "is_cons_cluster (C\<^sub>1\<union> C\<^sub>2)"
proof -
  have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
    using assms(1) assms(2) is_cons_cluster_def by auto
  moreover
  have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q"
    using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def
    by (meson UnE le_supI1 le_supI2)
  moreover
  have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
    if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2\<close> that
      unfolding quorum_of_set_def is_cons_cluster_def by metis
    moreover
    have \<open>W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2"
      and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
    for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
    proof -
      obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2"
        using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def by blast
      have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
        unfolding is_cons_cluster_def quorum_of_set_def
        by (metis Int_assoc Int_iff inf_bot_right)
      hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast
      thus "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
        unfolding is_cons_cluster_def by blast
    qed
    ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto
  qed
  ultimately show ?thesis using assms
    unfolding is_cons_cluster_def by simp
qed

text \<open>Similarly, the union of two strong consensus clusters is a strong consensus cluster.\<close>
lemma strong_cluster_union:
  assumes "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
  shows "strong_consensus_cluster (C\<^sub>1\<union> C\<^sub>2)"
proof -
  have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
    using assms(1) assms(2) strong_consensus_cluster_def by auto
  moreover
  have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q"
    using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def
    by (meson UnE le_supI1 le_supI2)
  moreover
  have "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
    if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "C \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> that
      unfolding quorum_of_set_def strong_consensus_cluster_def by metis
    hence "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
      by (metis Int_Un_distrib2 disjoint_eq_subset_Compl sup.boundedE that)
    moreover
    have \<open>(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2"
      and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
    for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
    proof -
      obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2"
        using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def by blast
      have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
        unfolding strong_consensus_cluster_def quorum_of_set_def
        by (metis Int_assoc Int_iff inf_bot_right)
      hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast
      thus "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
        unfolding strong_consensus_cluster_def by blast
    qed
    ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto
  qed
  ultimately show ?thesis using assms
    unfolding strong_consensus_cluster_def by simp
qed

end

section "Stellar quorum systems"

locale stellar =
  fixes slices :: "'node \<Rightarrow> 'node set set" \<comment> \<open>the quorum slices\<close>
    and W :: "'node set" \<comment> \<open>the well-behaved nodes\<close>
  assumes slices_ne:"\<And>p . p \<in> W \<Longrightarrow> slices p \<noteq> {}"
begin

definition quorum where
  "quorum Q \<equiv> \<forall> p \<in> Q \<inter> W . (\<exists> Sl \<in> slices p . Sl \<subseteq> Q)"

definition quorum_of where "quorum_of p Q \<equiv> quorum Q \<and> (p \<notin> W \<or> (\<exists> Sl \<in> slices p . Sl \<subseteq> Q))"
  \<comment> \<open>TODO: @{term "p\<notin>W"} needed?\<close>

lemma quorum_union:"quorum Q \<Longrightarrow> quorum Q' \<Longrightarrow> quorum (Q \<union> Q')"
  unfolding quorum_def
  by (metis IntE Int_iff UnE inf_sup_aci(1) sup.coboundedI1 sup.coboundedI2)

lemma l1:
  assumes "\<And> p . p \<in> S \<Longrightarrow> \<exists> Q \<subseteq> S . quorum_of p Q" and "p\<in> S"
  shows "quorum_of p S" using assms unfolding quorum_of_def quorum_def
  by (meson Int_iff subset_trans)

lemma is_pbqs:
  assumes "quorum_of p Q" and "p' \<in> Q"
  shows "quorum_of p' Q"
  \<comment> \<open>This is the property required of a PBQS.\<close>
  using assms
  by (simp add: quorum_def quorum_of_def)

interpretation with_w quorum_of
  \<comment> \<open>Stellar quorums form a personal quorum system.\<close>
  unfolding with_w_def personal_quorums_def
  quorum_def quorum_of_def by simp

lemma quorum_is_quorum_of_some_slice:
  assumes "quorum_of p Q" and "p \<in> W"
  obtains S where "S \<in> slices p" and "S \<subseteq> Q"
    and "\<And> p' . p' \<in> S \<inter> W \<Longrightarrow> quorum_of p' Q"
  using assms unfolding quorum_def quorum_of_def by fastforce

lemma "is_cons_cluster C \<Longrightarrow> quorum C"
  \<comment> \<open>Every consensus cluster is a quorum.\<close>
  unfolding is_cons_cluster_def
  by (metis inf.order_iff l1 quorum_of_def stellar.quorum_def stellar_axioms)

subsection \<open>Properties of blocking sets\<close>

inductive blocking_min where
  \<comment> \<open>This is the set of correct participants that are eventually blocked by a set @{term R} when byzantine processors do not take steps.\<close>
  "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl\<inter>W . q \<in> R \<or> blocking_min R q\<rbrakk> \<Longrightarrow> blocking_min R p"
inductive_cases blocking_min_elim:"blocking_min R p"

inductive blocking_max where
  \<comment> \<open>This is the set of participants that are eventually blocked by a set @{term R} when byzantine processors help epidemic propagation.\<close>
  "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl . q \<in> R\<union>B \<or> blocking_max R q\<rbrakk> \<Longrightarrow> blocking_max R p"
inductive_cases "blocking_max R p"

text \<open>Next we show that if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} and @{term p} belongs to a consensus cluster @{term S}, then @{term \<open>R \<inter> S \<noteq> {}\<close>}.\<close>

text \<open>We first prove two auxiliary lemmas:\<close>

lemma cons_cluster_wb:"p \<in> C \<Longrightarrow> is_cons_cluster C \<Longrightarrow> p\<in>W"
  using is_cons_cluster_def  by fastforce

lemma cons_cluster_has_ne_slices:
  assumes "is_cons_cluster C" and "p\<in>C"
    and "Sl \<in> slices p"
  shows "Sl \<noteq> {}"
  using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
  by (metis empty_iff inf_bot_left inf_bot_right subset_refl)

lemma cons_cluster_has_cons_cluster_slice:
  assumes "is_cons_cluster C" and "p\<in>C"
  obtains Sl where "Sl \<in> slices p" and "Sl \<subseteq> C"
  using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
  by (metis Int_commute  empty_iff inf.order_iff  inf_bot_right le_infI1)

theorem blocking_max_intersects_intact:
  \<comment> \<open>if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} when malicious participants help epidemic propagation,
and @{term p} belongs to a consensus cluster @{term C}, then @{term \<open>R \<inter> C \<noteq> {}\<close>}\<close>
  assumes  "blocking_max R p" and "is_cons_cluster C" and "p \<in> C"
  shows "R \<inter> C \<noteq> {}" using assms
proof (induct)
  case (1 p R)
  obtain Sl where "Sl \<in> slices p" and "Sl \<subseteq> C" using cons_cluster_has_cons_cluster_slice
    using "1.prems" by blast
  moreover have "Sl \<subseteq> W" using assms(2) calculation(2) is_cons_cluster_def by auto
  ultimately show ?case
    using "1.hyps" assms(2) by fastforce
qed

text \<open>Now we show that if @{term \<open>p \<in> C\<close>}, @{term C} is a consensus cluster, and quorum @{term Q} is such that @{term \<open>Q \<inter> C \<noteq> {}\<close>},
    then @{term \<open>Q \<inter> W\<close>} blocks @{term p}.

We start by defining the set of participants reachable from a participant through correct participants.
Their union trivially forms a quorum.
Moreover, if @{term p} is not blocked by a set @{term R},
then we show that the set of participants reachable from @{term p} and not blocked by @{term R} forms a quorum disjoint from @{term R}.
It follows that if @{term p } is a member of a consensus cluster @{term C} and @{term Q} is a quorum of a member of @{term C}, then @{term "Q\<inter>W"}
 must block @{term p}, as otherwise quorum intersection would be violated. \<close>

inductive not_blocked for p R where
  "\<lbrakk>Sl \<in> slices p; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
| "\<lbrakk>not_blocked p R p'; p' \<in> W; Sl \<in> slices p'; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
inductive_cases not_blocked_cases:"not_blocked p R q"

lemma l4:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  shows "quorum Q"
proof -
  have "\<exists> S \<in> slices n . S \<subseteq> Q" if "n\<in>Q\<inter>W" for n
  proof-
    have "not_blocked p R n" using assms that by blast
    hence "n \<notin> R" and "\<not>blocking_min R n" by (metis Int_iff not_blocked.simps that)+
    thus ?thesis  using blocking_min.intros not_blocked.intros(2) that unfolding Q_def
      by (simp; metis mem_Collect_eq subsetI)
  qed
  thus ?thesis by (simp add: quorum_def)
qed

lemma l5:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  assumes  "\<not>blocking_min R p" and \<open>p\<in>C\<close> and \<open>is_cons_cluster C\<close>
  shows "quorum_of p Q"
proof -
  have "p\<in>W"
    using assms(3,4) cons_cluster_wb by blast
  obtain Sl where "Sl \<in> slices p" and "\<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q"
    by (meson \<open>p \<in> W\<close> assms(2) blocking_min.intros)
  hence "Sl \<subseteq> Q" unfolding Q_def using not_blocked.intros(1) by blast
  with l4 \<open>Sl \<in> slices p\<close> show "quorum_of p Q"
    using Q_def  quorum_of_def by blast
qed

lemma cons_cluster_ne_slices:
  assumes "is_cons_cluster C" and "p\<in>C" and "Sl \<in> slices p"
  shows "Sl\<noteq>{}"
  using assms cons_cluster_has_ne_slices cons_cluster_wb stellar.quorum_of_def stellar_axioms by fastforce

lemma l6:
  fixes Q p R
  defines "Q \<equiv> {q . not_blocked p R q}"
  shows "Q \<inter> R \<inter> W = {}"
proof -
  have "q \<notin> R" if "not_blocked p R q" and "q\<in> W" for q using that
    by (metis Int_iff not_blocked.simps)
  thus ?thesis unfolding Q_def by auto
qed

theorem quorum_blocks_cons_cluster:
  assumes "quorum_of_set C Q" and "p\<in>C" and "is_cons_cluster C"
  shows "blocking_min (Q \<inter> W) p"
proof (rule ccontr)
  assume "\<not> blocking_min (Q \<inter> W) p"
  have "p\<in>W" using assms(2,3) is_cons_cluster_def by auto
  define Q' where "Q' \<equiv> {q . not_blocked p (Q\<inter>W) q}"
  have "quorum_of p Q'" using Q'_def \<open>\<not> blocking_min (Q \<inter> W) p\<close> assms(2) assms(3) l5(1) by blast
  moreover have "Q' \<inter> Q \<inter> W = {}"
    using Q'_def l6 by fastforce
  ultimately show False using assms unfolding is_cons_cluster_def
    by (metis Int_commute inf_sup_aci(2) quorum_of_set_def)
qed

subsection \<open>Reachability through a set\<close>

text \<open>Here we define the part of a quorum @{term Q} of @{term p} that is reachable through correct
participants from @{term p}. We show that if @{term p} and @{term p'} are members of the same consensus cluster and @{term Q} is a quorum of @{term p}
 and @{term Q'} is a quorum of @{term p'},
then the intersection @{term "Q\<inter>Q'\<inter>W"} is reachable from both @{term p} and @{term p'} through the consensus cluster.\<close>

inductive reachable_through for p S where
  "reachable_through p S p"
| "\<lbrakk>reachable_through p S p'; p' \<in> W; Sl \<in> slices p'; Sl \<subseteq> S; p'' \<in> Sl\<rbrakk> \<Longrightarrow> reachable_through p S p''"

definition truncation where "truncation p S \<equiv> {p' . reachable_through p S p'}"

lemma l13:
  assumes "quorum_of p Q" and "p \<in> W" and "reachable_through p Q p'"
  shows "quorum_of p' Q"
  using assms using quorum_assm reachable_through.cases
  by (metis is_pbqs subset_iff)

lemma l14:
  assumes "quorum_of p Q" and "p \<in> W"
  shows "quorum (truncation p Q)"
proof -
  have "\<exists> S \<in> slices p' . \<forall> q \<in> S . reachable_through p Q q" if "reachable_through p Q p'" and "p' \<in> W" for p'
    by (meson assms l13 quorum_is_quorum_of_some_slice stellar.reachable_through.intros(2) stellar_axioms that)
  thus ?thesis
    by (metis IntE mem_Collect_eq stellar.quorum_def stellar_axioms subsetI truncation_def)
qed

lemma l15:
  assumes "is_cons_cluster I" and "quorum_of p Q" and "quorum_of p' Q'" and "p \<in> I" and "p' \<in> I" and "Q \<inter> Q' \<inter> W \<noteq> {}"
  shows "W \<inter> (truncation p Q) \<inter> (truncation p' Q') \<noteq> {}"
proof -
  have "quorum (truncation p Q)" and "quorum (truncation p' Q')" using l14 assms is_cons_cluster_def by auto
  moreover have "quorum_of_set I (truncation p Q)" and "quorum_of_set I (truncation p' Q')"
    by (metis IntI assms(4,5) calculation mem_Collect_eq quorum_def quorum_of_def quorum_of_set_def reachable_through.intros(1) truncation_def)+
  moreover note \<open>is_cons_cluster I\<close>
  ultimately show ?thesis unfolding is_cons_cluster_def by auto
qed

end

subsection "Elementary quorums"

text \<open>In this section we define the notion of elementary quorum, which is a quorum that has no strict subset that is a quorum.
  It follows directly from the definition that every finite quorum contains an elementary quorum. Moreover, we show
that if @{term Q} is an elementary quorum and @{term n\<^sub>1} and @{term n\<^sub>2} are members of @{term Q}, then @{term n\<^sub>2} is reachable from @{term n\<^sub>1}
in the directed graph over participants defined as the set of edges @{term "(n,m)"} such that @{term m} is a member of a slice of @{term n}.
This lemma is used in the companion paper to show that probabilistic leader-election is feasible.\<close>

locale elementary = stellar
begin

definition elementary where
  "elementary s \<equiv> quorum s \<and> (\<forall> s' . s' \<subset> s \<longrightarrow> \<not>quorum s')"

lemma finite_subset_wf:
  shows "wf {(X, Y). X \<subset> Y \<and> finite Y}"
  by (metis finite_psubset_def wf_finite_psubset)

lemma quorum_contains_elementary:
  assumes "finite s" and  "\<not> elementary s" and "quorum s"
  shows "\<exists> s' . s' \<subset> s \<and> elementary s'" using assms
proof (induct s rule:wf_induct[where ?r="{(X, Y). X \<subset> Y \<and> finite Y}"])
  case 1
  then show ?case using finite_subset_wf by simp
next
  case (2 x)
  then show ?case
    by (metis (full_types) elementary_def finite_psubset_def finite_subset in_finite_psubset less_le psubset_trans)
qed

inductive path where
  "path []"
| "\<And> x . path [x]"
| "\<And> l n . \<lbrakk>path l; S \<in> Q (hd l); n \<in> S\<rbrakk> \<Longrightarrow> path (n#l)"

theorem elementary_connected:
  assumes "elementary s" and "n\<^sub>1 \<in> s" and "n\<^sub>2 \<in> s" and "n\<^sub>1 \<in> W" and "n\<^sub>2 \<in> W"
  shows "\<exists> l . hd (rev l) = n\<^sub>1 \<and> hd l = n\<^sub>2 \<and> path l" (is ?P)
proof -
  { assume "\<not>?P"
    define x where "x \<equiv> {n \<in> s . \<exists> l . l \<noteq> [] \<and> hd (rev l) = n\<^sub>1 \<and> hd l = n \<and> path l}"
    have "n\<^sub>2 \<notin> x" using \<open>\<not>?P\<close> x_def by auto
    have "n\<^sub>1 \<in> x" unfolding x_def using assms(2) path.intros(2) by force
    have "quorum x"
    proof -
      { fix n
        assume "n \<in> x"
        have "\<exists> S . S \<in> slices n \<and> S \<subseteq> x"
        proof -
          obtain S where "S \<in> slices n" and "S \<subseteq> s" using \<open>elementary s\<close> \<open>n \<in> x\<close> unfolding x_def
            by (force simp add:elementary_def quorum_def)
          have "S \<subseteq> x"
          proof -
            { assume "\<not> S \<subseteq> x"
              obtain m where "m \<in> S" and "m \<notin> x" using \<open>\<not> S \<subseteq> x\<close> by auto
              obtain l' where "hd (rev l') = n\<^sub>1" and "hd l' = n" and "path l'" and "l' \<noteq> []"
                using \<open>n \<in> x\<close> x_def by blast
              have "path (m # l')" using \<open>path l'\<close> \<open>m\<in> S\<close> \<open>S \<in> slices n\<close> \<open>hd l' = n\<close>
                using path.intros(3) by fastforce
              moreover have "hd (rev (m # l')) = n\<^sub>1" using \<open>hd (rev l') = n\<^sub>1\<close> \<open>l' \<noteq> []\<close> by auto
              ultimately have "m \<in> x" using \<open>m \<in> S\<close> \<open>S \<subseteq> s\<close> x_def by auto
              hence False using \<open>m \<notin> x\<close> by blast }
            thus ?thesis by blast
          qed
          thus ?thesis
            using \<open>S \<in> slices n\<close> by blast
        qed }
      thus ?thesis by (meson Int_iff quorum_def)
    qed
    moreover have "x \<subset> s"
      using \<open>n\<^sub>2 \<notin> x\<close> assms(3) x_def by blast
    ultimately have False using \<open>elementary s\<close>
      using elementary_def by auto
  }
  thus ?P by blast
qed

end

subsection \<open>The intact sets of the Stellar Whitepaper\<close>

definition project where
  "project slices S n \<equiv> {Sl \<inter> S | Sl . Sl \<in> slices n}"
  \<comment> \<open>Projecting on @{term S} is the same as deleting the complement of @{term S}, where deleting is understood as in the Stellar Whitepaper.\<close>

subsubsection \<open>Intact and the Cascade Theorem\<close>

locale intact = \<comment> \<open>Here we fix an intact set @{term I} and prove the cascade theorem.\<close>
  orig:stellar slices W
  + proj:stellar "project slices I" W \<comment> \<open>We consider the projection of the system on @{term I}.\<close>
  for slices W I +  \<comment> \<open>An intact set is a set @{term I} satisfying the three assumptions below:\<close>
  assumes intact_wb:"I \<subseteq> W"
    and q_avail:"orig.quorum I" \<comment> \<open>@{term I} is a quorum in the original system.\<close>
    and q_inter:"\<And> Q Q' . \<lbrakk>proj.quorum Q; proj.quorum Q'; Q \<inter> I \<noteq> {}; Q' \<inter> I \<noteq> {}\<rbrakk>  \<Longrightarrow> Q \<inter> Q' \<inter> I \<noteq> {}"
    \<comment> \<open>Any two sets that intersect @{term I} and that are quorums in the projected system intersect in @{term I}.
Note that requiring that @{text \<open>Q \<inter> Q' \<noteq> {}\<close>} instead of @{text \<open>Q \<inter> Q' \<inter> I \<noteq> {}\<close>} would be equivalent.\<close>
begin

theorem blocking_safe: \<comment> \<open>A set that blocks an intact node contains an intact node.
If this were not the case, quorum availability would trivially be violated.\<close>
  fixes S n
  assumes "n\<in>I" and "\<forall> Sl\<in> slices n .Sl\<inter>S \<noteq> {}"
  shows "S \<inter> I \<noteq> {}"
  using assms q_avail intact_wb unfolding orig.quorum_def
  by auto (metis inf.absorb_iff2 inf_assoc inf_bot_right inf_sup_aci(1))

theorem cascade:
\<comment> \<open>If @{term U} is a quorum of an intact node and @{term S} is a super-set of @{term U}, then either @{term S} includes
all intact nodes or there is an intact node outside of @{term S} which is blocked by the intact members of @{term S}.
This shows that, in SCP, once the intact members of a quorum accept a statement,
a cascading effect occurs and all intact nodes eventually accept it regardless of what befouled and faulty nodes do.\<close>
  fixes U S
  assumes "orig.quorum U" and "U \<inter> I \<noteq> {}" and "U \<subseteq> S"
  obtains "I \<subseteq> S" | "\<exists> n \<in> I - S . \<forall> Sl \<in> slices n . Sl \<inter> S \<inter> I \<noteq> {}"
proof -
  have False if 1:"\<forall> n \<in> I - S . \<exists> Sl \<in> slices n . Sl \<inter> S \<inter> I = {}" and 2:"\<not>(I \<subseteq> S)"
  proof -
    text \<open>First we show that @{term \<open>I-S\<close>} is a quorum in the projected system. This is immediate from the definition of quorum and assumption 1.\<close>
    have "proj.quorum (I-S)" using 1
      unfolding proj.quorum_def project_def
      by (auto; smt DiffI Diff_Compl Diff_Int_distrib Diff_eq Diff_eq_empty_iff Int_commute)
    text \<open>Then we show that U is also a quorum in the projected system:\<close>
    moreover have "proj.quorum U" using \<open>orig.quorum U\<close>
      unfolding proj.quorum_def orig.quorum_def project_def
      by (simp; meson Int_commute inf.coboundedI2)
    text \<open>Since quorums of @{term I} must intersect, we get a contradiction:\<close>
    ultimately show False using \<open>U \<subseteq> S\<close> \<open>U \<inter> I \<noteq> {}\<close> \<open>\<not>(I\<subseteq>S)\<close> q_inter by auto
  qed
  thus ?thesis using that by blast
qed

end

subsubsection "The Union Theorem"

text \<open>Here we prove that the union of two intact sets that intersect is intact.
This implies that maximal intact sets are disjoint.\<close>

locale intersecting_intact =
  i1:intact slices W I\<^sub>1 + i2:intact slices W I\<^sub>2 \<comment> \<open>We fix two intersecting intact sets @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
  + proj:stellar "project slices (I\<^sub>1\<union>I\<^sub>2)" W \<comment> \<open>We consider the projection of the system on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
  for slices W I\<^sub>1 I\<^sub>2 +
assumes inter:"I\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}"
begin

theorem union_quorum: "i1.orig.quorum (I\<^sub>1\<union>I\<^sub>2)" \<comment> \<open>@{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} is a quorum in the original system.\<close>
  using i1.intact_axioms i2.intact_axioms
  unfolding  intact_def stellar_def intact_axioms_def i1.orig.quorum_def
  by (metis Int_iff Un_iff le_supI1 le_supI2)

theorem union_quorum_intersection:
  assumes "proj.quorum Q\<^sub>1" and "proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}" and "Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
  shows "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    \<comment> \<open>Any two sets that intersect @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} and that are quorums in the system projected on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} intersect in @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
proof -
  text \<open>First we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} are quorums in the projections on @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
  have "i1.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close>
    unfolding i1.proj.quorum_def proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i2.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close>
    unfolding i2.proj.quorum_def proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i2.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close>
    unfolding proj.quorum_def i2.proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  moreover have "i1.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close>
    unfolding proj.quorum_def i1.proj.quorum_def project_def
    by auto (metis Int_Un_distrib Int_iff Un_subset_iff)
  text \<open>Next we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of, respectively, @{term I\<^sub>1} and @{term I\<^sub>2}.
This is the only interesting part of the proof.\<close>
  moreover have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i1.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "i2.proj.quorum Q\<^sub>1"
      and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
  proof -
    have "i1.proj.quorum I\<^sub>2"
    proof -
      have "i1.orig.quorum I\<^sub>2" by (simp add: i2.q_avail)
      thus ?thesis unfolding i1.orig.quorum_def i1.proj.quorum_def project_def
        by auto (meson Int_commute Int_iff inf_le2 subset_trans)
    qed
    moreover note \<open>i1.proj.quorum Q\<^sub>1\<close>
    ultimately have "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" using i1.q_inter inter \<open>Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}\<close> by blast

    moreover note \<open>i2.proj.quorum Q\<^sub>2\<close>
    moreover note \<open>i2.proj.quorum Q\<^sub>1\<close>
    ultimately have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}" using i2.q_inter \<open>Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}\<close> by blast
    thus ?thesis by (simp add: inf_sup_distrib1)
  qed
  text \<open>Next  we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of the same intact set. This is obvious.\<close>
  moreover
  have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i1.proj.quorum Q\<^sub>1" and "i1.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>1 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
    by (simp add: Int_Un_distrib i1.q_inter that)
  moreover
  have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
    if "i2.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
    for Q\<^sub>1 Q\<^sub>2
    by (simp add: Int_Un_distrib i2.q_inter that)
  text \<open>Finally we have covered all the cases and get the final result:\<close>
  ultimately
  show ?thesis
    by (smt Int_Un_distrib Int_commute assms(3,4) sup_bot.right_neutral)
qed

end

end


section \<open>Example\<close>
theory LLVM_Examples
imports
  "../ds/LLVM_DS_Dflt"
  "../ds/LLVM_DS_Array_List"
begin

text \<open>Example and Regression Tests using LLVM-VCG directly,
i.e., without Refinement Framework\<close>

subsection \<open>Regression Tests\<close>
typedef my_pair = "UNIV :: (64 word \<times> 32 word) set" by simp

lemmas my_pair_bij[simp] = Abs_my_pair_inverse[simplified] Rep_my_pair_inverse

instantiation my_pair :: llvm_rep
begin
  definition "from_val_my_pair \<equiv> Abs_my_pair o from_val"
  definition "to_val_my_pair \<equiv> to_val o Rep_my_pair"
  definition [simp]: "struct_of_my_pair (_:: my_pair itself) \<equiv> struct_of TYPE(64 word \<times> 32 word)"
  definition "init_my_pair \<equiv> Abs_my_pair init"

  instance
    apply standard
    unfolding from_val_my_pair_def to_val_my_pair_def struct_of_my_pair_def init_my_pair_def
    apply (auto simp: to_val_word_def)
    done

end

definition my_fst :: "my_pair \<Rightarrow> 64 word llM" where [llvm_inline]: "my_fst \<equiv> ll_extract_fst"
definition my_snd :: "my_pair \<Rightarrow> 32 word llM" where [llvm_inline]: "my_snd \<equiv> ll_extract_snd"
definition my_ins_fst :: "my_pair \<Rightarrow> 64 word \<Rightarrow> my_pair llM" where [llvm_inline]: "my_ins_fst \<equiv> ll_insert_fst"
definition my_ins_snd :: "my_pair \<Rightarrow> 32 word \<Rightarrow> my_pair llM" where [llvm_inline]: "my_ins_snd \<equiv> ll_insert_snd"
definition my_gep_fst :: "my_pair ptr \<Rightarrow> 64 word ptr llM" where [llvm_inline]: "my_gep_fst \<equiv> ll_gep_fst"
definition my_gep_snd :: "my_pair ptr \<Rightarrow> 32 word ptr llM" where [llvm_inline]: "my_gep_snd \<equiv> ll_gep_snd"

definition [llvm_code]: "add_add (a::_ word) \<equiv> doM {
  x \<leftarrow> ll_add a a;
  x \<leftarrow> ll_add x x;
  return x
}"

definition [llvm_code]: "test_named (a::32 word) (b::64 word) \<equiv> doM {
  a \<leftarrow> add_add a;
  b \<leftarrow> add_add b;
  let n = (init::my_pair);
  a \<leftarrow> my_fst n;
  b \<leftarrow> my_snd n;
  n \<leftarrow> my_ins_fst n init;
  n \<leftarrow> my_ins_snd n init;

  p \<leftarrow> ll_malloc TYPE(my_pair) (1::64 word);
  p1 \<leftarrow> my_gep_fst p;
  p2 \<leftarrow> my_gep_snd p;

  return b
}"

lemma [ll_is_pair_type_thms]: "ll_is_pair_type False TYPE(my_pair) TYPE(64 word) TYPE(32 word)"
  unfolding ll_is_pair_type_def
  by auto

export_llvm (debug) test_named file "code/test_named.ll"

subsection \<open>Numeric Algorithms\<close>

subsubsection \<open>Exponentiation\<close>

definition exp :: "64 word \<Rightarrow> 64 word llM" where [llvm_code]: "exp i \<equiv> doM {
  s \<leftarrow> prod_insert_fst init 1;
  s \<leftarrow> prod_insert_snd s i;
  s \<leftarrow> llc_while
    (\<lambda>s. doM {
      i \<leftarrow> prod_extract_snd s;
      ll_icmp_ne i 0
    })
    (\<lambda>s. doM {
      c \<leftarrow> prod_extract_fst s;
      i \<leftarrow> prod_extract_snd s;

      c \<leftarrow> ll_mul c 2;
      i \<leftarrow> ll_sub i 1;

      s \<leftarrow> prod_insert_fst init c;
      s \<leftarrow> prod_insert_snd s i;

      return s
    })
    s;

  prod_extract_fst s
}"

definition [llvm_code]: "main_exp (argc::32 word) (argv::8 word ptr ptr) \<equiv> doM {
  argc \<leftarrow> ll_zext argc TYPE(64 word);
  r \<leftarrow> exp argc;
  r \<leftarrow> ll_trunc r TYPE(32 word);
  return r
}"

text \<open>Executability of semantics inside Isabelle\<close>
value "run (exp 32) llvm_empty_memory"

definition [llvm_code]: "exp2 r \<equiv> doM {
  a \<leftarrow> ll_const (unsigned 1);
  (a,r) \<leftarrow> llc_while
    (\<lambda>(a,r). doM { ll_icmp_ult (unsigned 0) r})
    (\<lambda>(a,r). doM {
      r \<leftarrow> ll_sub r (unsigned 1);
      a \<leftarrow> ll_mul a (unsigned 2);
      return (a,r)
    })
    (a,r);
  return a
}"

export_llvm "exp2 :: 32 word \<Rightarrow> 32 word llM"

lemma exp2_aux1:
  assumes "2 ^ nat k < (N::int)" "t \<le> k" "0 < t"
  shows "2 * 2 ^ nat (k - t) < N"
proof -
  have "\<lbrakk>2 ^ k < N; 0 < t; t \<le> k\<rbrakk> \<Longrightarrow> 2 * 2 ^ (k - t) < (N::int)" for k t :: nat
    by (metis Suc_leI diff_less less_le_trans not_less power.simps(2) power_increasing_iff rel_simps(49) semiring_norm(76))
  with assms show ?thesis
    by (auto simp add: nat_diff_distrib' dest!: nat_mono simp flip: zero_less_nat_eq)
qed

lemma exp2_aux2:  "\<lbrakk>t \<le> k; 0 < t\<rbrakk> \<Longrightarrow> nat (1+k-t) = Suc (nat (k-t))" by simp

lemma
  assumes "LENGTH('b::len) \<ge> 2"
  shows "llvm_htriple
    (\<upharpoonleft>uint.assn k (ki::'a::len word) ** \<up>(2^nat k \<in> uints LENGTH('b)))
    (exp2 ki)
    (\<lambda>r::'b word. \<upharpoonleft>uint.assn (2^nat k) r ** \<upharpoonleft>uint.assn k ki)"
  unfolding exp2_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ai,ri) t. EXS a r. \<upharpoonleft>uint.assn a ai ** \<upharpoonleft>uint.assn r ri ** \<up>\<^sub>d( 0\<le>r \<and> r\<le>k \<and> a = 2^nat (k-r) ) ** \<up>\<^sub>!(t = r)"
    and R="measure nat"
    ])
  apply vcg_monadify
  apply vcg'
  using assms
  apply simp_all
  apply (simp_all add: algebra_simps exp2_aux1 exp2_aux2)
  done

subsubsection \<open>Euclid's Algorithm\<close>

definition [llvm_code]: "euclid2 (a::32 word) b \<equiv> doM {
  (a,b) \<leftarrow> llc_while
    (\<lambda>(a,b) \<Rightarrow> ll_cmp (a \<noteq> b))
    (\<lambda>(a,b) \<Rightarrow> if (a\<le>b) then return (a,b-a) else return (a-b,b))
    (a,b);
  return a
}"

export_llvm (debug) "euclid2" is euclid file "code/euclid2.ll"

lemma gcd_diff1': "gcd (a::int) (b-a) = gcd a b"
  by (metis gcd.commute gcd_diff1)

lemma "llvm_htriple
  (\<upharpoonleft>uint.assn a\<^sub>0 ai ** \<upharpoonleft>uint.assn b\<^sub>0 bi ** \<up>\<^sub>d(0<a\<^sub>0 \<and> 0<b\<^sub>0))
  (euclid2 ai bi)
  (\<lambda>ri. \<upharpoonleft>uint.assn (gcd a\<^sub>0 b\<^sub>0) ri)"
  unfolding euclid2_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ai,bi) t. EXS a b. \<upharpoonleft>uint.assn a ai ** \<upharpoonleft>uint.assn b bi
        ** \<up>\<^sub>a(t=a+b) ** \<up>\<^sub>d(0<a \<and> 0<b \<and> gcd a b = gcd a\<^sub>0 b\<^sub>0)"
    and R="measure nat"
  ])
  apply vcg_monadify
  apply vcg'
  apply clarsimp_all
  apply (simp_all add: gcd_diff1 gcd_diff1' uint_arith_simps)
  done

thm ll_range_def

find_theorems sint.assn ll_sub

thm sint_rules(2)[unfolded sints_num]

definition fib :: "64 word \<Rightarrow> 64 word llM"
  where [llvm_code]: "fib n \<equiv> REC (\<lambda>fib n. doM {
    t\<leftarrow>ll_icmp_ule n 1;
    llc_if t
      (return n)
      (doM {
        n\<^sub>1 \<leftarrow> ll_sub n 1;
        a\<leftarrow>fib n\<^sub>1;
        n\<^sub>2 \<leftarrow> ll_sub n 2;
        b\<leftarrow>fib n\<^sub>2;
        c\<leftarrow>ll_add a b;
        return c })} ) n"

export_llvm fib is fib

find_consts llvm_memory name: empty

prepare_code_thms (LLVM) [code] fib_def

value "map (\<lambda>n. run (fib n) (LLVM_MEMORY (MEMORY []))) [0,1,2,3]"

definition fib' :: "'n::len word \<Rightarrow> 'n word llM" where "fib' n \<equiv> REC (\<lambda>fib' n.
  if n\<le>1 then return n
  else doM {
    n\<^sub>1 \<leftarrow> fib' (n-1);
    n\<^sub>2 \<leftarrow> fib' (n-2);
    return (n\<^sub>1+n\<^sub>2)
  }) n"

prepare_code_thms (LLVM) [llvm_code, code] fib'_def
print_theorems
thm fib'.code(2)[folded fib'.code(1), THEN fun_cong, of n]
export_llvm thms: "fib' :: 64 word \<Rightarrow> 64 word llM" is fib

thm thms
thm llvm_inline

thm llc_while_unfold

subsection \<open>Array List Examples\<close>

definition [llvm_code]: "cr_big_al (n::64 word) \<equiv> doM {
  a \<leftarrow> arl_new TYPE(64 word) TYPE(64);
  (_,a) \<leftarrow> llc_while
    (\<lambda>(n,a). ll_icmp_ult (signed_nat 0) n)
    (\<lambda>(n,a). doM { a \<leftarrow> arl_push_back a n; n \<leftarrow> ll_sub n (signed_nat 1); return (n,a) })
    (n,a);

  (_,s) \<leftarrow> llc_while
    (\<lambda>(n,s). ll_icmp_ult (signed_nat 0) n)
    (\<lambda>(n,s). doM { n \<leftarrow> ll_sub n (signed_nat 1); x \<leftarrow> arl_nth a n; s\<leftarrow>ll_add x s; return (n,s) })
    (n,signed_nat 0);

  return s
}"

declare Let_def[llvm_inline]
export_llvm (debug) cr_big_al is "cr_big_al" file "code/cr_big_al.ll"

subsection \<open>Sorting\<close>

definition [llvm_inline]: "llc_for_range l h c s \<equiv> doM {
  (_,s) \<leftarrow> llc_while (\<lambda>(i,s). ll_cmp (i<h)) (\<lambda>(i,s). doM {
    s\<leftarrow>c i s;
    i \<leftarrow> ll_add i 1;
    return (i,s)}
  ) (l,s);
  return s
}"

lemma llc_for_range_rule:
  assumes [vcg_rules]: "\<And>i ii si. llvm_htripleF F
      (\<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(lo\<le>i \<and> i<hi) ** I i si)
      (c ii si)
      (\<lambda>si. I (i+1) si)"
  shows "llvm_htripleF F
      (\<upharpoonleft>snat.assn lo loi ** \<upharpoonleft>snat.assn hi hii ** \<up>(lo\<le>hi) ** I lo si)
      (llc_for_range loi hii c si)
      (\<lambda>si. I hi si)"
  unfolding llc_for_range_def
  apply (rewrite at 1 to "signed_nat 1" signed_nat_def[symmetric])
  apply (rewrite annotate_llc_while[where
    I="\<lambda>(ii,si) t. EXS i. \<upharpoonleft>snat.assn i ii ** \<up>(lo\<le>i \<and> i\<le>hi) ** \<up>\<^sub>!(t=hi-i) ** I i si"
    and R="measure id"])
  apply vcg_monadify
  apply vcg'
  done

definition llc_for_range_annot :: "(nat \<Rightarrow> 'b::llvm_rep \<Rightarrow> ll_assn)
  \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> ('a word \<Rightarrow> 'b \<Rightarrow> 'b llM) \<Rightarrow> 'b \<Rightarrow> 'b llM"
  where [llvm_inline]: "llc_for_range_annot I \<equiv> llc_for_range"
declare [[vcg_const "llc_for_range_annot I"]]

lemmas annotate_llc_for_range = llc_for_range_annot_def[symmetric]

lemmas llc_for_range_annot_rule[vcg_rules]
  = llc_for_range_rule[where I=I, unfolded annotate_llc_for_range[of I]] for I

(* TODO: Move *)
lemma sep_red_idx_setI:
  assumes "\<And>I I'. I\<inter>I'={} \<Longrightarrow> A (I\<union>I') = (A I ** A I')"
  shows "is_sep_red (A (I-I')) (A (I'-I)) (A I) (A I')"
proof -
  define I\<^sub>1 where "I\<^sub>1 \<equiv> I-I'"
  define I\<^sub>2 where "I\<^sub>2 \<equiv> I'-I"
  define C where "C \<equiv> I\<inter>I'"

  have S1: "I = I\<^sub>1 \<union> C" "I'=I\<^sub>2 \<union> C" and S2: "I-I' = I\<^sub>1" "I'-I=I\<^sub>2" and DJ: "I\<^sub>1\<inter>C={}" "I\<^sub>2\<inter>C={}"
    unfolding I\<^sub>1_def I\<^sub>2_def C_def by auto

  show ?thesis
    apply (rule is_sep_redI)
    apply (simp only: S2; simp only: S1)
    apply (auto simp: DJ assms)
    by (simp add: conj_entails_mono sep_conj_left_commute)

qed

lemma sep_set_img_reduce:
  "is_sep_red (\<Union>*i\<in>I-I'. f i) (\<Union>*i\<in>I'-I. f i) (\<Union>*i\<in>I. f i) (\<Union>*i\<in>I'. f i)"
  by (rule sep_red_idx_setI) simp

(* TODO: Move *)

lemma is_sep_red_false[simp]: "is_sep_red P' Q' sep_false Q"
  by (auto simp: is_sep_red_def)

(* TODO: Move *)
lemma entails_pre_pure[sep_algebra_simps]:
  "(\<up>\<Phi> \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> \<box>\<turnstile>Q)"
  "(\<up>\<Phi>**P \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> P\<turnstile>Q)"
  by (auto simp: entails_def sep_algebra_simps pred_lift_extract_simps)

definition "lstr_assn A I \<equiv> mk_assn (\<lambda>as cs. \<up>(length cs = length as \<and> (\<forall>i\<in>I. i<length as)) ** (\<Union>*i\<in>I. \<upharpoonleft>A (as!i) (cs!i)))"

lemma lstr_assn_union: "I\<inter>I'={} \<Longrightarrow>
  \<upharpoonleft>(lstr_assn A (I\<union>I')) as cs = (\<upharpoonleft>(lstr_assn A I) as cs ** \<upharpoonleft>(lstr_assn A I') as cs)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_red: "is_sep_red
  (\<upharpoonleft>(lstr_assn A (I-I')) as cs) (\<upharpoonleft>(lstr_assn A (I'-I)) as cs)
  (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>(lstr_assn A I') as cs)"
  by (rule sep_red_idx_setI) (simp add: lstr_assn_union)

lemma lstr_assn_red': "PRECOND (SOLVE_AUTO (I\<inter>I'\<noteq>{})) \<Longrightarrow> is_sep_red
  (\<upharpoonleft>(lstr_assn A (I-I')) as cs) (\<upharpoonleft>(lstr_assn A (I'-I)) as cs)
  (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>(lstr_assn A I') as cs)"
  by (rule sep_red_idx_setI) (simp add: lstr_assn_union)

lemma lstr_assn_singleton: "\<upharpoonleft>(lstr_assn A {i}) as cs = (\<up>(length cs = length as \<and> i<length as) ** \<upharpoonleft>A (as!i) (cs!i))"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_empty: "\<upharpoonleft>(lstr_assn A {}) as cs = \<up>(length cs = length as)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_out_of_range:
  "\<not>(length cs = length as \<and> (\<forall>i\<in>I. i<length as)) \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "i\<in>I \<Longrightarrow> \<not>i<length as \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "i\<in>I \<Longrightarrow> \<not>i<length cs \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  "length cs \<noteq> length as \<Longrightarrow> \<upharpoonleft>(lstr_assn A I) as cs = sep_false"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma lstr_assn_idx_left[fri_red_rules]:
  assumes "PRECOND (SOLVE_AUTO (length cs = length as \<and> i\<in>I \<and> i<length as))"
  shows "is_sep_red \<box> (\<upharpoonleft>(lstr_assn A (I-{i})) as cs) (\<upharpoonleft>A ai (cs!i)) (\<upharpoonleft>(lstr_assn A I) (as[i:=ai]) cs)"
proof -

  from assms have [simp]: "{i} - I = {}" "length cs = length as" "i<length as" and "i\<in>I"
    unfolding vcg_tag_defs by auto

  have "(\<Union>*i\<in>I - {i}. \<upharpoonleft>A (as ! i) (cs ! i))
    = (\<Union>*ia\<in>I - {i}. \<upharpoonleft>A (as[i := ai] ! ia) (cs ! ia))"
    by (rule sep_set_img_cong) auto
  then have 1: "\<upharpoonleft>(lstr_assn A (I-{i})) as cs = \<upharpoonleft>(lstr_assn A (I-{i})) (as[i:=ai]) cs"
    by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

  show ?thesis
    using lstr_assn_red[of A "{i}" I "as[i:=ai]" cs]
    by (simp add: 1 lstr_assn_singleton lstr_assn_empty sep_algebra_simps)

qed

lemma lstr_assn_idx_right[fri_red_rules]:
  assumes "PRECOND (SOLVE_AUTO (i\<in>I))"
  shows "is_sep_red (\<upharpoonleft>(lstr_assn A (I-{i})) as cs) \<box> (\<upharpoonleft>(lstr_assn A I) as cs) (\<upharpoonleft>A (as!i) (cs!i))"
proof -
  from assms have [simp]: "{i} - I = {}" "i\<in>I"
    unfolding vcg_tag_defs by auto

  show ?thesis
    using lstr_assn_red[of A I "{i}" "as" cs]
    apply (cases "length cs = length as \<and> (\<forall>i\<in>I. i<length as )"; simp add: lstr_assn_out_of_range)
    apply (simp add: lstr_assn_singleton lstr_assn_empty sep_algebra_simps)
    done
qed

(* TODO: Move *)
lemma is_pure_lst_assn[is_pure_rule]: "is_pure A \<Longrightarrow> is_pure (lstr_assn A I)"
  unfolding lstr_assn_def is_pure_def
  by (auto simp: sep_is_pure_assn_conjI sep_is_pure_assn_imgI)

lemma vcg_prep_lstr_assn: (* TODO: Need mechanism to recursively prepare pure parts of A! *)
  "pure_part (\<upharpoonleft>(lstr_assn A I) as cs) \<Longrightarrow> length cs = length as \<and> (\<forall>i\<in>I. i<length as)"
  by (auto simp: lstr_assn_def sep_algebra_simps dest: pure_part_split_conj)

(* TODO: Move *)
lemma pure_fri_auto_rule: "PRECOND (SOLVE_AUTO (\<flat>\<^sub>pA a c)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>pA a c"
  using pure_fri_rule
  unfolding vcg_tag_defs .

lemma pure_part_prepD: "pure_part (\<Union>*i\<in>I. f i) \<Longrightarrow> \<forall>i\<in>I. pure_part (f i)"
  by (metis Set.set_insert pure_part_split_conj sep_set_img_insert)

lemma pure_part_imp_pure_assn: "is_pure A \<Longrightarrow> pure_part (\<upharpoonleft>A a c) \<Longrightarrow> \<flat>\<^sub>pA a c"
  by (simp add: extract_pure_assn)

definition "aa_assn A \<equiv> mk_assn (\<lambda>as p. EXS cs.
  \<upharpoonleft>array_assn cs p ** \<up>(is_pure A \<and> list_all2 (\<flat>\<^sub>pA) as cs))"

lemma aa_nth_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(i<length as))
  (array_nth p ii)
  (\<lambda>c. \<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>A (as!i) c)"
  unfolding aa_assn_def
  apply (clarsimp simp: list_all2_conv_all_nth)
  supply pure_fri_auto_rule[fri_rules]
  apply vcg
  done

lemma aa_upd_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) as p ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>A a c ** \<up>\<^sub>d(i<length as))
  (array_upd p ii c)
  (\<lambda>c. \<upharpoonleft>(aa_assn A) (as[i:=a]) p)"
proof (cases "is_pure A")
  case [is_pure_rule,simp]: True
  (*note thin_dr_pure[vcg_prep_external_drules del]*)
  note [simp] = nth_list_update pure_part_imp_pure_assn

  show ?thesis
    unfolding aa_assn_def list_all2_conv_all_nth
    supply pure_fri_auto_rule[fri_rules]
    apply vcg
    done
qed (clarsimp simp: aa_assn_def)

definition [llvm_inline]: "qs_swap A i j \<equiv> doM {
  llc_if (ll_cmp' (i\<noteq>j)) (doM {
    x \<leftarrow> array_nth A i;
    y \<leftarrow> array_nth A j;
    array_upd A i y;
    array_upd A j x;
    return ()
  }) (return ())
}"

definition [llvm_code]: "qs_partition A lo hi \<equiv> doM {
  hi \<leftarrow> ll_sub hi (signed_nat 1);
  pivot \<leftarrow> array_nth A hi;
  let i = lo;

  i \<leftarrow> llc_for_range lo hi (\<lambda>j i. doM {
    Aj \<leftarrow> array_nth A j;
    if Aj < pivot then doM {
      qs_swap A i j;
      i \<leftarrow> ll_add i (signed_nat 1);
      return i
    } else return i
  }) i;

  qs_swap A i hi;
  return i
}"

definition [llvm_code]: "qs_quicksort A lo hi \<equiv> doM {
  REC (\<lambda>quicksort (lo,hi). doM {
    if lo < hi then doM {
      p \<leftarrow> qs_partition A lo hi;
      quicksort (lo, p-1);
      quicksort (p+1,hi)
    } else
      return ()

  }) (lo,hi);
  return ()
}"

(* TODO: Prepare-code-thms after inlining! *)
(* prepare_code_thms  qs_partition_def[unfolded llc_for_range_def] *)

(*prepare_code_thms [llvm_code] qs_quicksort_def*)

llvm_deps foo: "qs_quicksort :: 64 word ptr \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> unit llM"

export_llvm "qs_quicksort :: 64 word ptr \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> unit llM" is "qs_quicksort"
  file \<open>code/qs_quicksort.ll\<close>

definition "swap xs i j \<equiv> xs[ i:= xs!j, j:=xs!i]"

lemma qs_swap_aa_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>(aa_assn A) xs p ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>snat.assn j ji ** \<up>\<^sub>d(i<length xs \<and> j<length xs))
  (qs_swap p ii ji)
  (\<lambda>_. \<upharpoonleft>(aa_assn A) (swap xs i j) p)"
  unfolding qs_swap_def swap_def
  apply vcg_monadify
  apply vcg'
  done

lemma qs_swap_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>array_assn xs A ** \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>snat.assn j ji ** \<up>\<^sub>d(i<length xs \<and> j<length xs))
  (qs_swap A ii ji)
  (\<lambda>_. \<upharpoonleft>array_assn (swap xs i j) A)"
  unfolding qs_swap_def swap_def
  apply vcg_monadify
  apply vcg'
  done

fun at_idxs :: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list" (infixl "\<exclamdown>" 100) where
  "at_idxs xs [] = []"
| "at_idxs xs (i#is) = xs!i # at_idxs xs is"

lemma at_idxs_eq_map_nth: "at_idxs xs is = map (nth xs) is"
  by (induction "is") auto

lemma at_idxs_append[simp]: "at_idxs xs (is\<^sub>1@is\<^sub>2) = at_idxs xs is\<^sub>1 @ at_idxs xs is\<^sub>2"
  by (induction is\<^sub>1) auto

lemma at_idxs_ran_zero: "hi\<le>length xs \<Longrightarrow> at_idxs xs [0..<hi] = take hi xs"
  by (induction hi) (auto simp: take_Suc_conv_app_nth)

lemma at_idxs_slice: "hi\<le>length xs \<Longrightarrow> at_idxs xs [lo..<hi] = Misc.slice lo hi xs"
  apply (induction lo)
  apply (auto simp: Misc.slice_def at_idxs_ran_zero)
  by (simp add: at_idxs_eq_map_nth drop_take map_nth_upt_drop_take_conv)

(* TODO: Move *)
lemma pure_part_split_img:
  assumes "pure_part (\<Union>*i\<in>I. f i)"
  shows "(\<forall>i\<in>I. pure_part (f i))"
proof (cases "finite I")
  assume "finite I"
  then show ?thesis using assms
    by (induction) (auto dest: pure_part_split_conj)
next
  assume "infinite I" with assms show ?thesis by simp
qed

lemma "pure_part (\<upharpoonleft>(lstr_assn A I) as cs) \<Longrightarrow> (length cs = length as) \<and> (\<forall>i\<in>I. i<length as \<and> pure_part (\<upharpoonleft>A (as!i) (cs!i)))"
  by (auto simp: lstr_assn_def is_pure_def list_all2_conv_all_nth sep_algebra_simps
    dest!: pure_part_split_conj pure_part_split_img)

(* TODO: Move *)
lemma lstr_assn_insert: "i\<notin>I \<Longrightarrow> \<upharpoonleft>(lstr_assn A (insert i I)) as cs = (\<up>(i < length as) ** \<upharpoonleft>A (as!i) (cs!i) ** \<upharpoonleft>(lstr_assn A I) as cs)"
  by (auto simp: lstr_assn_def sep_algebra_simps pred_lift_extract_simps)

lemma fri_lstr_pure_rl[fri_rules]:
  "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(lstr_assn A I) as cs)) \<Longrightarrow> PRECOND (SOLVE_AUTO (i\<in>I)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>pA (as!i) (cs!i)"
  unfolding vcg_tag_defs
  by (auto simp: dr_assn_pure_asm_prefix_def lstr_assn_insert dr_assn_pure_prefix_def
    simp: sep_algebra_simps
    elim!: Set.set_insert dest!: pure_part_split_conj)

lemma length_swap[simp]: "length (swap xs i j) = length xs"
  by (auto simp: swap_def)

lemma at_idxs_cong:
  assumes "\<And>i. i\<in>List.set I \<Longrightarrow> xs!i = ys!i"
  shows "xs\<exclamdown>I = ys\<exclamdown>I"
  using assms
  apply (induction I)
  apply auto
  done

lemma at_idxs_upd_out[simp]: "i\<notin>List.set I \<Longrightarrow> xs[i:=x] \<exclamdown> I = xs\<exclamdown>I"
  by (auto intro: at_idxs_cong simp: nth_list_update')

lemma at_idxs_swap_out[simp]: "i\<notin>List.set I \<Longrightarrow> j\<notin>List.set I \<Longrightarrow> (swap xs i j)\<exclamdown>I = xs\<exclamdown>I"
  unfolding swap_def
  by auto

lemma mset_swap'[simp]: "\<lbrakk>i<length xs; j<length xs\<rbrakk> \<Longrightarrow> mset (swap xs i j) = mset xs"
  unfolding swap_def
  apply (auto simp: mset_swap)
  done

find_theorems at_idxs Misc.slice
find_theorems mset nth

lemma "llvm_htriple
  (\<upharpoonleft>(aa_assn snat.assn) as A ** \<upharpoonleft>snat.assn lo loi  ** \<upharpoonleft>snat.assn hi hii
    ** \<up>\<^sub>d(lo<hi \<and> hi\<le>length as))
  (qs_partition A loi hii)
  (\<lambda>pi. EXS as' p. \<upharpoonleft>(aa_assn snat.assn) as' A ** \<upharpoonleft>snat.assn p pi
    ** \<up>( lo\<le>p \<and> p<hi
        \<and> length as' = length as
        \<and> as'\<exclamdown>[0..<lo] = as\<exclamdown>[0..<lo]
        \<and> as'\<exclamdown>[hi..<length as] = as\<exclamdown>[hi..<length as]
        \<and> mset (as') = mset (as)
        \<and> (\<forall>i\<in>{lo..<p}. as!i \<le> as!p)
        \<and> (\<forall>i\<in>{p..<hi}. as!p \<le> as!i)
         ))"
  unfolding qs_partition_def
  apply (rewrite annotate_llc_for_range[where
    I="\<lambda>j ii. EXS i as'. \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>(aa_assn snat.assn) as' A
      ** \<up>(length as'=length as
        \<and> lo\<le>i \<and> i<hi
        \<and> as'\<exclamdown>[0..<lo] = as\<exclamdown>[0..<lo]
        \<and> as'\<exclamdown>[hi..<length as] = as\<exclamdown>[hi..<length as]
        \<and> mset (as') = mset (as)
      )

    "])
  apply vcg_monadify
  apply vcg'
  apply clarsimp_all
  apply auto
  prefer 2
  apply (subst at_idxs_swap_out)
  apply simp
  apply simp
  apply linarith
  apply simp
  oops
(*
xxx, ctd here: sharpen invariant!

  xxx, try "arr_assn A \<equiv> array o lst A"
  try to set up rules for nth and upd, using a set of externalized indexes (and their intermediate values).
    supplement frame inference by internalize/externalize rules

  apply vcg_try_solve
  apply vcg_try_solve

  apply vcg_rl back back
  apply vcg_try_solve
  apply (fri_dbg_step) back
  apply vcg_try_solve

  oops
  xxx, ctd here: Intro-trule for pure lstr-assn

  oops
  xxx, ctd here: The array itself contains data, which needs to be abstracted over!
    we will need to relate xs!i to some abstract value!

  oops

  xxx, integrate reduction rules into frame inference!
  xxx: simplify the resulting set differences during frame inference!
    Most important: Elimination of empty sets!

  xxx, ctd here: Integrate into frame inference
    "cut" is a bad name for this concept

  find_theorems sep_set_img

  ML_val \<open>@{term \<open>\<Union>*x\<in>y. p\<close>}\<close>

  lemma
    assumes "\<upharpoonleft>(lstr_assn A (I-I')) as cs \<turnstile> \<upharpoonleft>(lstr_assn A (I'-I)) as cs"
    shows "\<upharpoonleft>(lstr_assn A I) as cs \<turnstile> \<upharpoonleft>(lstr_assn A I') as cs"

    oops
  xxx, ctd here: do list_assn, with index set.

  derive rules to split/join those assertions. also rules for pure-case.
  in practice, let the lstr-assertions fragment, until some rule/frame forces a re-union.

  thm vcg_frame_erules

  apply vcg_rl

term "xs\<exclamdown>[2..<5]"

find_consts "nat \<Rightarrow> nat \<Rightarrow> _ list \<Rightarrow> _ list"

*)

end


theory Hotel_Example
imports MainRLT "HOL-Library.Predicate_Compile_Quickcheck"
begin

datatype guest = Guest0 | Guest1
datatype key = Key0 | Key1 | Key2 | Key3
datatype room = Room0

type_synonym card = "key * key"

datatype event =
  Check_in guest room card
| Enter guest room card
| Exit guest room

definition initk :: "room \<Rightarrow> key"
  where "initk = (%r. Key0)"

declare initk_def[code_pred_def, code]

primrec owns :: "event list \<Rightarrow> room \<Rightarrow> guest option"
where
  "owns [] r = None"
| "owns (e#s) r = (case e of
    Check_in g r' c \<Rightarrow> if r' = r then Some g else owns s r |
    Enter g r' c \<Rightarrow> owns s r |
    Exit g r' \<Rightarrow> owns s r)"

primrec currk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "currk [] r = initk r"
| "currk (e#s) r = (let k = currk s r in
    case e of Check_in g r' (k1, k2) \<Rightarrow> if r' = r then k2 else k
            | Enter g r' c \<Rightarrow> k
            | Exit g r \<Rightarrow> k)"

primrec issued :: "event list \<Rightarrow> key set"
where
  "issued [] = range initk"
| "issued (e#s) = issued s \<union>
  (case e of Check_in g r (k1, k2) \<Rightarrow> {k2} | Enter g r c \<Rightarrow> {} | Exit g r \<Rightarrow> {})"

primrec cards :: "event list \<Rightarrow> guest \<Rightarrow> card set"
where
  "cards [] g = {}"
| "cards (e#s) g = (let C = cards s g in
                    case e of Check_in g' r c \<Rightarrow> if g' = g then insert c C
                                                else C
                            | Enter g r c \<Rightarrow> C
                            | Exit g r \<Rightarrow> C)"

primrec roomk :: "event list \<Rightarrow> room \<Rightarrow> key"
where
  "roomk [] r = initk r"
| "roomk (e#s) r = (let k = roomk s r in
    case e of Check_in g r' c \<Rightarrow> k
            | Enter g r' (x,y) \<Rightarrow> if r' = r \<^cancel>\<open>\<and> x = k\<close> then y else k
            | Exit g r \<Rightarrow> k)"

primrec isin :: "event list \<Rightarrow> room \<Rightarrow> guest set"
where
  "isin [] r = {}"
| "isin (e#s) r = (let G = isin s r in
                 case e of Check_in g r c \<Rightarrow> G
                 | Enter g r' c \<Rightarrow> if r' = r then {g} \<union> G else G
                 | Exit g r' \<Rightarrow> if r'=r then G - {g} else G)"

primrec hotel :: "event list \<Rightarrow> bool"
where
  "hotel []  = True"
| "hotel (e # s) = (hotel s & (case e of
  Check_in g r (k,k') \<Rightarrow> k = currk s r \<and> k' \<notin> issued s |
  Enter g r (k,k') \<Rightarrow> (k,k') \<in> cards s g & (roomk s r \<in> {k, k'}) |
  Exit g r \<Rightarrow> g \<in> isin s r))"

definition no_Check_in :: "event list \<Rightarrow> room \<Rightarrow> bool" where(*>*)
[code del]: "no_Check_in s r \<equiv> \<not>(\<exists>g c. Check_in g r c \<in> set s)"

definition feels_safe :: "event list \<Rightarrow> room \<Rightarrow> bool"
where
  "feels_safe s r = (\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
   s = s\<^sub>3 @ [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 \<and>
   no_Check_in (s\<^sub>3 @ s\<^sub>2) r \<and> isin (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r = {})"

section \<open>Some setup\<close>

lemma issued_nil: "issued [] = {Key0}"
by (auto simp add: initk_def)

lemmas issued_simps[code] = issued_nil issued.simps(2)

setup \<open>Predicate_Compile_Data.ignore_consts [\<^const_name>\<open>Set.member\<close>,
  \<^const_name>\<open>issued\<close>, \<^const_name>\<open>cards\<close>, \<^const_name>\<open>isin\<close>,
  \<^const_name>\<open>Collect\<close>, \<^const_name>\<open>insert\<close>]\<close>
ML_val \<open>Core_Data.force_modes_and_compilations\<close>

fun find_first :: "('a => 'b option) => 'a list => 'b option"
where
  "find_first f [] = None"
| "find_first f (x # xs) = (case f x of Some y => Some y | None => find_first f xs)"

axiomatization cps_of_set :: "'a set => ('a => term list option) => term list option"
where cps_of_set_code [code]: "cps_of_set (set xs) f = find_first f xs"

axiomatization pos_cps_of_set :: "'a set => ('a => (bool * term list) option) => natural => (bool * term list) option"
where pos_cps_of_set_code [code]: "pos_cps_of_set (set xs) f i = find_first f xs"

axiomatization find_first' :: "('b Quickcheck_Exhaustive.unknown => 'a Quickcheck_Exhaustive.three_valued)
    => 'b list => 'a Quickcheck_Exhaustive.three_valued"
where find_first'_Nil: "find_first' f [] = Quickcheck_Exhaustive.No_value"
  and find_first'_Cons: "find_first' f (x # xs) =
    (case f (Quickcheck_Exhaustive.Known x) of
      Quickcheck_Exhaustive.No_value => find_first' f xs
    | Quickcheck_Exhaustive.Value x => Quickcheck_Exhaustive.Value x
    | Quickcheck_Exhaustive.Unknown_value =>
        (case find_first' f xs of Quickcheck_Exhaustive.Value x =>
          Quickcheck_Exhaustive.Value x
        | _ => Quickcheck_Exhaustive.Unknown_value))"

lemmas find_first'_code [code] = find_first'_Nil find_first'_Cons

axiomatization neg_cps_of_set :: "'a set => ('a Quickcheck_Exhaustive.unknown => term list Quickcheck_Exhaustive.three_valued) => natural => term list Quickcheck_Exhaustive.three_valued"
where neg_cps_of_set_code [code]: "neg_cps_of_set (set xs) f i = find_first' f xs"

setup \<open>
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val oi = Fun (Output, Fun (Input, Bool))
  val ii = Fun (Input, Fun (Input, Bool))
  fun of_set compfuns \<^Type>\<open>fun T _\<close> =
    case body_type (Predicate_Compile_Aux.mk_monadT compfuns T) of
      \<^Type>\<open>Quickcheck_Exhaustive.three_valued _\<close> =>
        Const(\<^const_name>\<open>neg_cps_of_set\<close>, \<^Type>\<open>set T\<close> --> Predicate_Compile_Aux.mk_monadT compfuns T)
    | _ => Const(\<^const_name>\<open>pos_cps_of_set\<close>, \<^Type>\<open>set T\<close> --> Predicate_Compile_Aux.mk_monadT compfuns T)
  fun member compfuns (U as \<^Type>\<open>fun T _\<close>) =
    (absdummy T (absdummy \<^Type>\<open>set T\<close> (Predicate_Compile_Aux.mk_if compfuns
      (\<^Const>\<open>Set.member T for \<open>Bound 1\<close> \<open>Bound 0\<close>\<close>))))

in
  Core_Data.force_modes_and_compilations \<^const_name>\<open>Set.member\<close>
    [(oi, (of_set, false)), (ii, (member, false))]
end
\<close>
section \<open>Property\<close>

lemma "\<lbrakk> hotel s; g \<in> isin s r \<rbrakk> \<Longrightarrow> owns s r = Some g"
quickcheck[tester = exhaustive, size = 6, expect = counterexample]
quickcheck[tester = smart_exhaustive, depth = 6, expect = counterexample]
oops

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
quickcheck[smart_exhaustive, depth = 10, allow_function_inversion, expect = counterexample]
oops

section \<open>Refinement\<close>

fun split_list
where
  "split_list [] = [([], [])]"
| "split_list (z # zs) = (([], z # zs) # [(z # xs', ys'). (xs', ys') <- split_list zs])"

lemma split_list: "((xs, ys) \<in> set (split_list zs)) = (zs = xs @ ys)"
apply (induct zs arbitrary: xs ys)
apply fastforce
apply (case_tac xs)
apply auto
done

lemma [code]: "feels_safe s r = list_ex (%(s3, s2, s1, g, c, c'). no_Check_in (s3 @ s2) r &
    isin (s2 @ [Check_in g r c] @ s1) r = {}) ([(s3, s2, s1, g, c, c'). (s3, Enter g' r' c # r3) <- split_list s, r' = r, (s2, Check_in g r'' c' # s1) <- split_list r3, r'' = r, g = g'])"
unfolding feels_safe_def list_ex_iff
by auto (metis split_list)+

lemma
  "hotel s ==> feels_safe s r ==> g \<in> isin s r ==> owns s r = Some g"
(* quickcheck[exhaustive, size = 9, timeout = 2000] -- maybe possible with a lot of time *)
quickcheck[narrowing, size = 7, expect = counterexample]
oops

end