(*  Title:       Iterators over Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* \isaheader{Iterators over Finite Sets} *}
theory SetIterator
imports
  "../../Automatic_Refinement/Lib/Misc"
  "../../Automatic_Refinement/Lib/Foldi"
  (*"../../Refine_Monadic/Refine_Monadic"*)
begin

text {* When reasoning about finite sets, it is often handy to be able to iterate over the elements
  of the set. If the finite set is represented by a list, the @{term fold} operation can be used.
  For general finite sets, the order of elements is not fixed though. Therefore, nondeterministic
  iterators are introduced in this theory. *}

subsection {* General Iterators *}

type_synonym ('x,'\<sigma>) set_iterator = "('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('x\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"

locale set_iterator_genord =
  fixes iti::"('x,'\<sigma>) set_iterator"
    and S0::"'x set"
    and R::"'x \<Rightarrow> 'x \<Rightarrow> bool"
  assumes foldli_transform:
    "\<exists>l0. distinct l0 \<and> S0 = set l0 \<and> sorted_by_rel R l0 \<and> iti = foldli l0"
begin
  text {* Let's prove some trivial lemmata to show that the formalisation agrees with
          the view of iterators described above. *}
  lemma set_iterator_weaken_R :
    "(\<And>x y. \<lbrakk>x \<in> S0; y \<in> S0; R x y\<rbrakk> \<Longrightarrow> R' x y) \<Longrightarrow>
             set_iterator_genord iti S0 R'"
    by (metis set_iterator_genord.intro foldli_transform sorted_by_rel_weaken)

  lemma finite_S0 :
    shows "finite S0"
    by (metis finite_set foldli_transform)

  lemma iti_stop_rule_cond :
    assumes not_c: "\<not>(c \<sigma>)"
    shows "iti c f \<sigma> = \<sigma>"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "iti c = foldli l0 c" by blast
    with foldli_not_cond [of c \<sigma> l0 f, OF not_c]
    show ?thesis by simp
  qed

  lemma iti_stop_rule_emp :
    assumes S0_emp: "S0 = {}"
    shows "iti c f \<sigma> = \<sigma>"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "S0 = set l0" "iti c = foldli l0 c" by blast
    with foldli.simps(1) [of c f \<sigma>] S0_emp
    show ?thesis by simp
  qed

  text {* Reducing everything to folding is cumbersome. Let's
          define a few high-level inference rules. *}

  lemma iteratei_rule_P:
    assumes
      "I S0 \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0;
                 \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0 - S. R y x\<rbrakk>
                 \<Longrightarrow> I (S - {x}) (f x \<sigma>)"
      "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> c \<sigma>; I S \<sigma>;
               \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iti c f \<sigma>0)"
  proof -
    { fix P I \<sigma>0 f
      assume
        I: "I S0 \<sigma>0" and
        R: "\<And>S \<sigma> x. \<lbrakk>c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>S-{x}. R x y\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>)" and
        C1: "I {} (iti c f \<sigma>0) \<Longrightarrow> P" and
        C2:"\<And>S. \<lbrakk>S \<subseteq> S0; S \<noteq> {}; \<not> c (iti c f \<sigma>0); I S (iti c f \<sigma>0)\<rbrakk> \<Longrightarrow> P"

      from foldli_transform obtain l0 where l0_props:
         "distinct l0" "S0 = set l0" "sorted_by_rel R l0"  "iti c = foldli l0 c" by auto

      from I R
      have "I {} (iti c f \<sigma>0) \<or>
          (\<exists>S. S \<subseteq> S0 \<and> S \<noteq> {} \<and>
               \<not> (c (iti c f \<sigma>0)) \<and>
               I S (iti c f \<sigma>0))"
        unfolding l0_props using l0_props(1,3)
      proof (induct l0 arbitrary: \<sigma>0)
        case Nil thus ?case by simp
      next
        case (Cons x l0)
        note ind_hyp = Cons(1)
        note I_x_l0 = Cons(2)
        note step = Cons(3)
        from Cons(4) have dist_l0: "distinct l0" and x_nin_l0: "x \<notin> set l0" by simp_all
        from Cons(5) have R_l0: "\<forall>y\<in>set l0. R x y" and
                          sort_l0: "sorted_by_rel R l0" by simp_all

        show ?case
        proof (cases "c \<sigma>0")
          case False
          with I_x_l0 show ?thesis
            apply (rule_tac disjI2)
            apply (rule_tac exI[where x="set (x # l0)"])
            apply (simp)
          done
        next
          case True note c_\<sigma>0 = this

          from step[of \<sigma>0 x "set (x # l0)"] I_x_l0 R_l0 c_\<sigma>0 x_nin_l0
          have step': "I (set l0) (f x \<sigma>0)"
            by (simp_all add: Ball_def)

          from ind_hyp [OF step' step dist_l0 sort_l0]
          have "I {} (foldli l0 c f (f x \<sigma>0)) \<or>
                (\<exists>S. S \<subseteq> set l0 \<and> S \<noteq> {} \<and>
                \<not> c (foldli l0 c f (f x \<sigma>0)) \<and> I S (foldli l0 c f (f x \<sigma>0)))"
            by (simp_all add: subset_iff)
          thus ?thesis
            by (simp add: c_\<sigma>0 subset_iff) metis
        qed
      qed
      with C1 C2 have "P" by blast
    } note aux = this

    from assms
    show ?thesis
      apply (rule_tac aux [of "\<lambda>S \<sigma>. I S \<sigma> \<and> (\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x)" \<sigma>0 f])
      apply auto
    done
  qed

  text {* Instead of removing elements one by one from the invariant, adding them is sometimes more natural. *}
  lemma iteratei_rule_insert_P:
  assumes pre :
      "I {} \<sigma>0"
      "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>(S0 - S) - {x}. R x y;
                 \<forall>y\<in>S. R y x\<rbrakk>
                  \<Longrightarrow> I (insert x S) (f x \<sigma>)"
      "\<And>\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>"
      "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> S0;
              \<not> (c \<sigma>); I S \<sigma>; \<forall>x\<in>S0-S. \<forall>y\<in>S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (iti c f \<sigma>0)"
  proof -
    let ?I' = "\<lambda>S \<sigma>. I (S0 - S) \<sigma>"

    have pre1:
      "!!\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> (c \<sigma>); ?I' S \<sigma>;
             \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x\<rbrakk> \<Longrightarrow> P \<sigma>"
    proof -
      fix S \<sigma>
      assume AA:
        "S \<subseteq> S0" "S \<noteq> {}"
        "\<not> (c \<sigma>)"
        "?I' S \<sigma>" "\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x"
      with pre(4) [of "S0 - S"]
      show "P \<sigma>" by auto
    qed

    have pre2 :"\<And>x S \<sigma>. \<lbrakk>c \<sigma>; x \<in> S; S \<subseteq> S0; ?I' S \<sigma>; \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> ?I' (S - {x}) (f x \<sigma>)"
    proof -
      fix x S \<sigma>
      assume AA : "c \<sigma>" "x \<in> S" "S \<subseteq> S0" "?I' S \<sigma>" "\<forall>y\<in>S - {x}. R x y" "\<forall>y\<in>S0 - S. R y x"

      from AA(2) AA(3) have "S0 - (S - {x}) = insert x (S0 - S)" "S0 - (S0 - S) = S" by auto
      moreover
      note pre(2) [of \<sigma> x "S0 - S"] AA
      ultimately show "?I' (S - {x}) (f x \<sigma>)"
        by auto
    qed

    show "P (iti c f \<sigma>0)"
      apply (rule iteratei_rule_P [of ?I' \<sigma>0 c f P])
      apply (simp add: pre)
      apply (rule pre2) apply simp_all
      apply (simp add: pre(3))
      apply (simp add: pre1)
    done
  qed

  text {* Show that iti without interruption is related to fold *}
  lemma iti_fold:
  assumes lc_f: "comp_fun_commute f"
    shows "iti (\<lambda>_. True) f \<sigma>0 = Finite_Set.fold f \<sigma>0 S0"
  proof (rule iteratei_rule_insert_P [where I = "\<lambda>X \<sigma>'. \<sigma>' = Finite_Set.fold f \<sigma>0 X"])
    fix S \<sigma> x
    assume "x \<in> S0 - S" "S \<subseteq> S0" and \<sigma>_eq: "\<sigma> = Finite_Set.fold f \<sigma>0 S"
    from finite_S0 `S \<subseteq> S0` have fin_S: "finite S" by (metis finite_subset)
    from `x \<in> S0 - S` have x_nin_S: "x \<notin> S" by simp
    note fold_eq = comp_fun_commute.fold_insert [OF lc_f fin_S x_nin_S]

    show "f x \<sigma> = Finite_Set.fold f \<sigma>0 (insert x S)"
      by (simp add: fold_eq \<sigma>_eq)
  qed simp_all
end

subsection {* Iterators over Maps *}

type_synonym ('k,'v,'\<sigma>) map_iterator = "('k\<times>'v,'\<sigma>) set_iterator"

text {* Iterator over the key-value pairs of a finite map are called iterators over maps.*}
abbreviation "map_iterator_genord it m R \<equiv> set_iterator_genord it (map_to_set m) R"

subsection {* Unordered Iterators *}

text {* Often one does not care about the order in which the elements are processed.
        Therefore, the selection function can be set to not impose any further restrictings.
        This leads to considerably simpler theorems. *}

definition "set_iterator it S0 \<equiv> set_iterator_genord it S0 (\<lambda>_ _. True)"
abbreviation "map_iterator it m \<equiv> set_iterator it (map_to_set m)"

lemma set_iterator_intro :
    "set_iterator_genord it S0 R \<Longrightarrow> set_iterator it S0"
unfolding set_iterator_def
apply (rule set_iterator_genord.set_iterator_weaken_R [where R = R])
apply simp_all
done

lemma set_iterator_no_cond_rule_P:
"\<lbrakk> set_iterator it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
by simp

lemma set_iterator_no_cond_rule_insert_P:
"\<lbrakk> set_iterator it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
by simp

lemma set_iterator_rule_P:
"\<lbrakk> set_iterator it S0;
   I S0 \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
   !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

lemma set_iterator_rule_insert_P:
"\<lbrakk> set_iterator it S0;
   I {} \<sigma>0;
   !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
   !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
   !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
 \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
by simp

text{* The following rules is adapted for maps. Instead of a set of key-value pairs the invariant
       now only sees the keys. *}
lemma map_iterator_genord_rule_P:
  assumes "map_iterator_genord it m R"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> it-{k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                             \<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)\<rbrakk> \<Longrightarrow>
                            I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                                     R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
proof (rule set_iterator_genord.iteratei_rule_P [of it "map_to_set m" R "\<lambda>S \<sigma>. I (fst ` S) \<sigma>" \<sigma>0 c f P])
  show "map_iterator_genord it m R" by fact
next
  show "I (fst ` map_to_set m) \<sigma>0" using I0 by (simp add: map_to_set_dom[symmetric])
next
  fix \<sigma>
  assume "I (fst ` {}) \<sigma>"
  with IF show "P \<sigma>" by simp
next
  fix \<sigma> S
  assume "S \<subseteq> map_to_set m" "S \<noteq> {}" "\<not> c \<sigma>" "I (fst ` S) \<sigma>"
         and R_prop: "\<forall>x\<in>S. \<forall>y\<in>map_to_set m - S. R y x"
  let ?S' = "fst ` S"

  show "P \<sigma>"
  proof (rule II [where it = ?S'])
    from `S \<subseteq> map_to_set m`
    show "?S' \<subseteq> dom m"
      unfolding map_to_set_dom
      by auto
  next
    from `S \<noteq> {}` show "?S' \<noteq> {}" by auto
  next
    show "\<not> (c \<sigma>)" by fact
  next
    show "I (fst ` S) \<sigma>" by fact
  next
    show "\<forall>k v k' v'.
       k \<notin> fst ` S \<and>
       m k = Some v \<and>
       k' \<in> fst ` S \<and> m k' = Some v' \<longrightarrow>
       R (k, v) (k', v')"
    proof (intro allI impI, elim conjE )
      fix k v k' v'
      assume pre_k: "k \<notin> fst ` S" "m k = Some v"
      assume pre_k': "k' \<in> fst ` S" "m k' = Some v'"

      from `S \<subseteq> map_to_set m` pre_k'
      have kv'_in: "(k', v') \<in> S"
        unfolding map_to_set_def by auto

      from `S \<subseteq> map_to_set m` pre_k
      have kv_in: "(k, v) \<in> map_to_set m - S"
        unfolding map_to_set_def
        by (auto simp add: image_iff)

      from R_prop kv_in kv'_in
      show "R (k, v) (k',v')" by simp
    qed
  qed
next
  fix \<sigma> S kv
  assume "S \<subseteq> map_to_set m" "kv \<in> S" "c \<sigma>" and I_S': "I (fst ` S) \<sigma>" and
         R_S: "\<forall>kv'\<in>S - {kv}. R kv kv'" and
         R_not_S: "\<forall>kv'\<in>map_to_set m - S. R kv' kv"
  let ?S' = "fst ` S"
  obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule PairE)

  have "I (fst ` S - {k}) (f (k, v) \<sigma>)"
  proof (rule IP)
    show "c \<sigma>" by fact
  next
    from `kv \<in> S` show "k \<in> ?S'" by (auto simp add: image_iff Bex_def)
  next
    from `kv \<in> S` `S \<subseteq> map_to_set m`
    have "kv \<in> map_to_set m" by auto
    thus m_k_eq: "m k = Some v" unfolding map_to_set_def by simp
  next
    from `S \<subseteq> map_to_set m`
    show S'_subset: "?S' \<subseteq> dom m"
      unfolding map_to_set_dom
      by auto
  next
    show "I (fst ` S) \<sigma>" by fact
  next
    from `S \<subseteq> map_to_set m` `kv \<in> S`
    have S_simp: "{(k', v'). k' \<in> (fst ` S) - {k} \<and> m k' = Some v'} = S - {kv}"
      unfolding map_to_set_def subset_iff
      apply (auto simp add: image_iff Bex_def)
      apply (metis option.inject)
    done

    from R_S[unfolded S_simp[symmetric]] R_not_S
    show "\<forall>k' v'. k' \<in> fst ` S - {k} \<and> m k' = Some v' \<longrightarrow>
                  R (k, v) (k', v') "
      by simp
  next
    from `S \<subseteq> map_to_set m` R_not_S
    show "\<forall>k' v'. k' \<notin> fst ` S \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)"
      apply (simp add: Ball_def map_to_set_def subset_iff image_iff)
      apply metis
    done
  qed

  moreover
    from `S \<subseteq> map_to_set m` `kv \<in> S`
    have "fst ` (S - {kv}) = fst ` S - {k}"
      apply (simp add: set_eq_iff image_iff Bex_def map_to_set_def subset_iff)
      apply (metis option.inject)
    done

  ultimately show "I (fst ` (S - {kv})) (f kv \<sigma>)" by simp
qed

lemma map_iterator_genord_rule_insert_P:
  assumes "map_iterator_genord it m R"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                             \<forall>k' v'. k' \<in> (dom m - it) - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                             \<forall>k' v'. k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                               R (k', v') (k, v)\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                         \<forall>k v k' v'. k \<in> it \<and> m k = Some v \<and> k' \<notin> it \<and> m k' = Some v' \<longrightarrow>
                                     R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
proof (rule map_iterator_genord_rule_P [of it m R "\<lambda>S \<sigma>. I (dom m - S) \<sigma>"])
  show "map_iterator_genord it m R" by fact
next
  show "I (dom m - dom m) \<sigma>0" using I0 by simp
next
  fix \<sigma>
  assume "I (dom m - {}) \<sigma>"
  with IF show "P \<sigma>" by simp
next
  fix \<sigma> it
  assume assms: "it \<subseteq> dom m" "it \<noteq> {}" "\<not> c \<sigma>" "I (dom m - it) \<sigma>"
                "\<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                             R (k, v) (k', v')"
  from assms have "dom m - it \<noteq> dom m" by auto
  with II[of "dom m - it" \<sigma>] assms
  show "P \<sigma>"
    apply (simp add: subset_iff dom_def)
    apply (metis option.simps(2))
  done
next
  fix k v it \<sigma>
  assume assms: "c \<sigma>" "k \<in> it" "m k = Some v" "it \<subseteq> dom m" "I (dom m - it) \<sigma>"
                "\<forall>k' v'. k' \<in> it - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v')"
                "\<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)"

  hence "insert k (dom m - it) = (dom m - (it - {k}))" "dom m - (dom m - it) = it" by auto
  with assms IP[of \<sigma> k "dom m - it" v]
  show "I (dom m - (it - {k})) (f (k, v) \<sigma>)" by (simp_all add: subset_iff)
qed

lemma map_iterator_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
      and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "P (it c f \<sigma>0)"
using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (it (\<lambda>_. True) f \<sigma>0)"
using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} \<sigma>0"
      and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
  shows "P (it (\<lambda>_. True) f \<sigma>0)"
using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
unfolding set_iterator_def
by simp

subsection {* Ordered Iterators *}

text {* Selecting according to a linear order is another case that is interesting.
 Ordered iterators over maps, i.\,e.\ iterators over key-value pairs,
 use an order on the keys.*}

context linorder begin
  definition "set_iterator_linord it S0
    \<equiv> set_iterator_genord it S0 op \<le>"
  definition "set_iterator_rev_linord it S0
    \<equiv> set_iterator_genord it S0 op \<ge>"
  definition "set_iterator_map_linord it S0 \<equiv>
     set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<le>k')"
  definition "set_iterator_map_rev_linord it S0 \<equiv>
     set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<ge>k')"
  abbreviation "map_iterator_linord it m \<equiv>
    set_iterator_map_linord it (map_to_set m)"
  abbreviation "map_iterator_rev_linord it m \<equiv>
    set_iterator_map_rev_linord it (map_to_set m)"

  lemma set_iterator_linord_rule_P:
  "\<lbrakk> set_iterator_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "op\<le>" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_linord_rule_insert_P:
  "\<lbrakk> set_iterator_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x \<le> x'\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "op\<le>" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_P:
  "\<lbrakk> set_iterator_rev_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "op\<ge>" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_insert_P:
  "\<lbrakk> set_iterator_rev_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x' \<le> x\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow>  (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "op\<ge>" I \<sigma>0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_map_linord_rule_P:
  "\<lbrakk> set_iterator_map_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k' \<le> k;
                  \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
         \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_linord_rule_insert_P:
  "\<lbrakk> set_iterator_map_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k;
                  \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k \<le> k'\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_P:
  "\<lbrakk> set_iterator_map_rev_linord it S0;
     I S0 \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k \<le> k';
                  \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
     !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_insert_P:
  "\<lbrakk> set_iterator_map_rev_linord it S0;
     I {} \<sigma>0;
     !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k';
                 \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k' \<le> k\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
     !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
     !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow>
            \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
   \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P
    [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma map_iterator_linord_rule_P:
    assumes "map_iterator_linord it m"
        and I0: "I (dom m) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k';
                 \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_linord_rule_insert_P:
    assumes "map_iterator_linord it m"
        and I0: "I {} \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k \<le> k';
                 \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto

  lemma map_iterator_rev_linord_rule_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I (dom m) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k;
                 \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_rev_linord_rule_insert_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I {} \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                 \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k' \<le> k;
                 \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                  \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (it c f \<sigma>0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto
end

subsection {* Conversions to foldli *}

lemma set_iterator_genord_foldli_conv :
  "set_iterator_genord iti S R \<longleftrightarrow>
   (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted_by_rel R l0 \<and> iti = foldli l0)"
unfolding set_iterator_genord_def by simp

lemma set_iterator_genord_I [intro] :
  "\<lbrakk>distinct l0; S = set l0; sorted_by_rel R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   set_iterator_genord iti S R" unfolding set_iterator_genord_foldli_conv
   by blast

lemma set_iterator_foldli_conv :
  "set_iterator iti S \<longleftrightarrow>
   (\<exists>l0. distinct l0 \<and> S = set l0 \<and> iti = foldli l0)"
unfolding set_iterator_def set_iterator_genord_def by simp

lemma set_iterator_I [intro] :
  "\<lbrakk>distinct l0; S = set l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   set_iterator iti S"
   unfolding set_iterator_foldli_conv
   by blast

context linorder begin
  lemma set_iterator_linord_foldli_conv :
    "set_iterator_linord iti S \<longleftrightarrow>
     (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted l0 \<and> iti = foldli l0)"
  unfolding set_iterator_linord_def set_iterator_genord_def by simp

  lemma set_iterator_linord_I [intro] :
    "\<lbrakk>distinct l0; S = set l0; sorted l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
     set_iterator_linord iti S"
     unfolding set_iterator_linord_foldli_conv
     by blast

  lemma set_iterator_rev_linord_foldli_conv :
    "set_iterator_rev_linord iti S \<longleftrightarrow>
     (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted (rev l0) \<and> iti = foldli l0)"
  unfolding set_iterator_rev_linord_def set_iterator_genord_def by simp

  lemma set_iterator_rev_linord_I [intro] :
    "\<lbrakk>distinct l0; S = set l0; sorted (rev l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
     set_iterator_rev_linord iti S"
     unfolding set_iterator_rev_linord_foldli_conv
     by blast
end

lemma map_iterator_genord_foldli_conv :
  "map_iterator_genord iti m R \<longleftrightarrow>
   (\<exists>(l0::('k \<times> 'v) list). distinct (map fst l0) \<and> m = map_of l0 \<and> sorted_by_rel R l0 \<and> iti = foldli l0)"
proof -
  { fix l0 :: "('k \<times> 'v) list"
    assume dist: "distinct l0"
    have "(map_to_set m = set l0) \<longleftrightarrow>
          (distinct (map fst l0) \<and>
           m = map_of l0)"
    proof (cases "distinct (map fst l0)")
      case True thus ?thesis by (metis map_of_map_to_set)
    next
      case False note not_dist_fst = this

      with dist have "~(inj_on fst (set l0))" by (simp add: distinct_map)
      hence "set l0 \<noteq> map_to_set m"
        by (rule_tac notI) (simp add: map_to_set_def inj_on_def)
      with not_dist_fst show ?thesis by simp
    qed
  }
  thus ?thesis
    unfolding set_iterator_genord_def distinct_map
    by metis
qed

lemma map_iterator_genord_I [intro] :
  "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted_by_rel R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   map_iterator_genord iti m R"
   unfolding map_iterator_genord_foldli_conv
   by blast

lemma map_iterator_foldli_conv :
  "map_iterator iti m \<longleftrightarrow>
   (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> iti = foldli l0)"
unfolding set_iterator_def map_iterator_genord_foldli_conv
by simp

lemma map_iterator_I [intro] :
  "\<lbrakk>distinct (map fst l0); m = map_of l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
   map_iterator iti m"
   unfolding map_iterator_foldli_conv
   by blast

context linorder begin

  lemma sorted_by_rel_keys_map_fst:
    "sorted_by_rel (\<lambda>(k,_) (k',_). R k k') l = sorted_by_rel R (map fst l)"
    by (induct l) auto

  lemma map_iterator_linord_foldli_conv :
    "map_iterator_linord iti m \<longleftrightarrow>
     (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (map fst l0) \<and> iti = foldli l0)"
  unfolding set_iterator_map_linord_def map_iterator_genord_foldli_conv
  by (simp add: sorted_by_rel_keys_map_fst)

  lemma map_iterator_linord_I [intro] :
    "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted (map fst l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
     map_iterator_linord iti m"
     unfolding map_iterator_linord_foldli_conv
     by blast

  lemma map_iterator_rev_linord_foldli_conv :
    "map_iterator_rev_linord iti m \<longleftrightarrow>
     (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (rev (map fst l0)) \<and> iti = foldli l0)"
  unfolding set_iterator_map_rev_linord_def map_iterator_genord_foldli_conv
  by (simp add: sorted_by_rel_keys_map_fst)

end

end


(*   Title: HOL/ex/Ballot.thy
     Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
     Author: Johannes Hölzl <hoelzl@in.tum.de>
*)

section \<open>Bertrand's Ballot Theorem\<close>

theory Ballot
imports
  Complex_Main
  "~~/src/HOL/Library/FuncSet"
begin

subsection \<open>Preliminaries\<close>

lemma card_bij':
  assumes "f \<in> A \<rightarrow> B" "\<And>x. x \<in> A \<Longrightarrow> g (f x) = x"
    and "g \<in> B \<rightarrow> A" "\<And>x. x \<in> B \<Longrightarrow> f (g x) = x"
  shows "card A = card B"
  apply (rule bij_betw_same_card)
  apply (rule bij_betwI)
  apply fact+
  done

subsection \<open>Formalization of Problem Statement\<close>

subsubsection \<open>Basic Definitions\<close>

datatype vote = A | B

definition
  "all_countings a b = card {f \<in> {1 .. a + b} \<rightarrow>\<^sub>E {A, B}.
      card {x \<in> {1 .. a + b}. f x = A} = a \<and> card {x \<in> {1 .. a + b}. f x = B} = b}"

definition
  "valid_countings a b =
    card {f\<in>{1..a+b} \<rightarrow>\<^sub>E {A, B}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> card {x\<in>{1..a+b}. f x = B} = b \<and>
      (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > card {x\<in>{1..m}. f x = B})}"

subsubsection \<open>Equivalence with Set Cardinality\<close>

lemma Collect_on_transfer:
  assumes "rel_set R X Y"
  shows "rel_fun (rel_fun R op =) (rel_set R) (\<lambda>P. {x\<in>X. P x}) (\<lambda>P. {y\<in>Y. P y})"
  using assms unfolding rel_fun_def rel_set_def by fast

lemma rel_fun_trans:
  "rel_fun P Q g g' \<Longrightarrow> rel_fun R P f f' \<Longrightarrow> rel_fun R Q (\<lambda>x. g (f x)) (\<lambda>y. g' (f' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2:
  "rel_fun P1 (rel_fun P2 Q) g g' \<Longrightarrow> rel_fun R P1 f1 f1' \<Longrightarrow> rel_fun R P2 f2 f2' \<Longrightarrow>
    rel_fun R Q (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g' (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_trans2':
  "rel_fun R (op =) f1 f1' \<Longrightarrow> rel_fun R (op =) f2 f2' \<Longrightarrow>
    rel_fun R (op =) (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g (f1' y) (f2' y))"
  by (auto simp: rel_fun_def)

lemma rel_fun_const: "rel_fun R (op =) (\<lambda>x. a) (\<lambda>y. a)"
  by auto

lemma rel_fun_conj:
  "rel_fun R (op =) f f' \<Longrightarrow> rel_fun R (op =) g g' \<Longrightarrow> rel_fun R (op =) (\<lambda>x. f x \<and> g x) (\<lambda>y. f' y \<and> g' y)"
  by (auto simp: rel_fun_def)

lemma rel_fun_ball:
  "(\<And>i. i \<in> I \<Longrightarrow> rel_fun R (op =) (f i) (f' i)) \<Longrightarrow> rel_fun R (op =) (\<lambda>x. \<forall>i\<in>I. f i x) (\<lambda>y. \<forall>i\<in>I. f' i y)"
  by (auto simp: rel_fun_def rel_set_def)

lemma
  shows all_countings_set: "all_countings a b = card {V\<in>Pow {0..<a+b}. card V = a}"
      (is "_ = card ?A")
    and valid_countings_set: "valid_countings a b =
      card {V\<in>Pow {0..<a+b}. card V = a \<and> (\<forall>m\<in>{1..a+b}. card ({0..<m} \<inter> V) > m - card ({0..<m} \<inter> V))}"
      (is "_ = card ?V")
proof -
  define P where "P j i \<longleftrightarrow> i < a + b \<and> j = Suc i" for j i
  have unique_P: "bi_unique P" and total_P: "\<And>m. m \<le> a + b \<Longrightarrow> rel_set P {1..m} {0..<m}"
    by (auto simp add: bi_unique_def rel_set_def P_def Suc_le_eq gr0_conv_Suc)
  have rel_fun_P: "\<And>R f g. (\<And>i. i < a+b \<Longrightarrow> R (f  (Suc i)) (g i)) \<Longrightarrow> rel_fun P R f g"
    by (simp add: rel_fun_def P_def)

  define R where "R f V \<longleftrightarrow>
    V \<subseteq> {0..<a+b} \<and> f \<in> extensional {1..a+b} \<and> (\<forall>i<a+b. i \<in> V \<longleftrightarrow> f (Suc i) = A)" for f V
  { fix f g :: "nat \<Rightarrow> vote" assume "f \<in> extensional {1..a + b}" "g \<in> extensional {1..a + b}"
    moreover assume "\<forall>i<a + b. (f (Suc i) = A) = (g (Suc i) = A)"
    then have "\<forall>i<a + b. f (Suc i) = g (Suc i)"
      by (metis vote.nchotomy)
    ultimately have "f i = g i" for i
      by (cases "i \<in> {1..a+b}") (auto simp: extensional_def Suc_le_eq gr0_conv_Suc) }
  then have unique_R: "bi_unique R"
    by (auto simp: bi_unique_def R_def)

  have "f \<in> extensional {1..a + b} \<Longrightarrow> \<exists>V\<in>Pow {0..<a + b}. R f V" for f
    by (intro bexI[of _ "{i. i < a+b \<and> f (Suc i) = A}"]) (auto simp add: R_def PiE_def)
  moreover have "V \<in> Pow {0..<a + b} \<Longrightarrow> \<exists>f\<in>extensional {1..a+b}. R f V" for V
    by (intro bexI[of _ "\<lambda>i\<in>{1..a+b}. if i - 1 \<in> V then A else B"]) (auto simp add: R_def PiE_def)
  ultimately have total_R: "rel_set R (extensional {1..a+b}) (Pow {0..<a+b})"
    by (auto simp: rel_set_def)

  have P: "rel_fun R (rel_fun P op =) (\<lambda>f x. f x = A) (\<lambda>V y. y \<in> V)"
    by (auto simp: P_def R_def Suc_le_eq gr0_conv_Suc rel_fun_def)

  have eq_B: "x = B \<longleftrightarrow> x \<noteq> A" for x
    by (cases x; simp)

  { fix f and m :: nat
    have "card {x\<in>{1..m}. f x = B} = card ({1..m} - {x\<in>{1..m}. f x = A})"
      by (simp add: eq_B set_diff_eq cong: conj_cong)
    also have "\<dots> = m - card {x\<in>{1..m}. f x = A}"
      by (subst card_Diff_subset) auto
    finally have "card {x\<in>{1..m}. f x = B} = m - card {x\<in>{1..m}. f x = A}" . }
  note card_B = this

  note transfers = rel_fun_const card_transfer[THEN rel_funD, OF unique_R] rel_fun_conj rel_fun_ball
    Collect_on_transfer[THEN rel_funD, OF total_R] Collect_on_transfer[THEN rel_funD, OF total_P]
    rel_fun_trans[OF card_transfer, OF unique_P] rel_fun_trans[OF Collect_on_transfer[OF total_P]]
    rel_fun_trans2'[where g="op ="] rel_fun_trans2'[where g="op <"] rel_fun_trans2'[where g="op -"]

  have "all_countings a b = card {f \<in> extensional {1..a + b}. card {x \<in> {1..a + b}. f x = A} = a}"
    using card_B by (simp add: all_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card ({x\<in>{0 ..< a + b}. x \<in> V}) = a}"
    by (intro P order_refl transfers)
  finally show "all_countings a b = card ?A"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)

  have "valid_countings a b = card {f\<in>extensional {1..a+b}.
      card {x\<in>{1..a+b}. f x = A} = a \<and> (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > m - card {x\<in>{1..m}. f x = A})}"
    using card_B by (simp add: valid_countings_def PiE_iff vote.nchotomy cong: conj_cong)
  also have "\<dots> = card {V\<in>Pow {0..<a+b}. card {x\<in>{0..<a+b}. x\<in>V} = a \<and>
    (\<forall>m\<in>{1..a+b}. card {x\<in>{0..<m}. x\<in>V} > m - card {x\<in>{0..<m}. x\<in>V})}"
    by (intro P order_refl transfers) auto
  finally show "valid_countings a b = card ?V"
    unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)
qed

lemma all_countings: "all_countings a b = (a + b) choose a"
  unfolding all_countings_set by (simp add: n_subsets)

subsection \<open>Facts About @{term valid_countings}\<close>

subsubsection \<open>Non-Recursive Cases\<close>

lemma card_V_eq_a: "V \<subseteq> {0..<a} \<Longrightarrow> card V = a \<longleftrightarrow> V = {0..<a}"
  using card_subset_eq[of "{0..<a}" V] by auto

lemma valid_countings_a_0: "valid_countings a 0 = 1"
  by (simp add: valid_countings_set card_V_eq_a cong: conj_cong)

lemma valid_countings_eq_zero:
  "a \<le> b \<Longrightarrow> 0 < b \<Longrightarrow> valid_countings a b = 0"
  by (auto simp add: valid_countings_set Int_absorb1 intro!: bexI[of _ "a + b"])

lemma Ico_subset_finite: "i \<subseteq> {a ..< b::nat} \<Longrightarrow> finite i"
  by (auto dest: finite_subset)

lemma Icc_Suc2: "a \<le> b \<Longrightarrow> {a..Suc b} = insert (Suc b) {a..b}"
  by auto

lemma Ico_Suc2: "a \<le> b \<Longrightarrow> {a..<Suc b} = insert b {a..<b}"
  by auto

lemma valid_countings_Suc_Suc:
  assumes "b < a"
  shows "valid_countings (Suc a) (Suc b) = valid_countings a (Suc b) + valid_countings (Suc a) b"
proof -
  let ?l = "Suc (a + b)"
  let ?Q = "\<lambda>V c. \<forall>m\<in>{1..c}. m - card ({0..<m} \<inter> V) < card ({0..<m} \<inter> V)"
  let ?V = "\<lambda>P. {V. (V \<in> Pow {0..<Suc ?l} \<and> P V) \<and> card V = Suc a \<and> ?Q V (Suc ?l)}"
  have "valid_countings (Suc a) (Suc b) = card (?V (\<lambda>V. ?l \<notin> V)) + card (?V (\<lambda>V. ?l \<in> V))"
    unfolding valid_countings_set
    by (subst card_Un_disjoint[symmetric]) (auto simp add: set_eq_iff intro!: arg_cong[where f=card])
  also have "card (?V (\<lambda>V. ?l \<in> V)) = valid_countings a (Suc b)"
    unfolding valid_countings_set
  proof (rule card_bij'[where f="\<lambda>V. V - {?l}" and g="insert ?l"])
    have *: "\<And>m V. m \<in> {1..a + Suc b} \<Longrightarrow> {0..<m} \<inter> (V - {?l}) = {0..<m} \<inter> V"
      by auto
    show "(\<lambda>V. V - {?l}) \<in> ?V (\<lambda>V. ?l \<in> V) \<rightarrow> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)}"
      by (auto simp: Ico_subset_finite *)
    { fix V assume V: "V \<subseteq> {0..<?l}"
      then have "finite V" "?l \<notin> V" "{0..<Suc ?l} \<inter> V = V"
        by (auto dest: finite_subset)
      with V have "card (insert ?l V) = Suc (card V)"
        "card ({0..<m} \<inter> insert ?l V) = (if m = Suc ?l then Suc (card V) else card ({0..<m} \<inter> V))"
        if "m \<le> Suc ?l" for m
        using that by auto }
    then show "insert ?l \<in> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)} \<rightarrow> ?V (\<lambda>V. ?l \<in> V)"
      using \<open>b < a\<close> by auto
  qed auto
  also have "card (?V (\<lambda>V. ?l \<notin> V)) = valid_countings (Suc a) b"
    unfolding valid_countings_set
  proof (intro arg_cong[where f="\<lambda>P. card {x. P x}"] ext conj_cong)
    fix V assume "V \<in> Pow {0..<Suc a + b}" and [simp]: "card V = Suc a"
    then have [simp]: "V \<subseteq> {0..<Suc ?l}"
      by auto
    show "?Q V (Suc ?l) = ?Q V (Suc a + b)"
      using \<open>b<a\<close> by (simp add: Int_absorb1 Icc_Suc2)
  qed (auto simp: subset_eq less_Suc_eq)
  finally show ?thesis
    by simp
qed

lemma valid_countings:
  "(a + b) * valid_countings a b = (a - b) * ((a + b) choose a)"
proof (induct a arbitrary: b)
  case 0 show ?case
    by (cases b) (simp_all add: valid_countings_eq_zero)
next
  case (Suc a) note Suc_a = this
  show ?case
  proof (induct b)
    case (Suc b) note Suc_b = this
    show ?case
    proof cases
      assume "a \<le> b" then show ?thesis
        by (simp add: valid_countings_eq_zero)
    next
      assume "\<not> a \<le> b"
      then have "b < a" by simp

      have "Suc a * (a - Suc b) + (Suc a - b) * Suc b =
        (Suc a * a - Suc a * Suc b) + (Suc a * Suc b - Suc b * b)"
        by (simp add: sign_simps)
      also have "\<dots> = (Suc a * a + (Suc a * Suc b - Suc b * b)) - Suc a * Suc b"
        using \<open>b<a\<close> by (intro add_diff_assoc2 mult_mono) auto
      also have "\<dots> = (Suc a * a + Suc a * Suc b) - Suc b * b - Suc a * Suc b"
        using \<open>b<a\<close> by (intro arg_cong2[where f="op -"] add_diff_assoc mult_mono) auto
      also have "\<dots> = (Suc a * Suc (a + b)) - (Suc b * Suc (a + b))"
        by (simp add: sign_simps)
      finally have rearrange: "Suc a * (a - Suc b) + (Suc a - b) * Suc b = (Suc a - Suc b) * Suc (a + b)"
        unfolding diff_mult_distrib by simp

      have "(Suc a * Suc (a + b)) * ((Suc a + Suc b) * valid_countings (Suc a) (Suc b)) =
        (Suc a + Suc b) * Suc a * ((a + Suc b) * valid_countings a (Suc b) + (Suc a + b) * valid_countings (Suc a) b)"
        unfolding valid_countings_Suc_Suc[OF \<open>b < a\<close>] by (simp add: field_simps)
      also have "... = (Suc a + Suc b) * ((a - Suc b) * (Suc a * (Suc (a + b) choose a)) +
        (Suc a - b) * (Suc a * (Suc (a + b) choose Suc a)))"
        unfolding Suc_a Suc_b by (simp add: field_simps)
      also have "... = (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc (Suc a + b) * (Suc a + b choose a))"
        unfolding Suc_times_binomial_add by (simp add: field_simps)
      also have "... = Suc a * (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc a + Suc b choose Suc a)"
        unfolding Suc_times_binomial_eq by (simp add: field_simps)
      also have "... = (Suc a * Suc (a + b)) * ((Suc a - Suc b) * (Suc a + Suc b choose Suc a))"
        unfolding rearrange by (simp only: mult_ac)
      finally show ?thesis
        unfolding mult_cancel1 by simp
    qed
  qed (simp add: valid_countings_a_0)
qed

lemma valid_countings_eq[code]:
  "valid_countings a b = (if a + b = 0 then 1 else ((a - b) * ((a + b) choose a)) div (a + b))"
  by (simp add: valid_countings[symmetric] valid_countings_a_0)

subsection \<open>Relation Between @{term valid_countings} and @{term all_countings}\<close>

lemma main_nat: "(a + b) * valid_countings a b = (a - b) * all_countings a b"
  unfolding valid_countings all_countings ..

lemma main_real:
  assumes "b < a"
  shows "valid_countings a b = (a - b) / (a + b) * all_countings a b"
using assms
proof -
  from main_nat[of a b] \<open>b < a\<close> have
    "(real a + real b) * real (valid_countings a b) = (real a - real b) * real (all_countings a b)"
    by (simp only: of_nat_add[symmetric] of_nat_mult[symmetric]) auto
  from this \<open>b < a\<close> show ?thesis
    by (subst mult_left_cancel[of "real a + real b", symmetric]) auto
qed

lemma
  "valid_countings a b = (if a \<le> b then (if b = 0 then 1 else 0) else (a - b) / (a + b) * all_countings a b)"
proof (cases "a \<le> b")
  case False
    from this show ?thesis by (simp add: main_real)
next
  case True
    from this show ?thesis
      by (auto simp add: valid_countings_a_0 all_countings valid_countings_eq_zero)
qed

subsubsection \<open>Executable Definition\<close>

declare all_countings_def [code del]
declare all_countings[code]

value "all_countings 1 0"
value "all_countings 0 1"
value "all_countings 1 1"
value "all_countings 2 1"
value "all_countings 1 2"
value "all_countings 2 4"
value "all_countings 4 2"

subsubsection \<open>Executable Definition\<close>

declare valid_countings_def [code del]

value "valid_countings 1 0"
value "valid_countings 0 1"
value "valid_countings 1 1"
value "valid_countings 2 1"
value "valid_countings 1 2"
value "valid_countings 2 4"
value "valid_countings 4 2"

end


section\<open>One-Step Methods\<close>
theory One_Step_Method
imports
  Ordinary_Differential_Equations.Initial_Value_Problem
begin

subsection \<open>Grids \label{sec:osm-grid}\<close>

locale grid =
  fixes t::"nat \<Rightarrow> real"
  assumes steps: "\<And>i. t i \<le> t (Suc i)"
begin

lemmas grid = steps

lemma grid_ge_min:
  shows "t 0 \<le> t j"
proof (induct j)
  fix j
  assume "t 0 \<le> t j"
  also from grid have "t j \<le> t (Suc j)" .
  finally show "t 0 \<le> t (Suc j)" .
qed simp

lemma grid_mono:
  assumes "j \<le> n"
  shows "t j \<le> t n"
using assms
proof (induct rule: inc_induct)
  fix j
  assume "j < n" "t (Suc j) \<le> t n"
  moreover
  with grid have "t j \<le> t (Suc j)" by auto
  ultimately
  show "t j \<le> t n" by simp
qed simp

text \<open>The size of the step from point j to j+1 in grid t\<close>

definition stepsize
where "stepsize j = t (Suc j) - t j"

lemma grid_stepsize_nonneg:
  shows "stepsize j \<ge> 0"
  using grid unfolding stepsize_def
  by (simp add: field_simps order_less_imp_le)

lemma grid_stepsize_sum:
  shows "(\<Sum>i\<in>{0..<n}. stepsize i) = t n - t 0"
  by (induct n) (simp_all add: stepsize_def)

definition max_stepsize
where "max_stepsize n = Max (stepsize ` {0..n})"

lemma max_stepsize_ge_stepsize:
  assumes "j \<le> n"
  shows "max_stepsize n \<ge> stepsize j"
  using assms by (auto simp: max_stepsize_def)

lemma max_stepsize_nonneg:
  shows "max_stepsize n \<ge> 0"
  using grid_stepsize_nonneg[of 0]
    max_stepsize_ge_stepsize[of 0 n]
  by simp

lemma max_stepsize_mono:
  assumes "j \<le> n"
  shows "max_stepsize j \<le> max_stepsize n"
  using assms by (auto intro!: Max_mono simp: max_stepsize_def)

definition min_stepsize
where "min_stepsize n = Min (stepsize ` {0..n})"

lemma min_stepsize_le_stepsize:
  assumes "j \<le> n"
  shows "min_stepsize n \<le> stepsize j"
  using grid assms
  by (auto simp add: min_stepsize_def)

end

lemma (in grid) grid_interval_notempty: "t 0 \<le> t n" using grid_ge_min[of n] .

subsection \<open>Definition \label{sec:osm-definition}\<close>

text\<open>Discrete evolution (noted \<open>\<Psi>\<close>) using incrementing function @{term incr}\<close>

definition discrete_evolution
where "discrete_evolution incr t1 t0 x = x + (t1 - t0) *\<^sub>R incr (t1 - t0) t0 x"

text \<open>Using the discrete evolution \<open>\<Psi>\<close> between each two points of the
  grid, define a function over the whole grid\<close>

fun grid_function
where
  "grid_function \<Psi> x0 t 0 = x0"
| "grid_function \<Psi> x0 t (Suc j) = \<Psi> (t (Suc j)) (t j) (grid_function \<Psi> x0 t j)"

subsection \<open>Consistency \label{sec:osm-consistent}\<close>

definition "consistent x t T B p incr \<longleftrightarrow>
  (\<forall>h\<ge>0. t + h \<le> T \<longrightarrow> dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1))"

lemma consistentD:
  assumes "consistent x t T B p incr"
  assumes "h \<ge> 0" "t + h \<le> T"
  shows "dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1)"
  using assms
  unfolding consistent_def by auto

lemma consistentI[intro]:
  fixes x::"real\<Rightarrow>'a::real_normed_vector"
  assumes "\<And>h. h > 0 \<Longrightarrow> t + h \<le> T \<Longrightarrow>
    dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) \<le> B * h ^ (p + 1)"
  shows "consistent x t T B p incr"
  using assms unfolding consistent_def
  by safe (case_tac "h = 0", auto simp: discrete_evolution_def)

lemma consistent_imp_nonneg_constant:
  assumes "consistent x t T B p incr"
  assumes "t < T"
  shows "B \<ge> 0"
proof -
  from assms have "T - t > 0" by simp
  have "0 \<le> dist (x T) (discrete_evolution incr T t (x t))" by simp
  also from assms
  have "... \<le> B * (T - t) ^ (p + 1)"
    unfolding consistent_def by (auto dest: spec[where x="T - t"])
  finally show ?thesis using zero_less_power[OF \<open>T - t > 0\<close>, of "p+1"]
    by (simp add: zero_le_mult_iff)
qed

lemma stepsize_inverse:
  assumes "L \<ge> 0" "h \<ge> 0" "B \<ge> 0" "r \<ge> 0" "p > 0" "T1 \<ge> T2" "T2 \<ge> 0"
  assumes max_step: "h \<le> root p (r * L / B / (exp (L * T1 + 1) - 1))"
  shows  "B / L * (exp (L * T2 + 1) - 1) * h ^ p \<le> r"
proof -
  { assume "L = 0" hence ?thesis using \<open>r \<ge> 0\<close> by simp
  } moreover {
    assume B_pos: "B > 0" assume "L > 0"
    from \<open>0 \<le> T2\<close> \<open>T1 \<ge> T2\<close> have "T1 \<ge> 0" by simp
    hence eg: "(exp (L * T1 + 1) - 1) > 0" using \<open>L > 0\<close>
      by (auto intro!: add_nonneg_pos)
    have "B * (h ^ p * (exp (L * T2 + 1) - 1)) / L \<le>
      B * (root p (r * L / B / (exp (L * T1 + 1) - 1)) ^ p
      * (exp (L * T2 + 1) - 1)) / L"
      using assms
      by (auto simp add: ge_iff_diff_ge_0[symmetric] divide_simps
               intro!: mult_left_mono mult_right_mono power_mono)
    also
    have "root p (r * L / B / (exp (L * T1 + 1) - 1)) ^ p =
      (r * L / B / (exp (L * T1 + 1) - 1))"
      using assms B_pos \<open>T1 \<ge> 0\<close> \<open>L > 0\<close> \<open>B > 0\<close>
      by (subst real_root_pow_pos2[OF \<open>p > 0\<close>])
         (auto intro!: divide_nonneg_pos add_nonneg_pos mult_pos_pos)
    finally
    have "B * (h ^ p * (exp (L * T2 + 1) - 1)) / L \<le>
      r * ((exp (L * T2 + 1) - 1) / (exp (L * T1 + 1) - 1))"
      using B_pos \<open>L > 0\<close> eg \<open>r \<ge> 0\<close>
      by (simp add: ac_simps)
    also have "... \<le> r" using \<open>T1 \<ge> T2\<close> \<open>0 \<le> T2\<close>
    proof (cases "T1 = 0")
      assume "T1 \<noteq> 0" with \<open>T1 \<ge> T2\<close> \<open>0 \<le> T2\<close> have "T1 > 0" by simp
      show ?thesis using \<open>L > 0\<close> \<open>0 \<le> T2\<close> \<open>T1 \<ge> 0\<close> add_0_left \<open>T1 > 0\<close> \<open>T1 \<ge> T2\<close>
        by (intro mult_right_le_one_le \<open>r \<ge> 0\<close>)
           (subst pos_le_divide_eq pos_divide_le_eq, auto simp add: intro!: add_pos_pos)+
    qed simp
    finally have ?thesis by (simp add: ac_simps)
  } moreover {
    assume "\<not>0<B" hence "B = 0" using \<open>B \<ge> 0\<close> by simp
    hence ?thesis using \<open>r \<ge> 0\<close> by simp
  } ultimately show ?thesis using assms by arith
qed

subsection \<open>Accumulation of errors\<close>

text \<open>The concept of accumulating errors applies to convergence and stability.\<close>

lemma (in grid) error_accumulation:
  fixes x::"(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> 'a::euclidean_space"
  assumes max_step: "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (T - t 0) + 1) - 1))"
  defines "K \<equiv> {(s, y). \<exists>i \<le> j. s = t i \<and> y \<in> cball (x t i) r}"
  assumes "p > 0"
  assumes lipschitz: "\<And>j. t (Suc j) \<le> T \<Longrightarrow>
  dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le> \<bar>r\<bar> \<Longrightarrow>
  dist (\<psi> (stepsize j) (t j) (x t j))
     (\<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j))
    \<le> L * dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)" and "L \<ge> 0"
  assumes consistence_error: "\<And>j. t (Suc j) \<le> T \<Longrightarrow>
    dist (x t (Suc j)) (discrete_evolution \<psi> (t (Suc j)) (t j) (x t j)) \<le>
    B * stepsize j ^ (p + 1)" and "B \<ge> 0"
  assumes initial_error: "dist (x t 0) x0 \<le>
    B * (exp 1 - 1) * stepsize 0 ^ p / L"
  assumes "t j \<le> T"
  shows "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le>
    B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
using \<open>t j \<le> T\<close> max_step
proof (induct j)
  case 0 note initial_error
  also have "B * (exp 1 - 1) * stepsize 0 ^ p / L \<le>
    B * (exp 1 - 1) * max_stepsize 0 ^ p / L"
    using grid_stepsize_nonneg \<open>B\<ge>0\<close> \<open>L\<ge>0\<close>
    by (auto intro!: max_stepsize_ge_stepsize power_mono mult_left_mono divide_right_mono)
  finally show ?case by simp
next
  case (Suc j)
  have "t 0 \<le> T"
    using Suc grid_interval_notempty[of "Suc j"] by auto
  from Suc have j_in:"t j \<le> T" using grid_mono[of j "Suc j"] by simp
  moreover
  have "max_stepsize j \<le> max_stepsize (Suc j)"
    by (simp add: max_stepsize_mono)
  with Suc have IH1: "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (T - t 0) + 1) - 1))" by simp
  ultimately have
    IH2: "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)
     \<le> B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
    by (rule Suc(1))
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j)) =
    norm (x t (Suc j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) +
    ((discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (simp add: field_simps dist_norm)
  also have "... \<le> norm (x t (Suc j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) +
    norm (((discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j) -
    (discrete_evolution \<psi>) (t (Suc j)) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    (is "_ \<le> _ + ?ej")
    by (rule norm_triangle_ineq)
  also have "?ej =
    norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j + stepsize j *\<^sub>R
    (\<psi> (stepsize j) (t j) (x t j) -
    \<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (simp add: discrete_evolution_def stepsize_def algebra_simps)
  also have "... \<le>
    norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j) + norm (stepsize j *\<^sub>R
    (\<psi> (stepsize j) (t j) (x t j) -
    \<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j)))"
    by (rule norm_triangle_ineq)
  also have "... = norm (x t j - grid_function (discrete_evolution \<psi>) x0 t j) +
    stepsize j *
    dist (\<psi> (stepsize j) (t j) (x t j))
    (\<psi> (stepsize j) (t j) (grid_function (discrete_evolution \<psi>) x0 t j))"
    (is "_ = _ + _ * ?dj")
    using grid_stepsize_nonneg
    by (simp add: dist_norm)
  also
  have "?dj \<le> L * dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
  proof (intro lipschitz(1))
    from IH2 have
      "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)
      \<le> B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
      by (simp add: ac_simps)
    also have "... \<le>
      B / L * (exp (L * (T - t 0) + 1) - 1) * max_stepsize j ^ p"
      using \<open>L\<ge>0\<close> \<open>B\<ge>0\<close> \<open>t j \<le> T\<close> max_stepsize_nonneg
      by (auto intro!: mult_left_mono mult_right_mono divide_right_mono)
    also have "... \<le> \<bar>r\<bar>"
      using \<open>B \<ge> 0\<close> max_step max_stepsize_nonneg \<open>L \<ge> 0\<close> \<open>p > 0\<close>
        grid_ge_min using grid_mono[of 0 j] \<open>t 0 \<le> T\<close> IH1
      by (intro stepsize_inverse) auto
    finally show
      "dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j) \<le> \<bar>r\<bar>" .
  qed (insert Suc, simp)
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> norm (x t (Suc j) - (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) +
    (1 + stepsize j * L) *
      dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
    using grid_stepsize_nonneg
    by (auto simp: algebra_simps mult_right_mono dist_norm)
  also
  have "norm (x t (Suc j) - (discrete_evolution \<psi>) (t (Suc j)) (t j) (x t j)) \<le>
    B * stepsize j ^ (p + 1)"
    using consistence_error[OF \<open>t (Suc j) \<le> T\<close>] by (simp add: dist_norm)
  finally have rec:
    "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
      \<le> B * stepsize j ^ (p + 1) +
        (1 + stepsize j * L) *
        dist (x t j) (grid_function (discrete_evolution \<psi>) x0 t j)"
    by simp
  also have "... \<le> B * stepsize j ^ (p + 1) +
    (1 + stepsize j * L) * (B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p)"
    using \<open>B \<ge> 0\<close> IH1 IH2 \<open>t (Suc j) \<le> T\<close> \<open>0\<le>L\<close> grid_stepsize_nonneg
    by (intro add_mono mult_left_mono) auto
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> B * stepsize j ^ (p + 1) +
    (1 + stepsize j * L) * (B / L * (exp (L * (t j - t 0) + 1) - 1) *
      max_stepsize j ^ p)" .
  also have "... \<le> B * stepsize j * max_stepsize j ^ p +
    (1 + stepsize j * L) *
    (B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p)"
    using grid_stepsize_nonneg \<open>B \<ge> 0\<close> grid
    by (auto intro!: mult_left_mono power_mono
      simp add: max_stepsize_def field_simps)
  also have "... = max_stepsize j ^ p * B / L * (1 + stepsize j * L) *
      (exp (L * (t j - t 0) + 1))
    - max_stepsize j ^ p * B / L"
    using \<open>B \<ge> 0\<close> grid_stepsize_nonneg \<open>p > 0\<close> \<open>L\<ge>0\<close>
    apply (cases "L \<noteq> 0")
    subgoal by (simp add: field_simps)
    subgoal
      apply (cases "max_stepsize j = 0")
      subgoal by simp
      subgoal by (metis IH1 abs_not_less_zero abs_of_pos div_0 less_eq_real_def max_stepsize_nonneg
            mult_zero_right real_root_zero)
      done
    done
  also
  have "B * (max_stepsize j ^ p * (exp (L * (t j - t 0) + 1) *
    (1 + L * (t (Suc j) - t j)))) / L
    \<le> B * (max_stepsize j ^ p * exp (L * (t (Suc j) - t 0) + 1)) / L"
    using \<open>L \<ge> 0\<close> \<open>B \<ge> 0\<close> max_stepsize_nonneg
  proof (intro divide_right_mono mult_left_mono)
    have "exp (L * (t j - t 0) + 1) * (1 + L * (t (Suc j) - t j)) \<le>
      exp (L * (t j - t 0) + 1) * exp (stepsize j * L)"
      unfolding stepsize_def[symmetric] by (auto simp add: ac_simps)
    also have "... \<le> exp (L * (t (Suc j) - t 0) + 1)"
      by (simp add: mult_exp_exp stepsize_def algebra_simps)
    finally
    show "exp (L * (t j - t 0) + 1) * (1 + L * (t (Suc j) - t j)) \<le>
      exp (L * (t (Suc j) - t 0) + 1)" .
  qed simp_all
  hence "max_stepsize j ^ p * B / L * (1 + stepsize j * L) *
    exp (L * (t j - t 0) + 1) \<le>
    max_stepsize j ^ p * B / L * exp (L * (t (Suc j) - t 0) + 1)"
    by (simp add: stepsize_def ac_simps)
  finally
  have "dist (x t (Suc j)) (grid_function (discrete_evolution \<psi>) x0 t (Suc j))
    \<le> B / L * (exp (L * (t (Suc j) - t 0) + 1) - 1) *
    max_stepsize j ^ p" by (simp add: algebra_simps)
  also have "... \<le> B / L * (exp (L * (t (Suc j) - t 0) + 1) - 1) *
    max_stepsize (Suc j) ^ p"
    using \<open>B\<ge>0\<close>\<open>L\<ge>0\<close> max_stepsize_nonneg
    by (intro mult_left_mono power_mono max_stepsize_mono)
       (auto intro!: divide_nonneg_nonneg mult_nonneg_nonneg add_nonneg_nonneg grid_mono)
  finally show ?case .
qed

subsection \<open>Consistency of order p implies convergence of order p \label{sec:osm-cons-imp-conv}\<close>

locale consistent_one_step =
  fixes t0 t1 and x::"real \<Rightarrow> 'a::euclidean_space" and incr p B r L
  assumes order_pos: "p > 0"
  assumes consistent_nonneg: "B \<ge> 0"
  assumes consistent: "\<And>s. s \<in> {t0..t1} \<Longrightarrow> consistent x s t1 B p incr"
  assumes lipschitz_nonneg: "L \<ge> 0"
  assumes lipschitz_incr: "\<And>s h. s \<in> {t0..t1} \<Longrightarrow> h \<in> {0..t1 - s} \<Longrightarrow>
    L-lipschitz_on (cball (x s) \<bar>r\<bar>) (\<lambda>x. incr h s x)"

locale max_step = grid +
  fixes t1 p L B r
  assumes max_step: "\<And>j. t j \<le> t1 \<Longrightarrow> max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
begin

lemma max_step_mono_r:
  assumes "\<bar>s\<bar> \<ge> \<bar>r\<bar>" "L \<ge> 0" "B \<ge> 0" "t1 \<ge> t 0" "0 < p" "t j \<le> t1"
  shows "max_stepsize j \<le>
    root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
proof -
  from max_step \<open>t j \<le> t1\<close> have "max_stepsize j \<le>
    root p (\<bar>r\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))" .
  also
  have "... \<le> root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))"
    using assms
    apply (cases "B = 0", force)
    apply (cases "L = 0", force)
    by (auto simp add: mult_le_cancel_left1
             intro!: divide_right_mono add_increasing mult_left_mono)
  finally
  show "max_stepsize j \<le> root p (\<bar>s\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1))" .
qed

end

locale convergent_one_step = consistent_one_step + max_step +
  assumes grid_from: "t0 = t 0"
begin

lemma (in convergent_one_step) convergence:
  assumes "t j \<le> t1"
  shows "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
        B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
proof -
  from order_pos consistent_nonneg lipschitz_nonneg
  have "p > 0" "B \<ge> 0" "L \<ge> 0" by simp_all
  from consistent have consistence_error: "dist (x (t j + stepsize j))
      (discrete_evolution incr (t j + stepsize j) (t j) (x (t j)))
      \<le> B * (stepsize j ^ (p + 1))"
      if "t (Suc j) \<le> t1" for j :: nat
    apply (rule consistentD [OF _ grid_stepsize_nonneg])
    using \<open>t (Suc j) \<le> t1\<close> grid_mono[of j "Suc j"] grid_from grid_interval_notempty
    by (auto simp add: stepsize_def)
  have lipschitz_grid: "dist (incr (stepsize j) (t j) (x (t j)))
    (incr (stepsize j) (t j)
    (grid_function (discrete_evolution incr) (x (t 0)) t j))
    \<le> L *
    dist (x (t j))
    (grid_function (discrete_evolution incr) (x (t 0)) t j)"
    if "t (Suc j) \<le> t1"
    and in_K: "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r\<bar>"
    for j :: nat
  proof -
    from in_K have "stepsize j \<in> {0..t1 - t j}"
      using grid_stepsize_nonneg grid_mono \<open>t (Suc j) \<le> t1\<close>
      by (simp add: stepsize_def)
    moreover
    have t: "t j \<in> {t 0..t1}" using grid[of j] \<open>t (Suc j) \<le> t1\<close>
      grid_mono[of j "Suc j"] grid_ge_min by simp
    moreover
    have "x (t j) \<in> cball (x (t j)) \<bar>r\<bar>" by simp
    moreover
    have  "grid_function (discrete_evolution incr) (x (t 0)) t j \<in>
      cball (x (t j)) \<bar>r\<bar>" using in_K mem_cball by blast
    ultimately
    show ?thesis
      using lipschitz_incr grid_from
      unfolding lipschitz_on_def
      by blast
  qed
  have
    "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
    (B / L * (exp (L * (t j - t 0) + 1) - 1)) * max_stepsize j ^ p"
    using \<open>p > 0\<close> \<open>L \<ge> 0\<close> \<open>B \<ge> 0\<close> \<open>t j \<le> t1\<close>
      max_stepsize_nonneg
      consistence_error lipschitz_grid
    by (intro error_accumulation[OF max_step]) (auto intro!:
      divide_nonneg_nonneg mult_nonneg_nonneg zero_le_power grid_mono
      simp add: lipschitz_on_def stepsize_def)
  also have "... \<le>
    (B / L * (exp (L * (t1 - t 0) + 1) - 1)) * max_stepsize j ^ p"
    using \<open>t j \<le> t1\<close> \<open>0\<le>L\<close> \<open>0\<le>B\<close> max_stepsize_nonneg
    by (auto intro!: divide_right_mono mult_right_mono mult_left_mono)
  finally show ?thesis by simp
qed

end

subsection \<open>Stability \label{sec:osm-stability}\<close>

locale disturbed_one_step = grid +
  fixes t1 s s0 x incr p B L
  assumes initial_error: "norm s0 \<le> B / L * (exp 1 - 1) * stepsize 0 ^ p"
  assumes error: "\<And>j. t (Suc j) \<le> t1 \<Longrightarrow>
  norm (s (stepsize j) (t j)
  (grid_function (discrete_evolution (\<lambda>h t x. incr h t x + s h t x))
    (x (t 0) + s0) t j)) \<le> B * stepsize j ^ p"

locale stable_one_step =
  consistent_one_step "t 0" + disturbed_one_step +
  max_step t t1 p L B "r / 2"
begin

lemma t0_le: "t i \<le> t1 \<Longrightarrow> t 0 \<le> t1"
  by (metis grid_interval_notempty order.trans)

lemma stability:
  assumes "t j \<le> t1"
  defines incrs: "incrs \<equiv> \<lambda>h t x. incr h t x + s h t x"
  shows "dist
    (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
    (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
        B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
proof -
  have "t 0 \<le> t1"
    by (metis assms(1) grid_ge_min order_trans)
  have error: "norm (stepsize j *\<^sub>R s (stepsize j) (t j)
        (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      \<le> B * stepsize j ^ (p + 1)"
    if "t (Suc j) \<le> t1" for j
  proof -
    from error[OF that] have "stepsize j * norm (s (stepsize j) (t j)
        (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
       \<le> stepsize j * (B * stepsize j ^ p)"
      using grid_stepsize_nonneg
      by (auto intro: mult_left_mono simp: incrs)
    then show ?thesis
      using grid_stepsize_nonneg
      by (simp add: field_simps)
  qed
  interpret c1: convergent_one_step "t 0" using max_step_r
    by unfold_locales simp_all
  have incr_in: "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r / 2\<bar>"
    if "t (Suc j) \<le> t1" for j
  proof -
    from that have "t j \<le> t1"
      using grid_mono[of j "Suc j"] by auto
    have "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j)
      \<le> B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
      using \<open>t j \<le> t1\<close> by (rule c1.convergence)
    also have "... \<le> \<bar>r/2\<bar>" using max_stepsize_nonneg grid_interval_notempty max_step
      consistent_nonneg lipschitz_nonneg order_pos
      grid_mono \<open>t j \<le> t1\<close> t0_le
      apply (cases "L = 0", force)
      by (intro stepsize_inverse) auto
    finally show ?thesis .
  qed
  have incr_in_r: "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r\<bar>"
    if "t (Suc j) \<le> t1" for j
  proof -
    note incr_in[OF that]
    also have "\<bar>r/2\<bar> \<le> \<bar>r\<bar>" by simp
    finally show ?thesis .
  qed
  have "dist
    (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
    (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
    B / L * (exp (L * (t j - t 0) + 1) - 1) * max_stepsize j ^ p"
  proof (intro error_accumulation[OF max_step])
    fix j assume j: "t (Suc j) \<le> t1"
    show "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t (Suc j))
      (discrete_evolution incr (t (Suc j)) (t j) (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      \<le> B * stepsize j ^ (p + 1)"
      using error[OF j]
      by (simp add: incrs discrete_evolution_def[abs_def] dist_norm
        stepsize_def scaleR_right_distrib)
  next
    fix j assume "t (Suc j) \<le> t1" hence "t j \<le> t1" using grid_mono[of j "Suc j"]
      by simp
    have
      "dist (x (t j)) (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      \<le> dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) +
      dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j)"
      by (rule dist_triangle2)
    also have
      "dist (x (t j)) (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
      B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
      using \<open>t j \<le> t1\<close> by (rule c1.convergence)
    also have "... \<le> \<bar>r/2\<bar>"
      using max_stepsize_nonneg grid_interval_notempty max_step
        consistent_nonneg lipschitz_nonneg order_pos
        grid_mono \<open>t j \<le> t1\<close> \<open>t 0 \<le> t1\<close>
      by (intro stepsize_inverse) auto
    also
    assume "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le> \<bar>r / 2\<bar>"
    finally
    have "dist
      (x (t j))
      (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j) \<le> \<bar>r\<bar>" by simp
    thus "dist
      (incr (stepsize j) (t j)
      (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j))
      (incr (stepsize j) (t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j))
      \<le> L *
      dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
      (grid_function (discrete_evolution incr) (x (t 0)) t j)"
      using  \<open>t j \<le> t1\<close> \<open>t (Suc j) \<le> t1\<close> incr_in_r
        max_stepsize_nonneg
        grid_ge_min
        grid_stepsize_nonneg
        grid_mono[of j]
      by (intro lipschitz_incr[THEN lipschitz_onD]) (auto simp: stepsize_def mem_cball)
  next
    show "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t 0)
      (x (t 0))
      \<le> B * (exp 1 - 1) * stepsize 0 ^ p / L" using initial_error
      by (simp add: dist_norm)
  qed (simp_all add: consistent_nonneg order_pos lipschitz_nonneg \<open>t j \<le> t1\<close>)
  also have "... \<le>
    B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p"
    using grid lipschitz_nonneg consistent_nonneg
      max_stepsize_nonneg
      grid_ge_min grid_mono \<open>t j \<le> t1\<close>
    by  (auto simp add: ac_simps intro!: divide_right_mono mult_left_mono)
  finally have "dist (grid_function (discrete_evolution incrs) (x (t 0) + s0) t j)
   (grid_function (discrete_evolution incr) (x (t 0)) t j)
  \<le> B / L * (exp (L * (t1 - t 0) + 1) - 1) * max_stepsize j ^ p" .
  thus ?thesis by simp
qed

end

subsection\<open>Stability via implicit error\<close>

locale rounded_one_step = consistent_one_step "t 0" t1 x incr p B r L +
  max_step t t1 p L B "r / 2"
  for t::"nat\<Rightarrow>real" and t1 and x::"real\<Rightarrow>('a::ordered_euclidean_space)" and incr p B r L +
  fixes incr'::"real\<Rightarrow>real\<Rightarrow>'a\<Rightarrow>'a"
  fixes x0'::'a
  assumes initial_error: "dist (x (t 0)) x0' \<le>
    B / L * (exp 1 - 1) * stepsize 0 ^ p"
  assumes incr_approx: "\<And>h j x. t j \<le> t1 \<Longrightarrow> dist (incr h (t j) x) (incr' h (t j) x) \<le>
    B * stepsize j ^ p"
begin

lemma stability:
  assumes "t j \<le> t1"
  shows "dist
   ((grid_function (discrete_evolution incr') (x0') t j))
   (grid_function (discrete_evolution incr) (x (t 0)) t j) \<le>
     B / L * (exp (L * (t1 - (t 0)) + 1) - 1) * max_stepsize j ^ p"
proof -
   note fg' = incr_approx
  define s0 where "s0 \<equiv> x0' - x (t 0)"
  hence x0': "x0' = x (t 0) + s0"
    by simp
  define s where "s \<equiv> \<lambda>x xa xb. (incr' x xa xb) - incr x xa xb"
  define incrs where "incrs \<equiv> \<lambda>h t x. incr h t x + s h t x"
  have s: "incr' = incrs"
    by (simp add: s_def incrs_def [abs_def])
  interpret c: stable_one_step t1 x incr p B r L t s s0
  proof
    fix j
    assume "(t (Suc j)) \<le> t1"
    hence "t j \<le> t1" using grid_mono[of j "Suc j"] by simp
    have "norm (s (stepsize j) (t j) (grid_function
             (discrete_evolution (\<lambda>h t x. (incr' h t x)))
             (x (t 0) + s0) t j))
          \<le> B * stepsize j ^ p"
      unfolding s_def dist_norm[symmetric]
      by (simp only: dist_commute fg'[OF \<open>t j \<le> t1\<close>])
    then show "norm
         (s (stepsize j) (t j)
           (grid_function (discrete_evolution (\<lambda>h t x. incr h t x + s h t x))
             (x (t 0) + s0) (\<lambda>x. (t x)) j))
        \<le> B * stepsize j ^ p" by (simp add: s incrs_def)
  next
    show "norm s0 \<le> B / L * (exp 1 - 1) * stepsize 0 ^ p"
      unfolding s0_def using initial_error by (simp add: dist_commute dist_norm)
  qed
  show ?thesis
    unfolding s x0'
    using \<open>t j \<le> t1\<close>
    by (rule c.stability[simplified incrs_def[symmetric]])
qed

end

end


theory Chapter12_4
imports "~~/src/HOL/IMP/VCG" "~~/src/HOL/IMP/Hoare_Examples"
begin

text{*
\exercise
Let @{term "asum i"} be the annotated command \texttt{y := 0; W}
where \texttt{W} is defined in Example~12.7. Prove
*}
(* your definition of asum here *)

lemma "\<turnstile> {\<lambda>s. s ''x'' = i} strip(asum i) {\<lambda>s. s ''y'' = sum i}"
(* your definition/proof here *)

text{*
with the help of corollary @{thm[source] vc_sound'}.
\endexercise

\exercise
Solve exercises \ref{exe:Hoare:sumeq} to \ref{exe:Hoare:sqrt} using the VCG:
for every Hoare triple @{prop"\<turnstile> {P} c {Q}"} from one of those exercises
define an annotated version @{text C} of @{text c} and prove
@{prop"\<turnstile> {P} strip C {Q}"} with the help of %Corollary~\ref{cor:vc_sound}
corollary @{thm[source] vc_sound'}.
*}

text{*
\endexercise

\exercise
Having two separate functions @{const pre} and @{const vc} is inefficient.
When computing @{const vc} one often needs to compute @{const pre} too,
leading to multiple traversals of many subcommands. Define an optimised function
*}
fun prevc :: "acom \<Rightarrow> assn \<Rightarrow> assn \<times> bool" where
(* your definition/proof here *)

text{* that traverses the command only once. Prove *}

lemma "prevc C Q = (pre C Q, vc C Q)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Design a VCG that computes post rather than preconditions.
Start by solving Exercise~\ref{exe:fwdassign}. Now modify theory
@{theory VCG} as follows. Instead of @{const pre} define a function
*}

fun post :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
(* your definition/proof here *)

text{*
such that (with the execption of loops) @{term "post C P"} is the strongest
postcondition of @{text C} w.r.t.\ the precondition @{text P} (see also
Exercise~\ref{exe:sp}). Now modify @{const vc} such that is uses
@{const post} instead of @{const pre} and prove its soundness
and completeness.
*}

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
(* your definition/proof here *)

lemma vc_sound: "vc C P \<Longrightarrow> \<turnstile> {P} strip C {post C P}"
(* your definition/proof here *)

lemma vc_complete: "\<turnstile> {P} c {Q}
  \<Longrightarrow> \<exists>C. strip C = c \<and> vc C P \<and> (\<forall>s. post C P s \<longrightarrow> Q s)"
(* your definition/proof here *)

text {*
\endexercise
*}

end


theory sort_NStoogeSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun third :: "Nat => Nat" where
"third (Z) = Z"
| "third (S (Z)) = Z"
| "third (S (S (Z))) = Z"
| "third (S (S (S n))) = S (third n)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) Pair2" where
"splitAt x y = Pair (take x y) (drop x y)"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function nstooge1sort2 :: "int list => int list"
         and nstoogesort :: "int list => int list"
         and nstooge1sort1 :: "int list => int list" where
"nstooge1sort2 x =
   case splitAt (third (length x)) (reverse x) of
     | Pair ys zs =>
         case splitAt (third (length x)) (reverse x) of
           | Pair xs zs2 => append (nstoogesort zs) (reverse xs)
         end
   end"
| "nstoogesort (Nil2) = Nil2"
| "nstoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nstoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "nstoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "nstooge1sort1 x =
     case splitAt (third (length x)) x of
       | Pair ys zs =>
           case splitAt (third (length x)) x of
             | Pair xs zs2 => append ys (nstoogesort zs2)
           end
     end"
by pat_completeness auto

(*hipster third
          take
          sort2
          length
          drop
          splitAt
          count
          append
          reverse
          nstooge1sort2
          nstoogesort
          nstooge1sort1 *)

theorem x0 :
  "!! (x :: int) (y :: int list) .
     (count x (nstoogesort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory week03B_demo_automation imports Main begin

definition
  xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor A B \<equiv> (A \<and> \<not>B) \<or> (\<not>A \<and> B)"

thm xor_def

lemma xorI [intro!]:
  "\<lbrakk> \<lbrakk>A; B\<rbrakk> \<Longrightarrow> False; \<not>B \<Longrightarrow> A \<rbrakk> \<Longrightarrow> xor A B"
  apply (unfold xor_def)
  apply blast
  done

lemma xorE [elim!]:
  "\<lbrakk> xor A B; \<lbrakk>A; \<not>B\<rbrakk> \<Longrightarrow> R; \<lbrakk>\<not>A; B\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply (unfold xor_def)
  apply blast
  done

lemma "xor A A = False" by blast

 (* declare xorE [elim!] *)

lemma "xor A B = xor B A" by blast

lemma "\<not>\<not>x \<longrightarrow> x"
  apply (rule impI)
  apply (rule ccontr)
  apply (erule notE)
  apply assumption

end


\<comment> \<open>Substitutionless First-Order Logic: A Formal Soundness Proof\<close>

theory Less imports Main begin

type_synonym proxy = \<open>unit list\<close>

type_synonym arity = proxy

type_synonym var = proxy

datatype form = Pre proxy arity | Eq var var | Neg form | Imp form form | Uni var form

primrec eval :: \<open>(var \<Rightarrow> 'a) \<Rightarrow> arity \<Rightarrow> 'a list\<close> where
  \<open>eval _ [] = []\<close> |
  \<open>eval e (_ # n) = e n # eval e n\<close>

primrec semantics :: \<open>(var \<Rightarrow> 'a) \<Rightarrow> (proxy \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool\<close> where
  \<open>semantics e g (Pre i n) = g i (eval e n)\<close> |
  \<open>semantics e g (Eq x y) = (e x = e y)\<close> |
  \<open>semantics e g (Neg p) = (\<not> semantics e g p)\<close> |
  \<open>semantics e g (Imp p q) = (semantics e g p \<longrightarrow> semantics e g q)\<close> |
  \<open>semantics e g (Uni x p) = (\<forall>t. semantics (e(x := t)) g p)\<close>

primrec no_occur_in :: \<open>var \<Rightarrow> form \<Rightarrow> bool\<close> where
  \<open>no_occur_in z (Pre _ n) = (length z \<ge> length n)\<close> |
  \<open>no_occur_in z (Eq x y) = (z \<noteq> x \<and> z \<noteq> y)\<close> |
  \<open>no_occur_in z (Neg p) = no_occur_in z p\<close> |
  \<open>no_occur_in z (Imp p q) = (no_occur_in z p \<and> no_occur_in z q)\<close> |
  \<open>no_occur_in z (Uni _ p) = no_occur_in z p\<close>

abbreviation \<open>fail \<equiv> Uni [] (Eq [] [])\<close>

inductive OK :: \<open>form \<Rightarrow> bool\<close> ("\<turnstile> _" 0) where
  \<open>\<turnstile> pq \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> case pq of Imp p' q \<Rightarrow> if p' = p then q else fail | _ \<Rightarrow> fail\<close> |
  \<open>\<turnstile> p \<Longrightarrow> \<turnstile> Uni x p\<close> |
  \<open>\<turnstile> Imp (Imp p q) (Imp (Imp q r) (Imp p r))\<close> |
  \<open>\<turnstile> Imp (Imp (Neg p) p) p\<close> |
  \<open>\<turnstile> Imp p (Imp (Neg p) q)\<close> |
  \<open>\<turnstile> Imp (Uni x (Imp p q)) (Imp (Uni x p) (Uni x q))\<close> |
  \<open>\<turnstile> if no_occur_in x p then Imp p (Uni x p) else fail\<close> |
  \<open>\<turnstile> Imp (Neg (Uni x p)) (Uni x (Neg (Uni x p)))\<close> |
  \<open>\<turnstile> Imp (Uni x (Uni y p)) (Uni y (Uni x p))\<close> |
  \<open>\<turnstile> Neg (Uni x (Neg (Eq x y)))\<close> |
  \<open>\<turnstile> Imp (Eq x y) (Imp (Eq x z) (Eq y z))\<close> |
  \<open>\<turnstile> if x \<noteq> y then Imp (Eq x y) (Imp p (Uni x (Imp (Eq x y) p))) else fail\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> semantics e g p\<close>
proof (induct arbitrary: e rule: OK.induct)
  case (1 pq) show ?case by (cases pq) (use 1 in auto)
next
  case 7
  have *: \<open>length x \<ge> length n \<Longrightarrow> eval e n = eval (e(x := t)) n\<close> for x n e and t :: 'a
    by (induct n) auto
  have \<open>no_occur_in x p \<Longrightarrow> semantics e g p = semantics (e(x := t)) g p\<close> for x p e g and t :: 'a
  proof (induct arbitrary: e)
    case Pre show ?case by (smt Pre * no_occur_in.simps semantics.simps)
  next
    case Uni show ?case by (smt Uni fun_upd_twist fun_upd_upd no_occur_in.simps semantics.simps)
  qed auto
  then show ?case by auto
next
  case 9 show ?case by (smt fun_upd_twist semantics.simps)
next
  case 12 show ?case by (smt fun_upd_same fun_upd_triv fun_upd_twist semantics.simps)
qed auto

end

\<comment> \<open>Andreas Halkjær From, John Bruntse Larsen, Anders Schlichtkrull & Jørgen Villadsen\<close>