section \<open>\isaheader{Array-Based Maps with Natural Number Keys}\<close>
theory Impl_Array_Map
imports
  "../../../Automatic_Refinement/Automatic_Refinement"
  "../../Lib/Diff_Array"
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym 'v iam = "'v option array"

subsection \<open>Definitions\<close>

definition iam_\<alpha> :: "'v iam \<Rightarrow> nat \<rightharpoonup> 'v" where
  "iam_\<alpha> a i \<equiv> if i < array_length a then array_get a i else None"

abbreviation iam_invar :: "'v iam \<Rightarrow> bool" where "iam_invar \<equiv> \<lambda>_. True"

definition iam_empty :: "unit \<Rightarrow> 'v iam"
  where "iam_empty \<equiv> \<lambda>_::unit. array_of_list []"

definition iam_lookup :: "nat \<Rightarrow> 'v iam \<rightharpoonup> 'v"
  where [code_unfold]: "iam_lookup k a \<equiv> iam_\<alpha> a k"

definition "iam_increment (l::nat) idx \<equiv>
  max (idx + 1 - l) (2 * l + 3)"

lemma incr_correct: "\<not> idx < l \<Longrightarrow> idx < l + iam_increment l idx"
  unfolding iam_increment_def by auto

definition iam_update :: "nat \<Rightarrow> 'v \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_update k v a \<equiv> let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)"

lemma [code]: "iam_update k v a \<equiv> array_set_oo
  (\<lambda>_. let l=array_length a in
         array_set (array_grow a (iam_increment l k) None) k (Some v))
  a k (Some v)"
  unfolding iam_update_def array_set_oo_def
  apply (rule eq_reflection)
  by auto

definition iam_delete :: "nat \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_delete k a \<equiv>
  if k<array_length a then array_set a k None else a"

lemma [code]: "iam_delete k a \<equiv> array_set_oo (\<lambda>_. a) a k None"
  unfolding iam_delete_def array_set_oo_def by auto

primrec iam_iteratei_aux
  :: "nat \<Rightarrow> ('v iam) \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> (nat \<times> 'v\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
  where
    "iam_iteratei_aux 0 a c f \<sigma> = \<sigma>"
  | "iam_iteratei_aux (Suc i) a c f \<sigma> = (
      if c \<sigma> then
        iam_iteratei_aux i a c f (
          case array_get a i of None \<Rightarrow> \<sigma> | Some x \<Rightarrow> f (i, x) \<sigma>
        )
      else \<sigma>)"

definition iam_iteratei :: "'v iam \<Rightarrow> (nat \<times> 'v,'\<sigma>) set_iterator" where
  "iam_iteratei a = iam_iteratei_aux (array_length a) a"

subsection \<open>Parametricity\<close>

definition iam_rel_def_internal:
  "iam_rel R \<equiv> \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
lemma iam_rel_def: "\<langle>R\<rangle> iam_rel = \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
    by (simp add: iam_rel_def_internal relAPP_def)

lemma iam_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>Rv\<rangle>iam_rel)"
  unfolding iam_rel_def
  by tagged_solver

lemma param_iam_\<alpha>[param]:
  "(iam_\<alpha>, iam_\<alpha>) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> nat_rel \<rightarrow> \<langle>R\<rangle> option_rel"
  unfolding iam_\<alpha>_def[abs_def] iam_rel_def by parametricity

lemma param_iam_invar[param]:
  "(iam_invar, iam_invar) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> bool_rel"
  unfolding iam_rel_def by parametricity

lemma param_iam_empty[param]:
  "(iam_empty, iam_empty) \<in> unit_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
    unfolding iam_empty_def[abs_def] iam_rel_def by parametricity

lemma param_iam_lookup[param]:
  "(iam_lookup, iam_lookup) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>option_rel"
  unfolding iam_lookup_def[abs_def]
  by parametricity

(* TODO: why does parametricity fail here? *)
lemma param_iam_increment[param]:
  "(iam_increment, iam_increment) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel"
  unfolding iam_increment_def[abs_def]
  by simp

(* TODO: The builtin "Let" rule for parametricity does some unpleasant things
         here, leading to an unprovable subgoal. Investigate this. *)
lemma param_iam_update[param]:
  "(iam_update, iam_update) \<in> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
unfolding iam_update_def[abs_def] iam_rel_def Let_def
apply parametricity
done

lemma param_iam_delete[param]:
  "(iam_delete, iam_delete) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
  unfolding iam_delete_def[abs_def] iam_rel_def by parametricity

lemma param_iam_iteratei_aux[param]:
  assumes I: "i \<le> array_length a"
  assumes IR: "(i,i') \<in> nat_rel"
  assumes AR: "(a,a') \<in> \<langle>Ra\<rangle>iam_rel"
  assumes CR: "(c,c') \<in> Rb \<rightarrow> bool_rel"
  assumes FR: "(f,f') \<in> \<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb"
  assumes \<sigma>R: "(\<sigma>,\<sigma>') \<in> Rb"
  shows "(iam_iteratei_aux i a c f \<sigma>, iam_iteratei_aux i' a' c' f' \<sigma>') \<in> Rb"
  using assms
  unfolding iam_rel_def
  apply (induct i' arbitrary: i \<sigma> \<sigma>')
  apply (simp_all only: pair_in_Id_conv iam_iteratei_aux.simps)
  apply parametricity
  apply simp_all
  done

lemma param_iam_iteratei[param]:
  "(iam_iteratei,iam_iteratei) \<in> \<langle>Ra\<rangle>iam_rel \<rightarrow> (Rb \<rightarrow> bool_rel) \<rightarrow>
      (\<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb) \<rightarrow> Rb \<rightarrow> Rb"
  unfolding iam_iteratei_def[abs_def]
  by parametricity (simp_all add: iam_rel_def)

subsection \<open>Correctness\<close>

definition "iam_rel' \<equiv> br iam_\<alpha> iam_invar"

lemma iam_empty_correct:
  "(iam_empty (), Map.empty) \<in>  iam_rel'"
   by (simp add: iam_rel'_def br_def iam_\<alpha>_def[abs_def] iam_empty_def)

lemma iam_update_correct:
  "(iam_update,op_map_update) \<in> nat_rel \<rightarrow> Id \<rightarrow> iam_rel'  \<rightarrow> iam_rel'"
   by (auto simp: iam_rel'_def br_def Let_def array_get_array_set_other
                  incr_correct iam_\<alpha>_def[abs_def] iam_update_def)

lemma iam_lookup_correct:
  "(iam_lookup,op_map_lookup) \<in> Id \<rightarrow> iam_rel' \<rightarrow> \<langle>Id\<rangle>option_rel"
   by (auto simp: iam_rel'_def br_def iam_lookup_def[abs_def])

lemma array_get_set_iff: "i<array_length a \<Longrightarrow>
  array_get (array_set a i x) j = (if i=j then x else array_get a j)"
  by (auto simp: array_get_array_set_other)

lemma iam_delete_correct:
  "(iam_delete,op_map_delete) \<in> Id \<rightarrow> iam_rel' \<rightarrow> iam_rel'"
  unfolding iam_\<alpha>_def[abs_def] iam_delete_def[abs_def] iam_rel'_def br_def
  by (auto simp: Let_def array_get_set_iff)

definition iam_map_rel_def_internal:
  "iam_map_rel Rk Rv \<equiv>
    if Rk=nat_rel then \<langle>Rv\<rangle>iam_rel O iam_rel' else {}"
lemma iam_map_rel_def:
  "\<langle>nat_rel,Rv\<rangle>iam_map_rel \<equiv> \<langle>Rv\<rangle>iam_rel O iam_rel'"
  unfolding iam_map_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "iam_map_rel" i_map]

lemma iam_map_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>nat_rel,Rv\<rangle>iam_map_rel)"
  unfolding iam_map_rel_def iam_rel'_def by tagged_solver

lemma iam_empty_impl:
    "(iam_empty (), op_map_empty) \<in> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def op_map_empty_def
  apply (intro relcompI)
  apply (rule param_iam_empty[THEN fun_relD], simp)
  apply (rule iam_empty_correct)
  done

lemma iam_lookup_impl:
    "(iam_lookup, op_map_lookup)
  \<in> nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>R\<rangle>option_rel"
unfolding iam_map_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (frule iam_lookup_correct[param_fo], assumption)
apply (frule param_iam_lookup[param_fo], assumption)
apply simp
done

lemma iam_update_impl:
   "(iam_update, op_map_update) \<in>
     nat_rel \<rightarrow> R \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (2) param_iam_update[param_fo])
  apply (rule iam_update_correct[param_fo])
  apply simp_all
  done

lemma iam_delete_impl:
    "(iam_delete, op_map_delete) \<in>
        nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (1) param_iam_delete[param_fo])
  apply (rule iam_delete_correct[param_fo])
  by simp_all

lemmas iam_map_impl =
  iam_empty_impl
  iam_lookup_impl
  iam_update_impl
  iam_delete_impl

declare iam_map_impl[autoref_rules]

subsection \<open>Iterator proofs\<close>

abbreviation "iam_to_list a \<equiv> it_to_list iam_iteratei a"

lemma distinct_iam_to_list_aux:
  shows "\<lbrakk>distinct xs; \<forall>(i,_)\<in>set xs. i \<ge> n\<rbrakk> \<Longrightarrow>
        distinct (iam_iteratei_aux n a
            (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
   (is "\<lbrakk>_;_\<rbrakk> \<Longrightarrow> distinct (?iam_to_list_aux n xs)")
proof (induction n arbitrary: xs)
  case (0 xs) thus ?case by simp
next
  case (Suc i xs)
    show ?case
    proof (cases "array_get a i")
      case None
        with Suc.IH[OF Suc.prems(1)] Suc.prems(2)
            show ?thesis by force
    next
      case (Some x)
        let ?xs' = "xs @ [(i,x)]"
        from Suc.prems have "distinct ?xs'" and
            "\<forall>(i',x)\<in>set ?xs'. i' \<ge> i" by force+
        from Some and Suc.IH[OF this] show ?thesis by simp
  qed
qed

lemma distinct_iam_to_list:
  "distinct (iam_to_list a)"
unfolding it_to_list_def iam_iteratei_def
  by (force intro: distinct_iam_to_list_aux)

lemma iam_to_list_set_correct_aux:
  assumes "(a, m) \<in> iam_rel'"
  shows "\<lbrakk>n \<le> array_length a; map_to_set m - {(k,v). k < n} = set xs\<rbrakk>
         \<Longrightarrow> map_to_set m =
             set (iam_iteratei_aux n a (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
proof (induction n arbitrary: xs)
  case (0 xs)
    thus ?case by simp
next
  case (Suc n xs)
    with assms have [simp]: "array_get a n = m n"
        unfolding iam_rel'_def br_def iam_\<alpha>_def[abs_def] by simp
    show ?case
    proof (cases "m n")
      case None
        with Suc.prems(2) have "map_to_set m - {(k,v). k < n} = set xs"
        unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from None and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    next
      case (Some x)
        let ?xs' = "xs @ [(n,x)]"
        from Some and Suc.prems(2)
            have "map_to_set m - {(k,v). k < n} = set ?xs'"
            unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from Some and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    qed
qed

lemma iam_to_list_set_correct:
  assumes "(a, m) \<in> iam_rel'"
  shows "map_to_set m = set (iam_to_list a)"
proof-
  from assms
      have A: "map_to_set m - {(k, v). k < array_length a} = set []"
      unfolding map_to_set_def iam_rel'_def br_def iam_\<alpha>_def[abs_def]
      by (force split: if_split_asm)
  with iam_to_list_set_correct_aux[OF assms _ A] show ?thesis
    unfolding it_to_list_def iam_iteratei_def by simp
qed

lemma iam_iteratei_aux_append:
  "n \<le> length xs \<Longrightarrow> iam_iteratei_aux n (Array (xs @ ys)) =
             iam_iteratei_aux n (Array xs)"
apply (induction n)
apply force
apply (intro ext, auto split: option.split simp: nth_append)
done

lemma iam_iteratei_append:
  "iam_iteratei (Array (xs @ [None])) c f \<sigma> =
       iam_iteratei (Array xs) c f \<sigma>"
  "iam_iteratei (Array (xs @ [Some x])) c f \<sigma> =
       iam_iteratei (Array xs) c f
       (if c \<sigma> then (f (length xs, x) \<sigma>) else \<sigma>)"
unfolding  iam_iteratei_def
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force simp: nth_append iam_iteratei_aux_append) []
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force split: option.split
             simp: nth_append iam_iteratei_aux_append) []
done

lemma iam_iteratei_aux_Cons:
  "n < array_length a \<Longrightarrow>
      iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) (x#xs) =
      x # iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) xs"
    by (induction n arbitrary: xs, auto split: option.split)

lemma iam_to_list_append:
  "iam_to_list (Array (xs @ [None])) = iam_to_list (Array xs)"
  "iam_to_list (Array (xs @ [Some x])) =
       (length xs, x) # iam_to_list (Array xs)"
unfolding  it_to_list_def iam_iteratei_def
apply (simp add: iam_iteratei_aux_append)
apply (simp add: iam_iteratei_aux_Cons)
apply (simp add: iam_iteratei_aux_append)
done

lemma autoref_iam_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list nat_rel Rv iam_map_rel iam_to_list"
  unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix a m'
  assume "(a,m') \<in> \<langle>nat_rel,Rv\<rangle>iam_map_rel"
  then obtain a' where [param]: "(a,a')\<in>\<langle>Rv\<rangle>iam_rel"
    and "(a',m')\<in>iam_rel'" unfolding iam_map_rel_def by blast

  have "(iam_to_list a, iam_to_list a')
            \<in> \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity

  moreover from distinct_iam_to_list and
                iam_to_list_set_correct[OF \<open>(a',m')\<in>iam_rel'\<close>]
      have "RETURN (iam_to_list a') \<le> it_to_sorted_list
               (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def key_rel_def[abs_def]
          by (force intro: refine_vcg)

  ultimately show "\<exists>l'. (iam_to_list a, l') \<in>
                            \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel
                    \<and> RETURN l' \<le> it_to_sorted_list (
                        key_rel (\<lambda>_ _. True)) (map_to_set m')" by blast
qed

(* We provide a ,,sorted'' iterator to simplify derivations of the
    generic algorithm library *)
lemmas [autoref_ga_rules] =
  autoref_iam_is_iterator[unfolded is_map_to_list_def]

lemma iam_iteratei_altdef:
    "iam_iteratei a = foldli (iam_to_list a)"
     (is "?f a = ?g (iam_to_list a)")
proof-
  obtain l where "a = Array l" by (cases a)
  have "?f (Array l) = ?g (iam_to_list (Array l))"
  proof (induction "length l" arbitrary: l)
    case (0 l)
      thus ?case by (intro ext,
          simp add: iam_iteratei_def it_to_list_def)
  next
    case (Suc n l)
      hence "l \<noteq> []" and [simp]: "length l = Suc n" by force+
      with append_butlast_last_id have [simp]:
          "butlast l @ [last l] = l" by simp
      with Suc have [simp]: "length (butlast l) = n" by simp
      note IH = Suc(1)[OF this[symmetric]]
      let ?l' = "iam_to_list (Array l)"

      show ?case
      proof (cases "last l")
        case None
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list (Array (butlast l)))"
              by (force simp: None iam_iteratei_append IH)
          also have "iam_to_list (Array (butlast l)) =
              iam_to_list (Array (butlast l @ [last l]))"
              using None by (simp add: iam_to_list_append)
          finally show "?f (Array l) = ?g ?l'" by simp
      next
        case (Some x)
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list
              (Array (butlast l @ [last l])))"
              by (force simp: IH iam_iteratei_append
                      iam_to_list_append Some)
          finally show ?thesis by simp
      qed
  qed
  thus ?thesis by (simp add: \<open>a = Array l\<close>)
qed

lemma pi_iam[icf_proper_iteratorI]:
  "proper_it (iam_iteratei a) (iam_iteratei a)"
unfolding proper_it_def by (force simp: iam_iteratei_altdef)

lemma pi'_iam[icf_proper_iteratorI]:
  "proper_it' iam_iteratei iam_iteratei"
  by (rule proper_it'I, rule pi_iam)

end


section\<open>Examples of Intuitionistic Reasoning\<close>

theory IFOL_examples imports IFOL begin

text\<open>Quantifier example from the book Logic and Computation\<close>
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule impI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule allI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule exI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule exE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule allE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
txt\<open>Now \<open>apply assumption\<close> fails\<close>
oops

text\<open>Trying again, with the same first two steps\<close>
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule impI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule allI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule exE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule exI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule allE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
done

lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
by (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)

text\<open>Example of Dyckhoff's method\<close>
lemma "~ ~ ((P-->Q) | (Q-->P))"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (unfold not_def)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule impI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule disj_impE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule imp_impE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
 apply (erule imp_impE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
apply (erule FalseE)+
done

end


section \<open>Cylindric Kleene Lattices and Liberation Kleene Lattices\<close>

text \<open>Using this mathematical component requires downloading the Archive of Formal Proofs.\<close>

theory CKL2
  imports Main  "~~/src/HOL/Library/Lattice_Syntax"
          Kleene_Algebra.Kleene_Algebra

begin

text \<open>Kleene algebras with a left zero are also known as weak Kleene algebras.\<close>

context kleene_algebra_zerol
begin

definition kplus :: "'a \<Rightarrow> 'a" ("_\<^sup>\<oplus>" [101] 100) where
  "x\<^sup>\<oplus> = x \<cdot> x\<^sup>\<star>"

lemma kplus_star: "x\<^sup>\<star> = 1 + x\<^sup>\<oplus>"
  by (simp add: kplus_def)

lemma kplus_star_opp: "x\<^sup>\<oplus> = x\<^sup>\<star> \<cdot> x"
  by (simp add: kplus_def local.star_slide_var)

lemma kplus_unfoldr [simp]: "x + x\<^sup>\<oplus> \<cdot> x = x\<^sup>\<oplus>"
  by (simp add: kplus_star_opp)

lemma kplus_unfoldl [simp]: "x + x \<cdot> x\<^sup>\<oplus> = x\<^sup>\<oplus>"
  using kplus_def kplus_star_opp kplus_unfoldr mult_assoc by auto

end

text \<open>We define weak l-monoids, weak residuated l-monoids, weak Kleene lattices and weak action lattices
and prove some properties.\<close>

class l_monoid_zerol = dioid_one_zerol + semilattice_inf +
  assumes absorp1 [simp]: "x + (x \<sqinter> y) = x"
  and absorp2 [simp]: "x \<sqinter> (x + y) = x"

begin

sublocale lmon_lat: lattice _ _ _ "(+)"
  by unfold_locales

lemma meet_zeror [simp]: "x \<sqinter> 0 = 0"
  by (simp add: inf_absorb2)

end

class residuated_l_monoid_zerol = l_monoid_zerol +
  fixes fres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and bres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes fres_adj: "(x \<cdot> y \<le> z) = (x \<le> fres z y)"
  and bres_adj: "(x \<cdot> y \<le> z) = (y \<le> bres x z)"

class distrib_l_monoid_zerol = l_monoid_zerol + distrib_lattice

begin

sublocale distrib_lattice "(\<sqinter>)" "(\<le>)" "(<)" "(+)"
  apply unfold_locales
  by (metis add_commute local.join.le_supI local.join.sup_ge2 local.sup_inf_distrib1 local.sup_unique)

end

class kleene_lattice_zerol = l_monoid_zerol + kleene_algebra_zerol

begin

lemma star_meet: "(x \<sqinter> y)\<^sup>\<star> \<le> x\<^sup>\<star> \<sqinter> y\<^sup>\<star>"
  by (simp add: star_iso)

end

class action_lattice_zerol = kleene_lattice_zerol + residuated_l_monoid_zerol

class l_monoid = l_monoid_zerol + dioid_one_zero

class kleene_lattice = kleene_lattice_zerol + dioid_one_zero

begin

subclass l_monoid
  by unfold_locales

end

class action_lattice = action_lattice_zerol + dioid_one_zero

text \<open>Next we define weak cylindric l-monoids and prove some basic properties.\<close>

locale cylindric_l_monoid_zerol =
  fixes cyl :: "'a::linorder \<Rightarrow> 'b::l_monoid_zerol \<Rightarrow> 'b"
  assumes cyl_ext: "x \<le> cyl i x"
  and cyl_sup_add: "cyl i (x + y) = (cyl i x) + (cyl i y)"
  and cyl_multl: "cyl i ((cyl i x) \<cdot> y) = (cyl i x) \<cdot> (cyl i y)"
  and cyl_multr: "cyl i (x \<cdot> cyl i y) = (cyl i x) \<cdot> (cyl i y)"
  and cyl_inf: "cyl i (x \<sqinter> (cyl i y)) = (cyl i x) \<sqinter> (cyl i y)"
  and cyl_zero [simp]: "cyl i 0 = 0"
  and cyl_comm: "cyl i (cyl j x) = cyl j (cyl i x)"
  and cyl_id_meet: "i \<noteq> j \<Longrightarrow> (cyl i 1) \<sqinter> (cyl j 1) = 1"
  and cyl_id_meet_pres: "(cyl i 1 \<cdot> cyl j 1) \<sqinter> (cyl i 1 \<cdot> cyl k 1) \<le> cyl i (cyl j 1 \<sqinter> cyl k 1)"
  and cyl_id_seq: "cyl i (cyl j 1) \<le> cyl i 1 \<cdot> cyl j 1"

begin

lemma cyl_zero_iff: "(cyl i x = 0) = (x = 0)"
  by (metis cyl_ext cyl_zero join.bot.extremum_unique)

lemma cyl_iso: "x \<le> y \<Longrightarrow> cyl i x \<le> cyl i y"
  by (metis cyl_sup_add less_eq_def)

lemma cyl_clos: "(x \<le> cyl i y) = (cyl i x \<le> cyl i y)"
  by (metis cyl_ext cyl_inf le_iff_inf order_trans)

lemma cyl_rel_prop_var1: "cyl i 1 \<cdot> x \<le> cyl i x"
  by (smt cyl_clos cyl_multl cyl_multr monoid.left_neutral mult.monoid_axioms order_refl)

lemma cyl_rel_prop_var2: "x \<cdot> cyl i 1 \<le> cyl i x"
  by (metis cyl_clos cyl_ext cyl_multl cyl_multr mult_oner)

lemma cyl_rel_prop: "cyl i 1 \<cdot> x \<cdot> cyl i 1 \<le> cyl i x"
  using cyl_clos cyl_rel_prop_var1 cyl_rel_prop_var2 order_trans by blast

lemma cyl_oplax: "cyl i (x \<cdot> y) \<le> cyl i x \<cdot> cyl i y"
  by (metis cyl_ext cyl_iso cyl_multr mult_isol)

lemma cyl_fix_prop: "cyl i x = x \<Longrightarrow> cyl i 1 \<cdot> x \<cdot> cyl i 1 = x"
  by (metis cyl_multl cyl_multr mult_onel mult_oner)

lemma cyl_fix_im: "(cyl i x = x) = (\<exists>y. cyl i y = x)"
  by (meson cyl_clos eq_iff)

lemma cyl_1_unl [simp]: "cyl i 1 \<cdot> cyl i x = cyl i x"
  by (metis cyl_fix_im cyl_multr mult_onel)

lemma cyl_1_unr [simp]: "cyl i x \<cdot> cyl i 1 = cyl i x"
  by (metis cyl_fix_im cyl_multl mult_oner)

lemma cyl_1_idem [simp]: "cyl i 1 \<cdot> cyl i 1 = cyl i 1"
  by simp

lemma cyl_conj: "(x \<sqinter> cyl i y = 0) = (y \<sqinter> cyl i x = 0)"
  by (metis cyl_inf cyl_zero_iff inf_commute)

lemma cyl_conj_var: "(cyl i x \<sqinter> cyl j y = 0) = (cyl j x \<sqinter> cyl i y = 0)"
  by (simp add: cyl_comm cyl_conj)

lemma cyl_1_zero [simp]: "cyl i 1 \<cdot> 0 = 0"
  by (metis cyl_zero cyl_1_unl)

lemma cyl_id_seq_eq: "cyl i (cyl j 1) = cyl i 1 \<cdot> cyl j 1"
  by (simp add: cyl_id_seq cyl_rel_prop_var1 dual_order.antisym)

lemma cyl_id_comm: "(cyl i 1) \<cdot> (cyl j 1) = (cyl j 1) \<cdot> (cyl i 1)"
  by (metis cyl_comm cyl_id_seq_eq)

lemma cyl_id_meet_pres_eq: "cyl i (cyl j 1 \<sqinter> cyl k 1) = (cyl i 1 \<cdot> cyl j 1) \<sqinter> (cyl i 1 \<cdot> cyl k 1)"
  apply (rule antisym)
  apply (metis cyl_ext cyl_id_meet cyl_id_seq_eq cyl_iso cyl_rel_prop_var1 inf.idem le_inf_iff)
  by (simp add: cyl_id_meet_pres)

lemma cyl_id_meet_pres_var: "cyl i (cyl j 1 \<sqinter> cyl k 1) = cyl i (cyl j 1) \<sqinter> cyl i (cyl k 1)"
  unfolding cyl_id_meet_pres_eq
  by (smt cyl_ext cyl_id_meet cyl_id_meet_pres_eq cyl_id_seq_eq cyl_rel_prop_var1 inf.absorb2)

lemma cyl_id_meet_pres_var2: "cyl i (cyl j 1 \<sqinter> cyl k 1) = cyl i 1 \<cdot> (cyl j 1 \<sqinter> cyl k 1)"
  by (smt cyl_1_unl cyl_id_meet cyl_id_meet_pres_eq inf_idem mult_onel mult_oner)

lemma cyl_id_meet_pres_var3: "(cyl i 1 \<cdot> cyl j 1) \<sqinter> (cyl i 1 \<cdot> cyl k 1) = cyl i 1 \<cdot> (cyl j 1 \<sqinter> cyl k 1)"
  by (metis cyl_id_meet cyl_id_meet_pres_eq inf.idem mult_oner)

lemma cyl_one_comm: "j \<noteq> k \<Longrightarrow> cyl i (cyl j 1) \<sqinter> cyl i (cyl k 1) = cyl i 1"
  by (metis cyl_id_meet cyl_id_meet_pres_var)

lemma cyl_id_meet_presl: "cyl i 1 \<cdot> ((cyl i 1 \<cdot> x) \<sqinter> (cyl i 1 \<cdot> y)) = (cyl i 1 \<cdot> x) \<sqinter> (cyl i 1 \<cdot> y)"
  apply (rule antisym)
  apply (metis (no_types, lifting) cyl_1_unl cyl_rel_prop_var1 le_inf_iff lmon_lat.inf_sup_ord(1) lmon_lat.inf_sup_ord(2) mult.assoc mult_isol_var mult_oner)
  by (metis cyl_ext mult_isor mult_onel)

lemma cyl_id_meet_presr: "((x \<cdot> cyl i 1) \<sqinter> (y \<cdot> cyl i 1)) \<cdot> cyl i 1 = (x \<cdot> cyl i 1) \<sqinter> (y \<cdot> cyl i 1)"
  apply (rule antisym)
  apply (metis (no_types, lifting) cyl_1_idem le_inf_iff lmon_lat.inf_sup_ord(1) lmon_lat.inf_sup_ord(2) mult.assoc mult_double_iso mult_onel)
  by (metis cyl_ext mult_isol mult_oner)

lemma cyl_id_meet_preslr: "cyl i 1 \<cdot> ((cyl i 1 \<cdot> x \<cdot> cyl i 1) \<sqinter> (cyl i 1 \<cdot> y \<cdot> cyl i 1)) \<cdot> cyl i 1 = (cyl i 1 \<cdot> x \<cdot> cyl i 1) \<sqinter> (cyl i 1 \<cdot> y \<cdot> cyl i 1)"
  by (metis (no_types, lifting) cyl_id_meet_presl cyl_id_meet_presr mult.assoc)

lemma cyl_id_add_comp: "cyl i 1 + cyl j 1 \<le> cyl i 1 \<cdot> cyl j 1"
  by (metis cyl_ext cyl_id_seq_eq cyl_iso join.le_sup_iff)

lemma
  assumes "\<forall>(x::'b) y. x \<le> 1 \<and> y \<le> 1 \<longrightarrow> x \<cdot> y = x \<sqinter> y"
  and "\<forall>(x::'b). x \<le> 1 \<longrightarrow> (\<exists>y. y \<le> 1 \<and> x + y = 1)"
  and "\<forall>(x::'b). x \<le> 1 \<longrightarrow> (\<exists>y. y \<le> 1 \<and> x \<sqinter> y = 0)"
  shows "x \<le> 1 \<Longrightarrow> cyl i 1 \<cdot> (cyl i x \<sqinter> 1) = cyl i x"
  (*nitpick*)
  oops

lemma "(cyl i x = x) = (cyl i 1 \<cdot> x \<cdot> cyl i 1 = x)"
  (*nitpick*)
  oops

lemma "cyl i 1 = (1::'b::l_monoid_zerol)"
  (*nitpick[show_all]*)
  oops

lemma cyl_one_comm_var: "j \<noteq> k \<Longrightarrow> cyl i 1 \<cdot> cyl j 1 \<sqinter> cyl i 1 \<cdot> cyl k 1 = cyl i 1"
  (*nitpick*)
  oops

lemma cyl_inter_one: "x \<le> 1 \<Longrightarrow> cyl i (cyl i x \<sqinter> 1) = cyl i x"
  by (metis absorp2 cyl_inf cyl_sup_add inf_commute join.le_iff_sup)

lemma cyl_inter_one_comm: "x \<le> 1 \<Longrightarrow> cyl i (cyl j x \<sqinter> 1) = cyl j (cyl i x \<sqinter> 1)"
  (*nitpick*)
  oops

lemma "cyl i 1 + cyl j 1 = cyl i 1 \<cdot> cyl j 1"
  (*nitpick*)
  oops

lemma "i \<noteq> j \<Longrightarrow> cyl i x \<noteq> cyl j x"
  nitpick
  oops

lemma "i \<noteq> j \<Longrightarrow> cyl i 1 \<noteq> cyl j 1"
  nitpick
  oops

end

locale distrib_cylindric_l_monoid_zerol = cylindric_l_monoid_zerol cyl for cyl +
  constrains cyl :: "'a::linorder \<Rightarrow> 'b::distrib_l_monoid_zerol \<Rightarrow> 'b"

locale cylindric_l_monoid = cylindric_l_monoid_zerol cyl for cyl +
  constrains cyl :: "'a::linorder \<Rightarrow> 'b::l_monoid \<Rightarrow> 'b"

begin

lemma "cyl i 1 \<cdot> x \<cdot> cyl i 1 = cyl i x"
  (*nitpick[show_all]*)
  oops

lemma "(cyl i x = x) = (cyl i 1 \<cdot> x \<cdot> cyl i 1 = x)"
  (*nitpick*)
  oops

lemma "(cyl i 1 \<cdot> x \<cdot> cyl i 1 = x) = (cyl i 1 \<cdot> x = x)"
  (*nitpick*)
  oops

lemma "(cyl i 1 \<cdot> x \<cdot> cyl i 1 = x) = (x \<cdot> cyl i 1 = x)"
  (*nitpick*)
  oops

lemma "(cyl i 1 \<cdot> x = x) = (x \<cdot> cyl i 1 = x)"
  (*nitpick*)
  oops

end

text \<open>Next we define weak cylindric Kleene lattices and prove some properties.\<close>

locale cylindric_kleene_lattice_zerol = cylindric_l_monoid_zerol +
  assumes cyl_kplus: "cyl i (x\<^sup>\<oplus>) \<le> (cyl i x::'b::{l_monoid_zerol,kleene_algebra_zerol})\<^sup>\<oplus>"

begin

lemma cyl_star: "cyl i x\<^sup>\<star> \<le> cyl i 1 \<cdot> (cyl i x)\<^sup>\<star>"
  by (metis cyl_ext mult_isor mult_onel)

lemma cyl_cyl_kplus [simp]: "cyl i ((cyl i x)\<^sup>\<oplus>) = (cyl i x)\<^sup>\<oplus>"
  by (metis cyl_ext cyl_fix_im cyl_kplus order_class.order.antisym)

lemma cyl_kplus_onel [simp]: "cyl i 1 \<cdot> (cyl i x)\<^sup>\<oplus> = (cyl i x)\<^sup>\<oplus>"
  by (metis cyl_cyl_kplus cyl_1_unl)

lemma cyl_kplus_one_shift [simp]: "cyl i 1 \<cdot> (cyl i x)\<^sup>\<oplus> = (cyl i x)\<^sup>\<oplus> \<cdot> 1"
  by simp

lemma cyl_kplus_id [simp]: "(cyl i 1)\<^sup>\<oplus> = (cyl i 1)"
  by (simp add: kplus_def star_inductr_var_eq2)

lemma cyl_star_one: "cyl i ((cyl i x)\<^sup>\<star>) = cyl i 1 \<cdot> (cyl i x)\<^sup>\<star>"
  by (simp add: cyl_sup_add kplus_star semiring_class.distrib_left)

lemma cyl_star_one_shift: "cyl i 1 \<cdot> (cyl i x)\<^sup>\<star> = (cyl i x)\<^sup>\<star> \<cdot> cyl i 1"
  by (simp add: star_sim3)

lemma cyl_1_prop: "(cyl i 1)\<^sup>\<star> \<le> cyl i 1"
  by (simp add: local.cyl_ext star_inductl_one)

lemma cyl_star_id [simp]: "(cyl i 1)\<^sup>\<star> = cyl i 1"
  by (simp add: cyl_1_prop order_class.order.antisym)

lemma cyl_plus_absorb: "cyl i 1 \<cdot> x\<^sup>\<oplus> \<cdot> cyl i 1 \<le> (cyl i 1 \<cdot> x)\<^sup>\<oplus> \<cdot> cyl i 1"
  by (smt conway.dagger_slide cyl_star_id kplus_def mult.assoc mult_isol star_denest_var_2 star_denest_var_4 star_ext)

lemma cyl_star_add_comp: "(cyl i 1 + cyl j 1)\<^sup>\<star> = cyl i 1 \<cdot> cyl j 1"
  by (metis church_rosser cyl_id_comm cyl_id_seq_eq cyl_rel_prop_var1 cyl_star_id)

lemma cyl_plus_add_comp: "(cyl i 1 + cyl j 1)\<^sup>\<oplus> = cyl i 1 \<cdot> cyl j 1"
  by (metis (no_types, lifting) bubble_sort cyl_ext cyl_id_comm cyl_id_seq_eq cyl_rel_prop_var1 cyl_star_id join.sup_ge2 kplus_def order_trans sup_id_star1)

lemma "(cyl i 1 \<cdot> x \<cdot> cyl i 1) \<sqinter> (cyl i 1 \<cdot> y \<cdot> cyl i 1) = cyl i 1 \<cdot> (x \<sqinter> (cyl i 1 \<cdot> y \<cdot> cyl i 1)) \<cdot> cyl i 1"
  (*nitpick*)
  oops

lemma  "(\<forall>x. cyl i x = cyl i 1 \<cdot> x \<cdot> cyl i 1) \<Longrightarrow> (\<forall>x. x \<cdot> 0 = 0) \<Longrightarrow> (cyl i 1 \<cdot> x) \<sqinter> (cyl i 1 \<cdot> y) = cyl i 1 \<cdot> (x \<sqinter> (cyl i 1 \<cdot> y))"
  (*nitpick*)
  oops

lemma  "(\<forall>x. cyl i x = cyl i 1 \<cdot> x \<cdot> cyl i 1) \<Longrightarrow> (\<forall>x. x \<cdot> 0 = 0) \<Longrightarrow> (x \<cdot> cyl i 1) \<sqinter> (y \<cdot> cyl i 1) = (x \<sqinter> (y \<cdot> cyl i 1)) \<cdot> cyl i 1"
  (*nitpick*)
  oops

lemma "(cyl i 1 + cyl j 1)\<^sup>\<star> = (cyl i 1 + cyl j 1)"
  (*nitpick*)
  oops

end

locale cylindric_kleene_lattice = cylindric_kleene_lattice_zerol cyl for cyl +
  constrains cyl :: "'a::linorder \<Rightarrow> 'b::kleene_lattice \<Rightarrow> 'b"

text \<open>We formalise a dual inner cylindrification in cylindric Kleene lattices.\<close>

locale dual_cylindric_kleene_lattice =
  fixes cy :: "'a \<Rightarrow> 'b::kleene_lattice_zerol \<Rightarrow> 'b"
  and dcy :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes cy_adj: "(cy i x \<le> y) = (x \<le> dcy i y)"
  assumes cy_seq1: "cy i (x \<cdot> cy i y) = cy i x \<cdot> cy i y"
  and zy_seq2: "cy i (cy i x \<cdot> y) = cy i x \<cdot> cy i y"
  and dzy_le_zy: "dcy i x \<le> cy i x"
  and zy_meet: "cy i (x \<sqinter> cy i y) = cy i x \<sqinter> cy i y"
  and cy_dcy_semicomm: "cy i (dcy j x) \<le> dcy j (cy i x)"
  and dcy_one: "dcy i 1 = 0"
  and cy_kplus : "cy i (x\<^sup>\<oplus>) \<le> (cy i x)\<^sup>\<oplus>"
  and l6: "i \<noteq> j \<Longrightarrow> (cy i 1) \<sqinter> (cy j 1) = 1"
  and cyl_id_meet_pres: "cy i 1 \<cdot> cy j 1 \<sqinter> cy i 1 \<cdot> cy k 1 \<le> cy i (cy j 1 \<sqinter> cy k 1)"

begin

lemma "dcy i (x + dcy i y) = dcy i x + dcy i y"
  (*nitpick*)
  oops

lemma cy_idem [simp]: "cy i (cy i x) = cy i x"
  by (smt cy_adj dzy_le_zy inf.absorb_iff1 inf.idem join.sup.orderE less_eq_def zy_meet)

lemma dcy_idem [simp]: "dcy i (dcy i x) = dcy i x"
  by (metis cy_adj cy_idem order_class.order.antisym order_refl)

lemma dcy_cy [simp]: "dcy i (cy i x) = cy i x"
  by (metis cy_adj cy_idem dzy_le_zy order_class.order.antisym order_refl)

lemma dcy_dzy [simp]: "cy i (dcy i x) = dcy i x"
  by (metis cy_adj dcy_cy order_class.order.antisym order_refl)

lemma cy_comm: "cy i (cy j x) = cy j (cy i x)"
  by (meson cy_adj cy_dcy_semicomm eq_iff order.trans)

lemma dcy_comm: "dcy i (dcy j x) = dcy j (dcy i x)"
  by (smt cy_adj cy_comm dcy_dzy eq_iff)

lemma cy_dcy_index_comm: "(cy i x \<le> dcy j y) = (cy j x \<le> dcy i y)"
  by (simp add: cy_adj dcy_comm)

lemma cy_iso: "x \<le> y \<Longrightarrow> cy i x \<le> cy i y"
  by (metis cy_adj inf.orderE le_infI2 order_refl)

lemma dcy_iso: "x \<le> y \<Longrightarrow> dcy i x \<le> dcy i y"
  by (meson cy_adj dual_order.trans order_refl)

lemma cy_sup_pres: "cy i (x + y) = cy i x + cy i y"
  by (meson cy_adj cy_iso join.le_sup_iff join.sup.cobounded1 join.sup.cobounded2 order_class.order.antisym)

lemma dcy_inf_pres: "dcy i (x \<sqinter> y) = dcy i x \<sqinter> dcy i y"
  by (meson cy_adj dcy_iso inf.cobounded1 inf.cobounded2 le_inf_iff order_class.order.antisym)

lemma cy_canc1: "cy i (dcy i x) \<le> x"
  using cy_adj by blast

lemma cy_canc3: "x \<le> dcy i (cy i x)"
  using cy_adj by blast

lemma cy_zero [simp]: "cy i 0 = 0"
  by (metis dcy_dzy dcy_one)

lemma cy_infl: "x \<le> cy i x"
  using cy_canc3 by auto

lemma dcy_infl: "dcy i x \<le> x"
  using cy_canc1 by auto

lemma cy_meet: "cy i (x \<cdot> dcy i y) = cy i x \<cdot> dcy i y"
  by (metis cy_seq1 dcy_dzy)

lemma cy_dcy_meet: "cy i (dcy i x \<cdot> y) = dcy i x \<cdot> cy i y"
  by (metis dcy_dzy zy_seq2)

lemma dcy_seq1: "dcy i x \<cdot> dcy i y \<le> dcy i (x \<cdot> dcy i y)"
  by (metis cy_adj cy_meet dcy_dzy dcy_infl mult_isor)

lemma dcy_seq2: "dcy i x \<cdot> dcy i y \<le> dcy i (dcy i x \<cdot> y)"
  by (metis cy_adj cy_dcy_meet dcy_dzy dcy_infl mult_isol)

lemma "dcy i x \<cdot> dcy i y = dcy i (x \<cdot> dcy i y)"
  (*nitpick*)
  oops

lemma "dcy i x \<cdot> dcy i y = dcy i (dcy i x \<cdot> y)"
  (*nitpick*)
  oops

lemma dcy_meet_prop: "dcy i x \<cdot> dcy i y \<le> dcy i (x \<cdot> y)"
  by (metis cy_adj cy_dcy_meet dcy_dzy dcy_infl mult_isol_var)

lemma dcy_fix: "(dcy i x = x) = (\<exists>y. dcy i y = x)"
  by auto

lemma dcy_star: "(dcy i x)\<^sup>\<oplus> \<le> dcy i (x\<^sup>\<oplus>)"
  by (metis (no_types, lifting) cy_adj cy_canc3 cy_kplus dcy_dzy kplus_def mult_isol_var order_class.order.antisym star_iso)

lemma dcy_star_prop [simp]: "dcy i ((dcy i x)\<^sup>\<oplus>) = (dcy i x)\<^sup>\<oplus>"
  by (metis dcy_idem dcy_infl dcy_star eq_iff)

lemma cyl_id_meet_pres_eq: "cy i ((cy j 1) \<sqinter> (cy k 1)) = (cy i (cy j 1)) \<sqinter> (cy i (cy k 1))"
proof -
have f1: "\<forall>b ba a bb. bb \<le> cy a b \<or> \<not> bb \<le> cy a (ba \<sqinter> cy a b)"
  using zy_meet by auto
have f2: "\<forall>a aa b. b \<sqinter> cy aa (cy a b) = b"
by (metis cy_infl inf.orderE le_inf_iff)
  then have "\<forall>a aa. cy aa 1 \<sqinter> (cy aa 1 \<cdot> cy a 1) = cy aa 1 \<cdot> cy a 1"
using f1 by (metis (no_types) cy_seq1 cyl_id_meet_pres inf.commute inf.orderE mult_onel zy_meet)
  then have "\<forall>a aa. cy aa 1 \<sqinter> cy a 1 = cy aa 1"
    using f1 by (metis (no_types) cy_infl cy_seq1 inf.commute inf.orderE mult_onel zy_seq2)
  then show ?thesis
    using f2 by (metis inf.commute zy_meet)
qed

end

text \<open>Next we turn to weak liberation Kleene lattices.\<close>

locale liberation_l_monoid_zerol =
  fixes lib :: "'a \<Rightarrow> 'b::l_monoid_zerol"
  assumes l1 [simp]: "lib i \<cdot> 0 = 0"
  and l2: "1 \<le> lib i"
  and l3: "lib i \<cdot> (x \<sqinter> ((lib i) \<cdot> y)) = ((lib i) \<cdot> x) \<sqinter> ((lib i) \<cdot> y)"
  and l4: "(x \<sqinter> (y \<cdot> lib i)) \<cdot> lib i = (x \<cdot> lib i) \<sqinter> (y \<cdot> lib i)"
  and l5: "(lib i) \<cdot> (lib j) = (lib j) \<cdot> (lib i)"
  and l6: "i \<noteq> j \<Longrightarrow> (lib i) \<sqinter> (lib j) = 1"
  and l7: "(lib i \<cdot> lib j) \<sqinter> (lib i \<cdot> lib k) \<le> lib i \<cdot> (lib j \<sqinter> lib k)"
  and l8: "(lib i \<cdot> lib k) \<sqinter> (lib j \<cdot> lib k) \<le> (lib i \<sqinter> lib j) \<cdot> lib k"

begin

lemma "i \<noteq> j \<Longrightarrow> i \<noteq> k \<Longrightarrow> j \<noteq> k \<Longrightarrow> (lib i \<cdot> lib j) \<sqinter> lib k = 1"
  (*nitpick*)
  oops

lemma "i \<noteq> j \<Longrightarrow> i \<noteq> k \<Longrightarrow> i \<noteq> l \<Longrightarrow> j \<noteq> k \<Longrightarrow> j \<noteq> l \<Longrightarrow> k \<noteq> l \<Longrightarrow> (lib i \<cdot> lib j) \<sqinter> (lib k \<cdot> lib l) = 1"
  (*nitpick*)
  oops

lemma lib_annir [simp]: "lib i \<cdot> 0 \<cdot> lib i = 0"
  by simp

lemma lib_idem [simp]: "lib i \<cdot> lib i = lib i"
  by (metis inf.absorb2 l2 l3 mult_onel mult_oner order_refl phl_cons1)

lemma lib_double_add: "lib i \<cdot> (x + y) \<cdot> lib i = (lib i \<cdot> x \<cdot> lib i) + (lib i \<cdot> y \<cdot> lib i)"
  by (simp add: semiring_class.distrib_left)

lemma lib_seq1: "lib i \<cdot> x \<cdot> lib i \<cdot> y \<cdot> lib i \<cdot> lib i = lib i \<cdot> x \<cdot> lib i \<cdot> lib i \<cdot> y \<cdot> lib i"
  by (simp add: semigroup_mult_class.mult.assoc)

lemma lib_seq2: "lib i \<cdot> lib i \<cdot> x \<cdot> lib i \<cdot> y \<cdot> lib i = lib i \<cdot> x \<cdot> lib i \<cdot> lib i \<cdot> y \<cdot> lib i"
  by (simp add: semigroup_mult_class.mult.assoc)

lemma  lib_meet: "lib i \<cdot> (x \<sqinter> (lib i \<cdot> y \<cdot> lib i)) \<cdot> lib i = (lib i \<cdot> x \<cdot> lib i) \<sqinter> (lib i \<cdot> y \<cdot> lib i)"
  by (metis l3 l4 mult.assoc)

lemma l7_eq: "(lib i \<cdot> lib j) \<sqinter> (lib i \<cdot> lib k) = lib i \<cdot> (lib j \<sqinter> lib k)"
  by (simp add: antisym l7 mult_isol_var)

lemma l8_eq: "(lib i \<cdot> lib k) \<sqinter> (lib j \<cdot> lib k) = (lib i \<sqinter> lib j) \<cdot> lib k"
  by (simp add: antisym l8 mult_isor)

lemma cyl10: "lib i \<cdot> lib j \<cdot> lib i = lib i \<cdot> lib j"
  by (metis l5 lib_idem mult.assoc)

end

locale liberation_l_monoid = liberation_l_monoid_zerol lib for lib +
  constrains lib :: "'a \<Rightarrow> 'b::l_monoid"

locale liberation_kleene_lattice_zerol = liberation_l_monoid_zerol lib for lib +
  constrains lib :: "'a \<Rightarrow> 'b::kleene_lattice_zerol"

begin

lemma lib_kplus_prop1 [simp]: "(lib i \<cdot> x \<cdot> lib i)\<^sup>\<oplus> = (lib i \<cdot> x)\<^sup>\<oplus> \<cdot> lib i"
  by (simp add: conway.dagger_slide kplus_def mult.assoc)

lemma lib_star_prop: "lib i \<cdot> x\<^sup>\<oplus> \<cdot> lib i \<le> (lib i \<cdot> x)\<^sup>\<oplus> \<cdot> lib i"
proof -
  have "1 \<le> lib i"
    by (simp add: l2)
  then have "(x + x)\<^sup>\<star> \<cdot> (lib i \<cdot> (x \<cdot> x\<^sup>\<star>) + lib i \<cdot> (x \<cdot> x\<^sup>\<star>))\<^sup>\<star> = (lib i \<cdot> x)\<^sup>\<star>"
    by (metis (no_types) distrib_right join.sup_idem less_eq_def mult.assoc mult.left_neutral star_denest_var)
  then have "lib i \<cdot> x \<cdot> (lib i \<cdot> x)\<^sup>\<star> = (lib i \<cdot> (x \<cdot> x\<^sup>\<star>))\<^sup>\<oplus>"
    by (simp add: kplus_def mult.assoc)
  then show ?thesis
    by (metis (no_types) absorp2 inf.absorb_iff2 inf.commute kplus_def kplus_unfoldl mult_isor)
qed

lemma lib_kplus_prop2: "(lib i \<cdot> x)\<^sup>\<oplus> \<cdot> lib i = lib i \<cdot> (x \<cdot> lib i)\<^sup>\<oplus>"
  by (simp add: kplus_def mult.assoc star_slide)

lemma lib_cyll: "lib i \<cdot> x\<^sup>\<oplus> \<le> (lib i \<cdot> x)\<^sup>\<oplus>"
  by (metis (no_types, hide_lams) kplus_def l2 mult.assoc mult_isol mult_isor mult_onel star_iso)

lemma lib_cylr: "x\<^sup>\<oplus> \<cdot> lib i \<le> (x \<cdot> lib i)\<^sup>\<oplus>"
  by (smt conway.dagger_subdist join.sup_aci(1) kplus_def kplus_star_opp l2 lib_idem mult.assoc mult_double_iso star_denest_var sup_id_star1 tc_eq)

lemma "lib i \<cdot> lib j = lib i + lib j"
  (*nitpick*)
  oops

end

locale liberation_kleene_lattice = liberation_kleene_lattice_zerol lib for lib +
  constrains lib :: "'a \<Rightarrow> 'b::kleene_lattice"

text \<open>Finally we formalise liberation action lattices. Ultimately this locale should be intergrated
whith the residuated lattice components in the AFP.\<close>

locale liberation_action_lattice_zerol =
  fixes li :: "'a \<Rightarrow> 'b::action_lattice_zerol"
  assumes li1 [simp]: "li i \<cdot> 0 = 0"
  and li2: "1 \<le> li i"
  and li3: "li i \<cdot> (x \<sqinter> ((li i) \<cdot> y)) = ((li i) \<cdot> x) \<sqinter> ((li i) \<cdot> y)"
  and li4: "(x \<sqinter> (y \<cdot> li i)) \<cdot> li i = (x \<cdot> li i) \<sqinter> (y \<cdot> li i)"
  and li5: "(li i) \<cdot> (li j) = (li j) \<cdot> (li i)"
  and li6: "i \<noteq> j \<Longrightarrow> (li i) \<sqinter> (li j) = 1"
  and li7: "li i \<cdot> (li j \<sqinter> li k) = (li i \<cdot> li j) \<sqinter> (li i \<cdot> li k)"
  and li8: "(li i \<sqinter> li j) \<cdot> li k = (li i \<cdot> li k) \<sqinter> (li j \<cdot> li k)"
  and li9: "bres (li i) 1 = 0"
  and i10: "fres 1 (li i) = 0"

begin

abbreviation "cyl i x \<equiv> li i \<cdot> x \<cdot> li i"

abbreviation "dcyl i x \<equiv> bres (li i) (fres x (li i))"

lemma bres_fres_comm: "(bres x (fres y z)) = (fres (bres x y) z)"
  apply (rule antisym)
  by (metis (no_types, lifting) bres_adj dual_order.refl fres_adj mult.assoc)+

lemma li_bres_adj: "(li i \<cdot> x \<le> y) = (x \<le> bres (li i) y)"
  by (simp add: bres_adj)

lemma li_fres_asj: "(x \<cdot> li i \<le> y) = (x \<le> fres y (li i))"
  by (simp add: fres_adj)

lemma bres_prop: "bres (li i) x \<le> li i \<cdot> x"
  by (metis (no_types, hide_lams) bres_adj dual_order.trans li2 mult_isor mult_onel order_refl)

lemma fres_prop: "fres x (li i) \<le> x \<cdot> li i"
  by (metis (no_types, hide_lams) dual_order.trans fres_adj li2 mult_isol mult_oner order_refl)

lemma li_bres_swap: "(x \<le> bres (li i) y) \<Longrightarrow> (bres (li i) x \<le> y)"
  by (meson bres_adj bres_prop order.trans)

lemma li_fres_swap: "(x \<le> fres y (li i)) \<Longrightarrow> (fres x (li i) \<le> y)"
  by (meson dual_order.trans fres_adj fres_prop)

lemma li_bres_canc1: "(li i) \<cdot> (bres (li i) x) \<le> x"
  by (simp add: bres_adj)

lemma li_bres_canc2: "x \<le> bres (li i) ((li i) \<cdot> x)"
  using bres_adj by auto

lemma li_fres_canc1: "(fres x (li i)) \<cdot> li i \<le> x"
  by (simp add: fres_adj)

lemma li_fres_canc2: "x \<le> (fres (x \<cdot> (li i)) (li i))"
  using fres_adj by blast

lemma li_bres_prop [simp]: "(li i) \<cdot> (bres (li i) x) = bres (li i) x"
  by (smt antisym bres_prop inf.absorb_iff2 li2 li3 li_bres_adj li_bres_canc1 li_bres_canc2 mult.assoc mult_onel mult_oner order.trans phl_cons2 phl_skip)

lemma bres_li_prop [simp]: "bres (li i) (li i \<cdot> x) = li i \<cdot> x"
  by (metis antisym li_bres_canc1 li_bres_canc2 li_bres_prop mult_isol)

lemma li_fres_prop [simp]: "(fres x (li i)) \<cdot> li i = fres x (li i)"
  by (smt fres_adj fres_prop inf.absorb_iff2 inf_commute li4 li_fres_canc1)

lemma fres_li_prop [simp]: "fres (x \<cdot> li i) (li i) = x \<cdot> li i"
  by (metis antisym li_fres_canc1 li_fres_canc2 li_fres_prop mult_isor)

lemma bres_bres_li [simp]: "bres (li i) (bres (li i) x) = bres (li i) x"
  by (metis bres_li_prop li_bres_prop)

lemma fres_fres_li [simp]: "fres (fres x (li i)) (li i) = fres x (li i)"
  by (metis fres_li_prop li_fres_prop)

lemma bres_li_defl: "bres (li i) x \<le> x"
  using li_bres_canc1 li_bres_prop by auto

lemma fres_li_defl: "fres x (li i) \<le> x"
  using li_fres_canc1 li_fres_prop by auto

lemma bres_li_zero [simp]: "bres (li i) 0 = 0"
  by (metis bres_li_prop li1)

lemma fres_li_zero [simp]: "fres 0 (li i) = 0"
  by (simp add: fres_li_defl join.bot.extremum_uniqueI)

lemma bres_iso: "x \<le> y \<Longrightarrow> bres z x \<le> bres z y"
  by (meson bres_adj dual_order.refl order.trans)

lemma fres_iso: "x \<le> y \<Longrightarrow> fres x z \<le> fres y z"
  using dual_order.trans fres_adj by blast

lemma cyl_idem [simp]: "cyl i (cyl i x) = cyl i x"
  by (metis bres_li_prop fres_li_prop li_bres_prop li_fres_prop mult.assoc)

lemma dcyl_idem: "dcyl i (dcyl i x) = dcyl i x"
  by (simp add: bres_fres_comm)

lemma cyl_dcyl [simp]: "cyl i (dcyl i x) = dcyl i x"
  by (metis bres_fres_comm li_bres_prop li_fres_prop)

lemma dyl_cyl [simp]: "dcyl i (cyl i x) = cyl i x"
  by (metis bres_li_prop fres_li_prop mult.assoc)

lemma cyl_dcyl_adj: "(cyl i x \<le> y) = (x \<le> dcyl i y)"
  using bres_adj fres_adj by blast

lemma dcyl_defl: "dcyl i x \<le> x"
  using bres_li_defl fres_li_defl order.trans by blast

lemma dcyl_le_cyl: "dcyl i x \<le> cyl i x"
  by (metis cyl_dcyl_adj fres_li_defl fres_li_prop li_bres_swap mult_double_iso)

lemma dcyl_ij_comm: "dcyl i (dcyl j x) = dcyl j (dcyl i x)"
  apply (rule antisym)
  by (smt li5 liberation_action_lattice_zerol.cyl_dcyl liberation_action_lattice_zerol.cyl_dcyl_adj liberation_action_lattice_zerol.dcyl_defl liberation_action_lattice_zerol_axioms mult.assoc)+

lemma cyl_dcyl_swap: "cyl i (dcyl j x) \<le> dcyl j (cyl i x)"
  by (metis bres_adj bres_iso cyl_dcyl_adj dcyl_ij_comm fres_iso li_fres_canc2)

lemma dcyl_zero [simp]: "dcyl i 1 = 0"
  by (simp add:  i10)

lemma dcyl_add: "dcyl i (x + dcyl i y) = dcyl i x + dcyl i y"
  (*nitpick*)
  oops

lemma dcyl_kplus: "(dcyl i x)\<^sup>\<oplus> \<le> dcyl i (x\<^sup>\<oplus>)"
  by (smt cyl_dcyl cyl_dcyl_adj dcyl_defl kplus_def kplus_star_opp li_bres_prop mult.assoc mult_isol_var star_iso)

lemma dcyl_kplus_prop [simp]: "dcyl i ((dcyl i x)\<^sup>\<oplus>) = (dcyl i x)\<^sup>\<oplus>"
  by (metis antisym dcyl_defl dcyl_idem dcyl_kplus)

end

end


(* Author:     Tobias Nipkow
*)

header{* Tame Properties *}

theory TameProps
imports Tame RTranCl
begin

lemma length_disj_filter_le: "\<forall>x \<in> set xs. \<not>(P x \<and> Q x) \<Longrightarrow>
 length(filter P xs) + length(filter Q xs) \<le> length xs"
by(induct xs) auto

lemma tri_quad_le_degree: "tri g v + quad g v \<le> degree g v"
proof -
  let ?fins = "[f \<leftarrow> facesAt g v . final f]"
  have "tri g v + quad g v =
        |[f \<leftarrow> ?fins . triangle f]| + |[f \<leftarrow> ?fins. |vertices f| = 4]|"
    by(simp add:tri_def quad_def)
  also have "\<dots> \<le> |[f \<leftarrow> facesAt g v. final f]|"
    by(rule length_disj_filter_le) simp
  also have "\<dots> \<le> |facesAt g v|" by(rule length_filter_le)
  finally show ?thesis by(simp add:degree_def)
qed

lemma faceCountMax_bound:
 "\<lbrakk> tame g; v \<in> \<V> g \<rbrakk> \<Longrightarrow> tri g v + quad g v \<le> 7"
using tri_quad_le_degree[of g v]
by(auto simp:tame_def tame11b_def split:split_if_asm)

lemma filter_tame_succs:
assumes invP: "invariant P succs" and fin: "!!g. final g \<Longrightarrow> succs g = []"
and ok_untame: "!!g. P g \<Longrightarrow> \<not> ok g \<Longrightarrow> final g \<and> \<not> tame g"
and gg': "g [succs]\<rightarrow>* g'"
shows "P g \<Longrightarrow> final g' \<Longrightarrow> tame g' \<Longrightarrow> g [filter ok o succs]\<rightarrow>* g'"
using gg'
proof (induct rule:RTranCl.induct)
  case refl show ?case by(rule RTranCl.refl)
next
  case (succs h h' h'')
  hence "P h'"  using invP by(unfold invariant_def) blast
  show ?case
  proof cases
    assume "ok h'"
    thus ?thesis using succs `P h'` by(fastforce intro:RTranCl.succs)
  next
    assume "\<not> ok h'" note fin_tame = ok_untame[OF `P h'` `\<not> ok h'`]
    have "h'' = h'" using fin_tame
      by(rule_tac RTranCl.cases[OF succs(2)])(auto simp:fin)
    hence False using fin_tame succs by fast
    thus ?case ..
  qed
qed

definition untame :: "(graph \<Rightarrow> bool) \<Rightarrow> bool" where
"untame P \<equiv> \<forall>g. final g \<and> P g \<longrightarrow> \<not> tame g"

lemma filterout_untame_succs:
assumes invP: "invariant P f" and invPU: "invariant (%g. P g \<and>  U g) f"
and untame: "untame(%g. P g \<and> U g)"
and new_untame: "!!g g'. \<lbrakk> P g; g' \<in> set(f g); g' \<notin> set(f' g) \<rbrakk> \<Longrightarrow> U g'"
and gg': "g [f]\<rightarrow>* g'"
shows "P g \<Longrightarrow> final g' \<Longrightarrow> tame g' \<Longrightarrow> g [f']\<rightarrow>* g'"
using gg'
proof (induct rule:RTranCl.induct)
  case refl show ?case by(rule RTranCl.refl)
next
  case (succs h h' h'')
  hence Ph': "P h'"  using invP by(unfold invariant_def) blast
  show ?case
  proof cases
    assume "h' \<in> set(f' h)"
    thus ?thesis using succs Ph' by(blast intro:RTranCl.succs)
  next
    assume "h' \<notin> set(f' h)"
    with succs(4) succs(1) have "U h'" by (rule new_untame)
    hence False using Ph' RTranCl_inv[OF invPU] untame succs
      by (unfold untame_def) fast
    thus ?case ..
  qed
qed

end


text \<open> Version 0.5, last changed 2019-02-01
  (C) fovefi ltd, www.fovefi.co
  (author: Manfred Kerber [make@fovefi.co] based on Percentile_Code.thy in foveSIMM by Lukas Bulwahn)

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In the following, an executable definition of the percentile function is given that is
  close to the one used in OpenSIMM, a system with a standard implementation for the computation
  of risk. Here, the percentile function is extended so that it is defined on the complete interval [0,1].
  The extension is done by taking a constant slope at the ends of the interval. To this end the original
  implementation was adjusted.
  \<close>

theory Percentile_Code
  imports Percentile
begin

section \<open>Code Generation of Percentile\<close>
paragraph \<open>The percentile definition close to the Java implementation\<close>

text \<open> In the Java code follows a check that the level is below 1 - 1/(2*size).
 * If not, it throws an exception. In the Isabelle implementation (there is no exception
 * handling in Isabelle), the code is underspecified, that is, no specific values will be
 * returned for larger values. This will be fixed in the definition of the percentile function
 * in the next section.
 \<close>

text \<open> An integer greater equal 0 considered as a real number is the same as the integer first considered
       as a natural number and this then considered as a real number. \<close>
lemma real_of_int:
  assumes "0 \<le> i"
  shows "real_of_int i = real (nat i)"
by (simp add: assms)

text \<open> The value of the minimum of the domain of equidistant point is determined. \<close>
lemma Min_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x"
  assumes "x \<le> 1 - 1 / (2 * length ys)"
  shows "Min {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'} = (ceiling (length ys * x - 0.5) + 0.5) / length ys"
  (is "Min ?A = ?expr")
proof (rule Min_eqI)
  text \<open>let ?A = "{x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'}"\<close>
  show "finite ?A" by simp
  show "?expr \<le> y" if "y \<in> ?A" for y
  proof -
    from that \<open>ys \<noteq> []\<close> obtain n where "y = (real n + 1 / 2) / real (length ys)" and "x \<le> y"
      unfolding equidistant_points_on_unit_interval_of_def
      apply auto done
    obtain i where "i = int n" by auto
    from this \<open>y = _\<close> have y: "y = (real_of_int i + 1 / 2) / real (length ys)"
      by simp
    have "i \<ge> ceiling (length ys * x - 0.5)"
    proof -
      have "x \<le> (real_of_int i + 1 / 2) / real (length ys)"
        using \<open>x \<le> y\<close> y by blast
      from this have "length ys * x \<le> (real_of_int i + 1 / 2)"
        apply -
        apply (frule mult_left_mono[where c="real (length ys)"])
         apply simp
        by (simp add: assms(1))
        find_theorems "_ * _ \<le> _ * _"
      from this have "length ys * x - 1 / 2 \<le> real_of_int i" by linarith
      from this show ?thesis
        by (simp add: ceiling_le)
    qed
    from this y have "y \<ge> (real_of_int (ceiling (length ys * x - 0.5)) + 1 / 2) / real (length ys)"
      apply simp
      find_theorems "_ / _ \<le> _ / _"
      apply (rule divide_right_mono)
      apply simp
      apply simp
      done
    from this show ?thesis by simp
  qed
  show "?expr \<in> ?A"
  proof -
    from assms have "0 \<le> real (length ys) * x - 1 / 2"
      apply auto
      by (simp add: Groups.mult_ac(2) divide_less_eq)
    from this have "0 \<le> \<lceil>real (length ys) * x - 1 / 2\<rceil>" by simp
    from this have a: "real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> = real (nat \<lceil>real (length ys) * x - 1 / 2\<rceil>)"
      by simp
    have b: "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<in> {0..<length ys}"
    proof -
      have "real (length ys) * x - 1 / 2 \<le> (length ys - 1)"
      proof -
        have "real (length ys) * x - 1 / 2 \<le> real (length ys) * (1 - 1 / real (2 * length ys)) - 1 / 2"
          using assms(1, 3) by simp
        also have "\<dots> = real (length ys) - 1"
          apply auto
          apply (subst right_diff_distrib)
          apply simp
          by (simp add: assms(1))
        also have "\<dots> = real (length ys - 1)"
          by (metis One_nat_def Suc_pred assms(1) diff_Suc_Suc diff_is_0_eq length_greater_0_conv of_nat_1 of_nat_diff zero_diff)
        finally show ?thesis .
      qed
      text \<open>have "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 0" s_orry\<close>
      from this have a: "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<le> \<lceil>real (length ys - 1)\<rceil>"
        using ceiling_mono by blast
      have "\<lceil>real (length ys - 1)\<rceil> = int (length ys - 1)" by simp
      from a this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> < length ys"
        by (smt assms(1) int_nat_eq length_greater_0_conv nat_less_le of_nat_0_less_iff of_nat_1 of_nat_diff of_nat_less_imp_less zero_less_diff)
      from this show ?thesis
        apply auto done
    qed
    have "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)
      \<in> dom (equidistant_points_on_unit_interval_of ys)"
      unfolding dom_equidistant_points_on_unit_interval_of
      apply auto
      apply (subst a)
      apply (rule image_eqI)
       apply (rule refl)
      apply (rule b) done
      find_theorems "dom (equidistant_points_on_unit_interval_of _)"
    moreover have "x \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
    proof -
      have "real (length ys) > 0" (* only need \<ge> *)
        by (simp add: assms)
      have a: "real (length ys) * x - 5 / 10 \<le> real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil>"
        by linarith
      have "x \<le> ((real (length ys) * x - 5 / 10) + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> by auto
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> a
        apply -
        apply (rule divide_right_mono)
        apply linarith
        apply simp done
      finally show ?thesis .
    qed
    ultimately show ?thesis by auto
  qed
qed

text \<open> A property of the ceiling function. \<close>
lemma ceiling_minus_leq:
  assumes "a + b \<ge> 1"
  shows "real_of_int \<lceil>x - a\<rceil> - b \<le> x"
using assms by linarith

text \<open> Relationship between floor and ceiling (floor plus 1 is less equal ceiling). \<close>
lemma floor_leq_ceiling:
  fixes x :: real
  assumes "x \<notin> real_of_int ` UNIV"
  shows "1 + real_of_int (floor x) \<le> real_of_int (ceiling x)"
using assms by (smt UNIV_I ceiling_correct image_eqI int_less_real_le le_floor_iff)

text \<open> If i < y for two integers then i \<le> y - 1 (when converted to real).\<close>
lemma less_to_leq:
  fixes y :: real
  assumes "real i < y"
  assumes "y \<in> real_of_int ` UNIV"
  shows "real i \<le> y - 1"
proof -
  from assms(2) obtain j where "y = real_of_int j"
    apply auto done
  obtain k where "j = int k"
    by (smt \<open>y = real_of_int j\<close> assms(1) int_less_real_le nat_0_le of_int_1 of_nat_0_le_iff)
  from this \<open>y = _\<close> assms(1) show ?thesis by auto
qed

text \<open> The value of the maximum of the domain of equidistant point is determined. \<close>
lemma Max_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x" "x \<le> 1 - 1 / (2 * length ys)"
  shows "Max {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x' < x} = (ceiling (length ys * x - 0.5) - 0.5) / length ys"
    (is "_ = ?expr")
proof -
  let ?A = "{x' \<in> (\<lambda>x. (1 / length ys) * (x + 0.5)) ` {0..<length ys}. x' < x}"
  have "Max ?A = ?expr"
  find_theorems "_ ` _" "Max"
  proof (rule Max_eqI)
    show "finite ?A" by simp
    show "y \<le> ?expr" if "y \<in> ?A" for y
    proof -
      show ?thesis
      proof (cases "real (length ys) * x - 1 / 2 \<in> range real_of_int")
        case True
          from that obtain i where "i \<in> {0..<length ys}"
            and y: "y = 1 / real (length ys) * (real i + 5 / 10)" and "y < x" by auto
          have "(real i + 5 / 10) < real (length ys) * x"
            by (metis \<open>y < x\<close> assms(1) divide_less_eq length_greater_0_conv mult.commute mult_numeral_1 numeral_One of_nat_0_less_iff times_divide_eq_right y)
          from this have "real i < real (length ys) * x - 0.5"
            by linarith
          from this have "real i \<le> real (length ys) * x - 1.5"
            apply -
            apply (frule less_to_leq)
            apply (simp add: True)
            by linarith
          from this have "(real i + 5 / 10) \<le> real (length ys) * x - 1"
            apply simp done
          have "1 / real (length ys) > 0" by (simp add: assms(1))
          from this assms y have y2: "y \<le> 1 / real (length ys) * (real (length ys) * x - 1)"
            using \<open>real i + 5 / 10 \<le> real (length ys) * x - 1\<close> real_mult_le_cancel_iff2 by blast
          have "real (length ys) * x - 1 / 2 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil>"
            by simp
          from this have "real (length ys) * x - 1 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
          proof -
            have "real (length ys) * x - 1 = (real (length ys) * x - 1 / 2) - 1 / 2" by simp
            also have "\<dots> \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
              by linarith
            finally show ?thesis .
          qed
        from this y2 show ?thesis
          apply auto
          find_theorems "?a \<le> ?b \<Longrightarrow> ?b \<le> ?c \<Longrightarrow> ?a \<le> ?c"
          apply (rule order.trans)
          apply assumption
          apply (rule divide_right_mono)
          apply simp apply simp done
          find_theorems "_ / _ \<le> _ / _"
      next
        case False
        then show ?thesis
        proof -
          have "y \<le> 1 / real (length ys) * (real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10)"
          proof -
            from that obtain i where "i \<in> {0..<length ys}"
              and "y = 1 / real (length ys) * (real i + 5 / 10)" and "y \<le> x" by auto
            have "i \<le> \<lfloor>real (length ys) * x - 5 / 10\<rfloor>"
        proof -
          have a: "1 / real (length ys) * (real i + 5 / 10) \<le> x"
            using \<open>y = _\<close> \<open>y \<le> x\<close> by blast
          have "(real i + 5 / 10) \<le> real (length ys) * x"
          proof -
            have "(real i + 5 / 10) = real (length ys) * (1 / real (length ys) * (real i + 5 / 10))"
              by (simp add: assms(1))
            also have "\<dots> \<le> real (length ys) * x"
              using a mult_left_mono of_nat_0_le_iff by blast
            finally show ?thesis .
          qed
          from this have "real i \<le> real (length ys) * x - 5 / 10" by linarith
          from this show ?thesis by linarith
        qed
        from this \<open>y = _\<close> show ?thesis
        proof -
          have "real (length ys) > 0" by (simp add: assms(1))
          from \<open>i \<le> floor _\<close> have "(real i + 5 / 10) \<le> real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10"
            by linarith
          from this \<open>y = _\<close> \<open>real (length ys) > 0\<close> show ?thesis
            using real_mult_le_cancel_iff2 by fastforce
        qed
      qed
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys)"
      proof -
        from False
        have "(real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10) \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10)"
          apply simp
          apply (rule floor_leq_ceiling)
          apply assumption
          done
        from this show ?thesis
          apply simp
          apply (rule divide_right_mono)
           apply simp apply simp done
      qed
      finally show ?thesis .
    qed
    qed qed
    show "?expr \<in> ?A"
    proof -
      have "?expr \<in> (\<lambda>x. 1 / real (length ys) * (real x + 5 / 10)) ` {0..<length ys}"
      proof
        have "real (length ys) * x - 1 / 2 > 0"
          by (metis assms(1) assms(2) diff_gt_0_iff_gt divide_divide_eq_left divide_less_eq length_greater_0_conv mult.commute of_nat_0_less_iff of_nat_mult of_nat_numeral)
        from this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 1"
          by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) =
          1 / real (length ys) * (real (nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1) + 5 / 10)"
          using \<open>ys \<noteq> []\<close>
          apply auto done
        have "real (length ys) \<ge> 0" by auto
        have "x \<le> 1"
          by (smt assms(3) divide_less_0_1_iff of_nat_0_le_iff)
        from this have "real (length ys) * x \<le> length ys"
          by (simp add: mult_left_le)
        from this \<open>real (length ys) \<ge> 0\<close> have "real (length ys) * x \<le> length ys + 1 / 2"
          by linarith
        from this have "real (length ys) * x - 1 / 2 \<le> length ys"
          by fastforce
        from this show "nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1 \<in> {0..<length ys}"
          apply auto
          using \<open>1 \<le> nat \<lceil>real (length ys) * x - 1 / 2\<rceil>\<close> by linarith
      qed
      moreover have "?expr < x"
      proof -
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < real (length ys) * x + 5 / 10"
          by linarith
        then have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10"
          by (simp add: mult.commute)
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10 < x * real (length ys)"
          using \<open>real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10\<close> by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) < x"
          apply auto
          by (simp add: assms(1) divide_less_eq)
      qed
      ultimately show ?thesis by auto
    qed
  qed
  from this show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def by simp
qed

text \<open> The lemma determines the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth2:
  fixes i :: int
  assumes "0 \<le> i" "nat i < length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i + 5 / 10) / size ys)) = ys ! (nat i)"
proof -
  let ?xs = "map (\<lambda>x. (real x + 1 / 2) / real (length ys)) [0..<length ys]"
  have "distinct ?xs" by (auto intro!: inj_onI simp add: distinct_map)
  have eq: "(real_of_int i + 1 / 2) / real (length ys) = ?xs ! nat i"
    using assms by auto
  show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def
    apply simp
    apply (subst eq)
    thm map_of_zip_nth
    apply (subst map_of_zip_nth)
       apply simp
      apply (rule \<open>distinct ?xs\<close>)
     apply (rule assms)
    apply simp done
qed

text \<open> The lemma gives an alternative characterization of the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth1:
  fixes i :: int
  assumes "1 \<le> i" "i \<le> length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i - 5 / 10) / size ys)) = ys ! nat (i - 1)"
proof -
  (* todo: size ys = real (length ys); which is better to write down? *)
  let ?f = "\<lambda>x. the (equidistant_points_on_unit_interval_of ys (x / size ys))"
  have "?f (real_of_int i - 5 / 10) = ?f (real_of_int (i - 1) + 5 / 10)" by force
  also have "\<dots> = ys ! nat (i - 1)"
    using assms by (simp only: equidistant_points_on_unit_interval_of_eq_nth2)
  finally show ?thesis .
qed

text \<open> The definition contains executable version of the percentile function which is close to the
       Java implementation in the OpenSIMM implementation. \<close>
definition percentile_impl_inner :: "real list \<Rightarrow> real \<Rightarrow> real"
where
  "percentile_impl_inner values level =
    (let  (size :: real) = (real (length values));
           (sorted :: (real list)) = sort values;
           i = (ceiling (size * level - 0.5));
           (lower :: real) = (i - 0.5) / size;
           (upper ::real) = (i + 0.5) / size;
           \<comment>\<open>Note that we convert i to a nat since we want to use it
              as an index in a list. This means that we automatically
              have values greater equal 0\<close>
           (lower_value :: real)  = sorted ! (nat (i-1));
           (upper_value :: real)  = sorted ! (nat i)
    in lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower))"

definition percentile_impl :: "(real list) \<Rightarrow> real \<Rightarrow> real" where
  "percentile_impl values level =
    (let (size :: nat) = (length values);
         (sorted :: real list) = sort values
      in
    (if (0 \<le> level \<and> level < 1/(2 *size))
       then (linear (0, (extrapolation_0 sorted)) (1/(2*size), sorted!0)) level
       else (if (1 - 1/(2 *size) < level \<and> level \<le> 1)
             then (linear (1 - 1/(2 *size), sorted!(size - 1)) (1, (extrapolation_1 sorted))) level
             else percentile_impl_inner sorted level)))"

text \<open> The theorem states the equivalence of the abstract definition of the percentile function from
       the Percentile theory and the computational version in the standard interval. \<close>
theorem percentile_inner_java_equiv:
  assumes "sorted values"
  assumes "length values > 1"
  assumes "1 / (2 * length values) < level" (* todo: lesseq instead of less *)
  assumes "level \<le> 1 - 1 / (2 * length values)"
  shows "Percentile.percentile values level = percentile_impl_inner values level"
proof -
  have non_empty: "values \<noteq> []" using assms(2) by auto
  have Percentile_inner_equ: "Percentile.percentile values level = Percentile.percentile_inner values level"
    using percentile_alt1 using assms by simp
  from assms(3) have "level \<noteq> 1 / real (2 * length values)" by blast
  let ?def = "(let p = equidistant_points_on_unit_interval_of (sort values);
         (x1, x2) = (Max {x' \<in> dom p. x' < level}, Min {x' \<in> dom p. level \<le> x'});
         (y1, y2) = (the (p x1), the (p x2))
     in linear (x1, y1) (x2, y2) level)"
  {
    fix size sorted i lower upper lower_value upper_value
    assume "size = real (length values)"
    assume "sorted = sort values"
    assume "i = \<lceil>size * level - 5 / 10\<rceil>"
    assume "lower = (real_of_int i - 5 / 10) / size"
    assume "upper = (real_of_int i + 5 / 10) / size"
    assume "lower_value = sorted ! nat (i - 1)"
    assume "upper_value = sorted ! nat i"
    have "length values = length sorted" and "sorted \<noteq> []" (* is this noteq Nil fact needed? *) and
          "length sorted > 0"
      using \<open>sorted = _\<close> \<open>_ \<noteq> []\<close> apply auto
      by (metis length_0_conv length_sort) (* todo: find a better lemma *)
    have "lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower) =
      linear (lower, lower_value) (upper, upper_value) level"
      apply (subst linear_eq[symmetric]) ..
    also have "\<dots> = ?def"
    proof -
      have b1: "0 \<le> \<lceil>real (length sorted) * level - 5 / 10\<rceil>"
      proof -
        have "- 1 / 2 \<le> real (length sorted) * level - 5 / 10"
          apply simp
          by (meson assms(3) le_less_trans less_eq_real_def of_nat_0_le_iff zero_le_divide_1_iff zero_le_mult_iff)
          (* strange proof? *)
        from this show ?thesis by linarith
      qed
      have b2: "nat \<lceil>real (length sorted) * level - 5 / 10\<rceil> < length sorted"
      proof -
        have "real (length sorted) * level \<le> real (length sorted) - 1 / 2"
        proof -
          from assms(4) have "level \<le> 1 - 1 / real (2 * length sorted)"
            using \<open>length values = length sorted\<close> by simp
          from this have "real (length sorted) * level \<le> real (length sorted) * (1 - 1 / real (2 * length sorted))"
            using \<open>0 < length sorted\<close> by auto
          also have "\<dots> = real (length sorted) - 1 / 2"
            apply simp
            by (metis \<open>length values = length sorted\<close> \<open>size = real (length values)\<close> non_empty
                      length_0_conv mult.commute mult.right_neutral mult_cancel_left
                      nonzero_mult_divide_mult_cancel_left of_nat_eq_iff of_nat_mult
                      right_diff_distrib' times_divide_eq_right)
          finally show ?thesis .
        qed
        from this show ?thesis
          using b1 by linarith
      qed
      have b3: "1 \<le> \<lceil>real (length sorted) * level - 5 / 10\<rceil>"
      proof -
        show ?thesis
          using assms(3) \<open>length _ = _\<close> \<open>length sorted > 0\<close>
          by (simp add: Groups.mult_ac(2) divide_less_eq)
      qed
      from b2 have b4: "\<lceil>real (length sorted) * level - 5 / 10\<rceil> \<le> int (length sorted)" by simp
      have "Max {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). x' < level} = lower"
        using \<open>lower = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Max_equidistant_points_on_unit_interval_of_bounded)
           prefer 4
           apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(3) apply auto[1]
        using assms(4) by auto
      moreover have "Min {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). level \<le> x'} = upper"
        using \<open>upper = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Min_equidistant_points_on_unit_interval_of_bounded)
         prefer 4
         apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(3) apply auto[1]
        using assms(4) by auto
      moreover have "the (equidistant_points_on_unit_interval_of sorted lower) = lower_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>lower_value = _\<close> \<open>lower = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth1)
        apply (rule b3)
        apply (rule b4)
        apply simp
        done
      moreover have "the (equidistant_points_on_unit_interval_of sorted upper) = upper_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>upper_value = _\<close> \<open>upper = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth2)
        apply (rule b1)
        apply (rule b2)
        apply simp done
      ultimately show ?thesis
        using \<open>sorted = _\<close> by simp
    qed
    finally have "lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower) =
       ?def" by simp (* intermediate proof step not needed? change proof structure? *)
  }
  from this \<open>level \<noteq> _\<close> show ?thesis using percentile_inner_alternative_pseudo_def percentile_impl_inner_def
       Percentile_inner_equ
    by (simp add: percentile_inner_alternative_pseudo_def percentile_impl_inner_def)
qed

theorem percentile_java_equiv_left:
  assumes "length values > 1"
  assumes "sorted values"
  assumes "1 / real (2 * length values) = level"
  shows "Percentile.percentile values level = percentile_impl values level"
proof -
  have "(length values) * level = 1/2" using assms by auto
  then have ceil: "ceiling ((length values) * level - 0.5) = 0" using ceiling_def
    by (simp add: \<open>real (length values) * level = 1 / 2\<close>)
  have "(sort values)!0 = (sort values)!(nat (0-1))"  by simp
  have "2 * length values \<ge> 4"
    using assms(1) by linarith
  then have "1/(2 * length values) \<le> 1/4"
    using inverse_of_nat_le by fastforce
  then have "1/(2*length values) < 1 - 1/(2 *length values)"
    by linarith
  then have "percentile_impl values level = percentile_impl_inner values level" using assms percentile_impl_def
    by (simp add: sorted_sort_id)
  then have "percentile_impl values level = (sort values)!0"
    using ceil percentile_impl_inner_def by auto
  then have "percentile_impl_inner values level = (sort values)!0" using ceil
    by (simp add: percentile_impl_inner_def)
  have "length values = length (sort values)" by simp
  have left_most: "(\<lambda>x. (1 / length values) * (x + 0.5)) 0 = level"
    using \<open>real (length values) * level = 1 / 2\<close> add_divide_distrib eq_divide_eq_1 mult_cancel_right1
          nonzero_mult_div_cancel_left times_divide_eq_left assms by auto
  have "level = ((map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values]))!0"
    using assms left_most
    by (smt add.left_neutral diff_zero gr0I not_less_zero nth_map_upt of_nat_0)
  then have "level \<in> set (map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values])"
    using assms(1)
    by (metis gr_implies_not0 length_map length_upt neq0_conv nth_mem zero_less_diff)
  then have "level \<in> set (map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values])"
       using left_most by blast
  then have "level \<in> dom (equidistant_points_on_unit_interval_of (sort values))"
    using equidistant_points_on_unit_interval_of_def
    by simp
  then have "neighbors (equidistant_points_on_unit_interval_of (sort values)) level = (level, level)"
    using defined_point_neighbors_eq finite_equidistant_points_on_unit_interval_of by blast
  then have val_0: "linear_approximation (equidistant_points_on_unit_interval_of (sort values)) level = (sort values)!0"
    using one_point_interpolation \<open>length values = length (sort values)\<close>
         \<open>level \<in> dom (equidistant_points_on_unit_interval_of (sort values))\<close> assms(1)
         equidistant_points_on_unit_interval_of_eq_nth2 finite_equidistant_points_on_unit_interval_of
         left_most length_greater_0_conv mult_cancel_right1 nat_zero_as_int of_nat_eq_0_iff
         real_of_int times_divide_eq_left
  proof -
    have f1: "(0::int) \<le> 0"
      by auto
  have f3: "length values \<noteq> 0 \<longrightarrow> (5 / 10 + real_of_int 0) / (of_nat_1 (length (sort values))) = 1 * (5 / 10) / (if length values = 0 then 0 else of_nat_1 (length values))"
    by auto
  have f4: "1 / (if length values = 0 then 0 else (length values)) * (5 / 10) = level"
    using left_most by auto
  have "\<forall>x1. real_of_int x1 + 5 / 10 = 5 / 10 + real_of_int x1"
    by auto
  then have "length values \<noteq> 0 \<longrightarrow> linear_approximation (equidistant_points_on_unit_interval_of (sort values)) level = sort values ! 0"
    using f4 f3 f1 \<open>\<And>c b a. b / c * a = b * a / c\<close> \<open>length values = length (sort values)\<close>
         \<open>level \<in> dom (equidistant_points_on_unit_interval_of (sort values))\<close> assms
         equidistant_points_on_unit_interval_of_eq_nth2 finite_equidistant_points_on_unit_interval_of
         length_greater_0_conv nat_zero_as_int one_point_interpolation
         divide_inverse_commute divide_numeral_1 inverse_divide of_int_0
    by (smt length_0_conv)
  then show ?thesis using assms(1) by linarith
qed
  then have "Percentile.percentile values level = Percentile.percentile_inner values level"
    using percentile_alt1[of "values" "level"]  assms
    by (smt Max_equidistant_points_on_unit_interval_of Max_ge
       \<open>level \<in> dom (equidistant_points_on_unit_interval_of (sort values))\<close>
       finite_equidistant_points_on_unit_interval_of le_less_trans le_numeral_extra(1)
        length_greater_0_conv sorted_sort_id)
  then have "Percentile.percentile values level = (sort values)!0" using linear_approximation_def
    using one_point_interpolation percentile_alt1 using val_0
    by (simp add: percentile_inner_def)
  then show ?thesis
    by (simp add: \<open>percentile_impl values level = percentile_impl_inner values level\<close>
       \<open>percentile_impl_inner values level = sort values ! 0\<close>)

qed

theorem percentile_java_equiv:
  assumes "sorted values"
  assumes "length values > 1"
  assumes "0 \<le> level \<and> level \<le> 1"
  shows "Percentile.percentile values level = percentile_impl values level"
proof -
  have l1: "0 \<le> level \<and> level < 1/(2* (length values)) \<longrightarrow>
       Percentile.percentile values level =
         (linear (0, extrapolation_0 values) (1/(2* (length values)), values!0)) level"
       using assms(1) assms(2) percentile_alt2 by blast
  have "0 \<le> level \<and> level < 1/(2* (length values)) \<longrightarrow>
       percentile_impl values level =
      (linear (0, (extrapolation_0 values)) (1/(2* (length values)), values!0)) level"
    using percentile_impl_def by (simp add: assms(1) sorted_sort_id)
  then have low: "0 \<le> level \<and> level < 1/(2* (length values)) \<longrightarrow> ?thesis" using l1 by auto

  have w: "1/(2* length values) < level \<and> level \<le> 1 - 1/(2* length values) \<longrightarrow>
           1/(2* length values) \<le> level \<and> level \<le> 1 - 1/(2* length values)" by auto
  have l2: "1/(2* length values) < level \<and> level \<le> 1 - 1/(2* length values) \<longrightarrow>
            Percentile.percentile values level = percentile_impl_inner values level"
    using percentile_inner_java_equiv[of "values" "level"] using assms(1) assms(2)
    by blast
  have  "1/(2* length values) < level \<and> level \<le> 1 - 1/(2* length values) \<longrightarrow>
      percentile_impl values level = percentile_impl_inner values level"
    using assms percentile_impl_def by (simp add: sorted_sort_id)
    then have mid: "1/(2* length values) < level \<and> level \<le> 1 - 1/(2* length values) \<longrightarrow> ?thesis"
      using l2 percentile_inner_java_equiv by simp

  have l3: "1 - 1/(2 * (length values)) < level \<and> level \<le> 1 \<longrightarrow>
       Percentile.percentile values level =
         (linear (1-1/(2* (length values)), values!(length values -1)) (1, extrapolation_1 values)) level"
    using assms(1) assms(2) percentile_alt3 by blast
  have "2 \<le> length values" using assms(2) by linarith
  then have quarter: "1/(2*(length values)) \<le> 1/4"
    using inverse_of_nat_le by fastforce
  then have "3/4 \<le> 1 - 1/(2*(length values))"
    using inverse_of_nat_le by fastforce
  then have "1/(2 * (length values)) < 1 - 1/(2 * (length values))" by linarith

  then have "1 - 1/(2 * (length values)) < level \<and> level \<le> 1 \<longrightarrow> \<not> ( level \<le> 1/(2 * (length values)))"
    by linarith

  then have "1 - 1/(2 * (length values)) < level \<and> level \<le> 1 \<longrightarrow>
       percentile_impl values level =
      (linear (1-1/(2* (length values)), values!(length values -1)) (1, extrapolation_1 values)) level"
    using percentile_impl_def
    by (smt assms(1) sorted_sort_id)
  then have up: "1 - 1/(2* (length values)) < level \<and> level \<le> 1 \<longrightarrow> ?thesis"
    using l3 by linarith
  have border_left: "1/(2* (length values)) = level \<longrightarrow> ?thesis"
    using assms(1) assms(2) percentile_java_equiv_left by blast
  then show ?thesis using low mid up assms by linarith
qed

export_code percentile_impl in Scala
end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory MuddyChildren
imports ClockView SPRViewDet
begin
(*>*)

subsection{* The Muddy Children *}

text{*

\label{sec:kbps-theory-mc}

Our first example of a multi-agent broadcast scenario is the classic
muddy children puzzle, one of a class of such puzzles that exemplify
non-obvious reasoning about mutual states of knowledge. It goes as
follows \citep[\S1.1, Example~7.2.5]{FHMV:1995}:
\begin{quotation}

  $N$ children are playing together, $k$ of whom get mud on their
  foreheads. Each can see the mud on the others' foreheads but not
  their own.

  A parental figure appears and says ``At least one of you has mud on your
  forehead.'', expressing something already known to each of them if $k >
  1$.

  The parental figure then asks ``Does any of you know whether you have mud
  on your own forehead?'' over and over.

  Assuming the children are perceptive, intelligent, truthful and they
  answer simultaneously, what will happen?
\end{quotation}
This puzzle relies essentially on \emph{synchronous public broadcasts}
making particular facts \emph{common knowledge}, and that agents are
capable of the requisite logical inference.

As the mother has complete knowledge of the situation, we integrate
her behaviour into the environment. Each agent $\mbox{child}_i$
reasons with the following KBP:
\begin{center}
  \begin{tabular}{lll}
    $\mathbf{do}$\\
     & $\gcalt\ \hat{\mathbf{K}}_{\mbox{child}_i} \mbox{muddy}_i$ & $@{text "\<rightarrow>"}$ Say ``I know if my forehead is muddy''\\
     & $\gcalt\ @{text "\<not>"}\hat{\mathbf{K}}_{\mbox{child}_i} \mbox{muddy}_i$ & $@{text "\<rightarrow>"}$ Say nothing\\
    $\mathbf{od}$\\
  \end{tabular}
\end{center}
where $\hat{\mathbf{K}}_a @{text "\<phi>"}$ abbreviates $\mathbf{K}_a
@{text "\<phi>"}\ @{text "\<or>"}\ \mathbf{K}_a @{text "\<not>\<phi>"}$.

As this protocol is deterministic, we use the SPR algorithm of
\S\ref{sec:kbps-theory-spr-deterministic-protocols}.

\begin{wrapfigure}{r}{0.5\textwidth}
  \vspace{-20pt}
  \includegraphics[width=0.48\textwidth]{MC}
  \vspace{-10pt}
  \caption{The protocol of $\mbox{child}_0$.}
  \label{fig:mc}
\end{wrapfigure}

The model records a child's initial observation of the mother's
pronouncement and the muddiness of the other children in her initial
private state, and these states are not changed by @{term
"envTrans"}. The recurring common observation is all of the children's
public responses to the mother's questions. Being able to distinguish
these observations is crucial to making this a broadcast scenario.

Running the algorithm for three children and minimising using
Hopcroft's algorithm yields the automaton in Figure~\ref{fig:mc} for
$\mbox{child}_0$. The initial transitions are labelled with the
initial observation, i.e., the cleanliness ``C'' or muddiness ``M'' of
the other two children. The dashed initial transition covers the case
where everyone is clean; in the others the mother has announced that
someone is dirty. Later transitions simply record the actions
performed by each of the agents, where ``K'' is the first action in
the above KBP, and ``N'' the second. Double-circled states are those
in which $\mbox{child}_0$ knows whether she is muddy, and
single-circled where she does not.

In essence the child counts the number of muddy foreheads she sees and
waits that many rounds before announcing that she knows.

Note that a solution to this puzzle is beyond the reach of the clock
semantics as it requires (in general) remembering the sequence of
previous broadcasts of length proportional to the number of
children. We discuss this further in \S\ref{sec:kbps-muddychildren}.

*}
(*<*)

datatype Agent = Child0 | Child1 | Child2
datatype Proposition = Dirty Agent

datatype ChildAct = SayIKnow | SayNothing

lemma Agent_univ: "(UNIV :: Agent set) = {Child0, Child1, Child2}"
  unfolding UNIV_def
  apply auto
  apply (case_tac x)
  apply auto
  done

instance Agent :: finite
  apply intro_classes
  apply (auto iff: Agent_univ)
  done

instantiation Agent :: linorder
begin

fun
  less_Agent
where
  "less_Agent Child0 Child0 = False"
| "less_Agent Child0 _      = True"
| "less_Agent Child1 Child2 = True"
| "less_Agent Child1 _      = False"
| "less_Agent Child2 _      = False"

definition
  less_eq_Agent :: "Agent \<Rightarrow> Agent \<Rightarrow> bool"
where
  "less_eq_Agent x y \<equiv> x = y \<or> x < y"

instance
  apply intro_classes
  unfolding less_eq_Agent_def
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, case_tac z, simp_all)
  apply (case_tac x, case_tac z, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  done
end

instantiation Agent :: enum
begin

definition
  "enum_class.enum = [Child0, Child1, Child2]"

definition
  "enum_class.enum_all P = (P Child0 \<and> P Child1 \<and> P Child2)"

definition
  "enum_class.enum_ex P = (P Child0 \<or> P Child1 \<or> P Child2)"

instance
  apply default
  unfolding enum_Agent_def enum_all_Agent_def enum_ex_Agent_def
  by auto (case_tac x, auto)+

end

lemma Act_univ: "(UNIV :: ChildAct set) = {SayIKnow, SayNothing}"
  unfolding UNIV_def
  apply auto
  apply (case_tac x)
  apply auto
  done

instance ChildAct :: finite
  by default (auto iff: Act_univ)

instantiation ChildAct :: enum
begin

definition
  "enum_class.enum = [SayIKnow, SayNothing]"

definition
  "enum_class.enum_all P = (P SayIKnow \<and> P SayNothing)"

definition
  "enum_class.enum_ex P = (P SayIKnow \<or> P SayNothing)"

instance
  apply default
  unfolding enum_ChildAct_def enum_all_ChildAct_def enum_ex_ChildAct_def
  by auto (case_tac x, auto)+

end

instantiation ChildAct :: linorder
begin

fun
  less_ChildAct
where
  "less_ChildAct SayIKnow SayNothing = True"
| "less_ChildAct _ _ = False"

definition
  less_eq_ChildAct :: "ChildAct \<Rightarrow> ChildAct \<Rightarrow> bool"
where
  "less_eq_ChildAct x y \<equiv> x = y \<or> x < y"

instance
  apply intro_classes
  unfolding less_eq_ChildAct_def
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac y, simp_all)
  apply (case_tac x, case_tac y, simp_all)
  apply (case_tac y, simp_all)
  done
end

type_synonym EnvAct = "unit"
type_synonym EnvState = "(bool \<times> bool \<times> bool) \<times> (ChildAct \<times> ChildAct \<times> ChildAct)"
type_synonym AgentState = "bool \<times> bool \<times> bool"
type_synonym GlobalState = "(Agent, EnvState, AgentState) BEState"

definition "agents \<equiv> fromList [Child0, Child1, Child2]"

fun
  aChildIsDirty :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
where
  "aChildIsDirty False False False = False"
| "aChildIsDirty _ _ _ = True"

definition
  initPS :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (Agent \<times> (bool \<times> bool \<times> bool)) odlist"
where
  "initPS c0 c1 c2 \<equiv>
     let acid = aChildIsDirty c0 c1 c2
      in fromList [ (Child0, (acid, c1, c2)), (Child1, (acid, c0, c2)), (Child2, (acid, c0, c1))]"

definition
  envInit :: "GlobalState list"
where
  "envInit \<equiv>
    let bu = [False, True]
     in [ \<lparr> es = ((c0, c1, c2), (SayNothing, SayNothing, SayNothing)), ps = initPS c0 c1 c2 \<rparr> .
             c0 \<leftarrow> bu, c1 \<leftarrow> bu, c2 \<leftarrow> bu ]"

(* The environment is passive, but it still needs to do something in
   each round for the system as a whole to evolve. *)

definition
  envAction :: "GlobalState \<Rightarrow> EnvAct list"
where
  "envAction \<equiv> \<lambda>_. [()]"

(* Transitions involve broadcasting the children's private actions,
leaving their private states unchanged. *)

definition
  envTransES :: "EnvAct \<Rightarrow> (Agent \<Rightarrow> ChildAct) \<Rightarrow> EnvState \<Rightarrow> EnvState"
where
  "envTransES \<equiv> \<lambda>eAct aAct s. (fst s, aAct Child0, aAct Child1, aAct Child2)"

definition
  envTrans :: "EnvAct \<Rightarrow> (Agent \<Rightarrow> ChildAct) \<Rightarrow> GlobalState \<Rightarrow> GlobalState"
where
  "envTrans eact aact s \<equiv> s \<lparr> es := envTransES eact aact (es s) \<rparr>"

(* Common observation: the actions of the agents. *)

definition "envObsC \<equiv> snd"

definition
  envVal :: "GlobalState \<Rightarrow> Proposition \<Rightarrow> bool"
where
  "envVal \<equiv> \<lambda>s p.
     case p of Dirty a \<Rightarrow>
       (case es s of ((c0, c1, c2), _) \<Rightarrow>
         (case a of
            Child0 \<Rightarrow> c0
          | Child1 \<Rightarrow> c1
          | Child2 \<Rightarrow> c2))"

(* FIXME This is a bit grot, this definition is already made for us in the locale. *)

definition "envObs \<equiv> \<lambda>a s. (envObsC (es s), ODList.lookup (ps s) a)"

(* The KBP. Clearly subjective and deterministic. *)

abbreviation
  "Kor \<phi> \<psi> \<equiv> Knot (Kand (Knot \<phi>) (Knot \<psi>))"

definition
  jkbp :: "Agent \<Rightarrow> (Agent, Proposition, ChildAct) KBP"
where
  "jkbp a = [ \<lparr> guard = Kor (\<^bold>K\<^sub>a (Kprop (Dirty a)))
                            (\<^bold>K\<^sub>a (Knot (Kprop (Dirty a)))), action = SayIKnow \<rparr>,
              \<lparr> guard = Kand (Knot (\<^bold>K\<^sub>a (Kprop (Dirty a))))
                             (Knot (\<^bold>K\<^sub>a (Knot (Kprop (Dirty a))))), action = SayNothing \<rparr> ]"

subsubsection{* Locale instantiations *}

interpretation MC!: Environment jkbp envInit envAction envTrans envVal envObs
  apply unfold_locales
  apply (auto simp: jkbp_def)
  done

subsubsection{* The Clock view implementation *}

interpretation MC_Clock!:
  FiniteLinorderEnvironment jkbp envInit envAction envTrans envVal envObs agents
  apply unfold_locales
  apply (simp add: Agent_univ agents_def)
  done

definition
  mc_ClockDFS
where
  "mc_ClockDFS \<equiv> ClockAutoDFS agents jkbp envInit envAction envTrans envVal envObs"

definition
  mc_ClockAlg
where
  "mc_ClockAlg \<equiv> mkClockAuto agents jkbp envInit envAction envTrans envVal envObs"

lemma (in FiniteLinorderEnvironment)
  "MC.Clock.implements mc_ClockAlg"
  unfolding mc_ClockAlg_def by (rule MC_Clock.mkClockAuto_implements)

subsubsection{* The SPR view implementation *}

interpretation MC_SPR!:
  FiniteDetBroadcastEnvironment jkbp envInit envAction envTrans envVal envObs agents envObsC
  apply unfold_locales
  prefer 3
  apply (fold envObs_def envAction_def envTrans_def)
  apply clarify
  apply (erule MC.SPR.jkbpDetI)
   apply (simp add: jkbp_def)
   apply (auto simp: jkbp_def)[1]

  unfolding envAction_def envTrans_def envObs_def agents_def
  apply (simp_all add: Agent_univ jkbp_def)

  done

definition
  mc_SPRDFS
where
  "mc_SPRDFS \<equiv> SPRDetAutoDFS agents jkbp envInit envAction envTrans envVal envObsC envObs"

definition
  mc_SPRAlg
where
  "mc_SPRAlg \<equiv> mkSPRDetAuto agents jkbp envInit envAction envTrans envVal envObsC envObs"

lemma (in FiniteDetBroadcastEnvironment)
  "MC.SPR.implements mc_SPRAlg"
  unfolding mc_SPRAlg_def by (rule MC_SPR.mkSPRDetAuto_implements)

end
(*>*)