(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, algorithms for iterators, min, max, to_sorted_list

*)

header {* \isaheader{Generic Algorithms for Sets} *}
theory SetGA
imports "../spec/SetSpec" SetIteratorCollectionsGA
begin
text_raw {*\label{thy:SetGA}*}

subsection {* Generic Set Algorithms *}

locale g_set_xx_defs_loc =
  s1!: StdSetDefs ops1 + s2!: StdSetDefs ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition "g_copy s \<equiv> s1.iterate s s2.ins_dj (s2.empty ())"
  definition "g_filter P s1 \<equiv> s1.iterate s1
    (\<lambda>x \<sigma>. if P x then s2.ins_dj x \<sigma> else \<sigma>)
    (s2.empty ())"

  definition "g_union s1 s2 \<equiv> s1.iterate s1 s2.ins s2"
  definition "g_diff s1 s2 \<equiv> s2.iterate s2 s1.delete s1"

  definition g_union_list where
    "g_union_list l =
      foldl (\<lambda>s s'. g_union s' s) (s2.empty ()) l"

  definition "g_union_dj s1 s2 \<equiv> s1.iterate s1 s2.ins_dj s2"

  definition "g_disjoint_witness s1 s2 \<equiv>
    s1.sel s1 (\<lambda>x. s2.memb x s2)"

  definition "g_disjoint s1 s2 \<equiv>
    s1.ball s1 (\<lambda>x. \<not>s2.memb x s2)"
end

locale g_set_xx_loc = g_set_xx_defs_loc ops1 ops2 +
  s1!: StdSet ops1 + s2!: StdSet ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  lemma g_copy_alt:
    "g_copy s = iterate_to_set s2.empty s2.ins_dj (s1.iteratei s)"
    unfolding iterate_to_set_alt_def g_copy_def ..

    have LIS:
      "set_ins_dj s2.\<alpha> s2.invar s2.ins_dj"
      "set_empty s2.\<alpha> s2.invar s2.empty"
      by unfold_locales

    from iterate_to_set_correct[OF LIS s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_copy_alt
      by simp_all
  qed

  lemma g_filter_impl: "set_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_filter"
  proof
    fix s P
    assume "s1.invar s"
    hence "s2.\<alpha> (g_filter P s) = {e \<in> s1.\<alpha> s. P e} \<and>
      s2.invar (g_filter P s)" (is "?G1 \<and> ?G2")
      unfolding g_filter_def
      apply (rule_tac I="\<lambda>it \<sigma>. s2.invar \<sigma> \<and> s2.\<alpha> \<sigma> = {e \<in> it. P e}"
        in s1.iterate_rule_insert_P)
      by (auto simp add: s2.empty_correct s2.ins_dj_correct)
    thus ?G1 ?G2 by auto
  qed

  lemma g_union_alt:
    "g_union s1 s2 = iterate_add_to_set s2 s2.ins (s1.iteratei s1)"
    unfolding iterate_add_to_set_def g_union_def ..

  lemma g_diff_alt:
    "g_diff s1 s2 = iterate_diff_set s1 s1.delete (s2.iteratei s2)"
    unfolding g_diff_def iterate_diff_set_def ..

  lemma g_union_impl:
    "set_union s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union"
  proof -
    have LIS: "set_ins s2.\<alpha> s2.invar s2.ins" by unfold_locales
    from iterate_add_to_set_correct[OF LIS _ s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_union_alt
      by simp_all
  qed

  lemma g_diff_impl:
    "set_diff s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_diff"
  proof -
    have LIS: "set_delete s1.\<alpha> s1.invar s1.delete" by unfold_locales
    from iterate_diff_correct[OF LIS _ s2.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_diff_alt
      by simp_all
  qed

  lemma g_union_list_impl:
    shows "set_union_list s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_union_list"
  proof
    fix l
    note correct = s2.empty_correct set_union.union_correct[OF g_union_impl]

    assume "\<forall>s1\<in>set l. s1.invar s1"
    hence aux: "\<And>s. s2.invar s \<Longrightarrow>
           s2.\<alpha> (foldl (\<lambda>s s'. g_union s' s) s l)
           = \<Union>{s1.\<alpha> s1 |s1. s1 \<in> set l} \<union> s2.\<alpha> s \<and>
           s2.invar (foldl (\<lambda>s s'. g_union s' s) s l)"
      by (induct l) (auto simp add: correct)

    from aux [of "s2.empty ()"]
    show "s2.\<alpha> (g_union_list l) = \<Union>{s1.\<alpha> s1 |s1. s1 \<in> set l}"
         "s2.invar (g_union_list l)"
      unfolding g_union_list_def
      by (simp_all add: correct)
  qed

  lemma g_union_dj_impl:
    "set_union_dj s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union_dj"
  proof
    fix s1 s2
    assume I:
      "s1.invar s1"
      "s2.invar s2"
    assume DJ: "s1.\<alpha> s1 \<inter> s2.\<alpha> s2 = {}"

    have "s2.\<alpha> (g_union_dj s1 s2)
      = s1.\<alpha> s1 \<union> s2.\<alpha> s2
      \<and> s2.invar (g_union_dj s1 s2)" (is "?G1 \<and> ?G2")
      unfolding g_union_dj_def

      apply (rule_tac I="\<lambda>it \<sigma>. s2.invar \<sigma> \<and> s2.\<alpha> \<sigma> = it \<union> s2.\<alpha> s2"
        in s1.iterate_rule_insert_P)
      using DJ
      apply (simp_all add: I)
      apply (subgoal_tac "x\<notin>s2.\<alpha> \<sigma>")
      apply (simp add: s2.ins_dj_correct I)
      apply auto
      done
    thus ?G1 ?G2 by auto
  qed

  lemma g_disjoint_witness_impl:
    "set_disjoint_witness s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint_witness"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_witness_def
      by (auto dest: s1.sel'_noneD s1.sel'_someD simp: s2.memb_correct)
  qed

  lemma g_disjoint_impl:
    "set_disjoint s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: s2.memb_correct s1.ball_correct)
  qed
end

sublocale g_set_xx_loc <
  set_copy s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_copy by (rule g_copy_impl)

sublocale g_set_xx_loc <
  set_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_filter by (rule g_filter_impl)

sublocale g_set_xx_loc <
  set_union s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union
  by (rule g_union_impl)

sublocale g_set_xx_loc <
  set_union_dj s1.\<alpha> s1.invar s2.\<alpha> s2.invar s2.\<alpha> s2.invar g_union_dj
  by (rule g_union_dj_impl)

sublocale g_set_xx_loc <
  set_diff s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_diff
  by (rule g_diff_impl)

sublocale g_set_xx_loc <
  set_disjoint_witness s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint_witness
  by (rule g_disjoint_witness_impl)

sublocale g_set_xx_loc <
  set_disjoint s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_disjoint by (rule g_disjoint_impl)

(*sublocale StdBasicSetDefs < g_set_xx!: g_set_xx_defs_loc ops ops .
sublocale StdBasicSet < g_set_xx!: g_set_xx_loc ops ops
  by unfold_locales
*)

locale g_set_xxx_defs_loc =
  s1!: StdSetDefs ops1 +
  s2!: StdSetDefs ops2 +
  s3!: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  definition "g_inter s1 s2 \<equiv>
    s1.iterate s1 (\<lambda>x s. if s2.memb x s2 then s3.ins_dj x s else s)
      (s3.empty ())"
end

locale g_set_xxx_loc = g_set_xxx_defs_loc ops1 ops2 ops3 +
  s1!: StdSet ops1 +
  s2!: StdSet ops2 +
  s3!: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  lemma g_inter_impl: "set_inter s1.\<alpha> s1.invar s2.\<alpha> s2.invar s3.\<alpha> s3.invar
    g_inter"
  proof
    fix s1 s2
    assume I:
      "s1.invar s1"
      "s2.invar s2"
    have "s3.\<alpha> (g_inter s1 s2) = s1.\<alpha> s1 \<inter> s2.\<alpha> s2 \<and> s3.invar (g_inter s1 s2)"
      unfolding g_inter_def
      apply (rule_tac I="\<lambda>it \<sigma>. s3.\<alpha> \<sigma> = it \<inter> s2.\<alpha> s2 \<and> s3.invar \<sigma>"
        in s1.iterate_rule_insert_P)
      apply (simp_all add: I s3.empty_correct s3.ins_dj_correct s2.memb_correct)
      done
    thus "s3.\<alpha> (g_inter s1 s2) = s1.\<alpha> s1 \<inter> s2.\<alpha> s2"
      and "s3.invar (g_inter s1 s2)" by auto
  qed
end

sublocale g_set_xxx_loc
  < set_inter s1.\<alpha> s1.invar s2.\<alpha> s2.invar s3.\<alpha> s3.invar g_inter
  by (rule g_inter_impl)

(*sublocale StdBasicSetDefs < g_set_xxx!: g_set_xxx_defs_loc ops ops ops .
sublocale StdBasicSet < g_set_xxx!: g_set_xxx_loc ops ops ops
  by unfold_locales
*)

locale g_set_xy_defs_loc =
  s1!: StdSet ops1 + s2!: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  definition "g_image_filter f s \<equiv>
    s1.iterate s
      (\<lambda>x res. case f x of Some v \<Rightarrow> s2.ins v res | _ \<Rightarrow> res)
      (s2.empty ())"

  definition "g_image f s \<equiv>
    s1.iterate s (\<lambda>x res. s2.ins (f x) res) (s2.empty ())"

  definition "g_inj_image_filter f s \<equiv>
    s1.iterate s
      (\<lambda>x res. case f x of Some v \<Rightarrow> s2.ins_dj v res | _ \<Rightarrow> res)
      (s2.empty ())"

  definition "g_inj_image f s \<equiv>
    s1.iterate s (\<lambda>x res. s2.ins_dj (f x) res) (s2.empty ())"

end

locale g_set_xy_loc = g_set_xy_defs_loc ops1 ops2 +
  s1!: StdSet ops1 + s2!: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  lemma g_image_filter_impl:
    "set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image_filter"
  proof
    fix f s
    assume I: "s1.invar s"
    have A: "g_image_filter f s ==
         iterate_to_set s2.empty s2.ins
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_image_filter_def
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp

    have ins: "set_ins s2.\<alpha> s2.invar s2.ins"
      and emp: "set_empty s2.\<alpha> s2.invar s2.empty" by unfold_locales

    from iterate_image_filter_to_set_correct[OF ins emp s1.iteratei_correct]
    show "s2.\<alpha> (g_image_filter f s) =
          {b. \<exists>a\<in>s1.\<alpha> s. f a = Some b}"
         "s2.invar (g_image_filter f s)"
      unfolding A using I by auto
  qed

  lemma g_image_alt: "g_image f s = g_image_filter (Some o f) s"
    unfolding g_image_def g_image_filter_def
    by auto

  lemma g_image_impl: "set_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image"
  proof -
    interpret set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_image_filter
      by (rule g_image_filter_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_image_alt
      by (auto simp add: image_filter_correct)
  qed

  lemma g_inj_image_filter_impl:
    "set_inj_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image_filter"
  proof
    fix f::"'x1 \<rightharpoonup> 'x2" and s
    assume I: "s1.invar s" and INJ: "inj_on f (s1.\<alpha> s \<inter> dom f)"
    have A: "g_inj_image_filter f s ==
         iterate_to_set s2.empty s2.ins_dj
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_inj_image_filter_def
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp

    have ins_dj: "set_ins_dj s2.\<alpha> s2.invar s2.ins_dj"
      and emp: "set_empty s2.\<alpha> s2.invar s2.empty" by unfold_locales

    from set_iterator_image_filter_correct[OF s1.iteratei_correct[OF I] INJ]
    have iti_s1_filter: "set_iterator
      (set_iterator_image_filter f (s1.iteratei s))
      {y. \<exists>x. x \<in> s1.\<alpha> s \<and> f x = Some y}"
      by simp

    from iterate_to_set_correct[OF ins_dj emp, OF iti_s1_filter]
    show "s2.\<alpha> (g_inj_image_filter f s) =
          {b. \<exists>a\<in>s1.\<alpha> s. f a = Some b}"
         "s2.invar (g_inj_image_filter f s)"
      unfolding A by auto
  qed

  lemma g_inj_image_alt: "g_inj_image f s = g_inj_image_filter (Some o f) s"
    unfolding g_inj_image_def g_inj_image_filter_def
    by auto

  lemma g_inj_image_impl:
    "set_inj_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image"
  proof -
    interpret set_inj_image_filter
      s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_inj_image_filter
      by (rule g_inj_image_filter_impl)

    have AUX: "\<And>S f. inj_on f S \<Longrightarrow> inj_on (Some \<circ> f) (S \<inter> dom (Some \<circ> f))"
      by (auto intro!: inj_onI dest: inj_onD)

    show ?thesis
      apply unfold_locales
      unfolding g_inj_image_alt
      by (auto simp add: inj_image_filter_correct AUX)

  qed

end

sublocale g_set_xy_loc < set_image_filter s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_image_filter by (rule g_image_filter_impl)

sublocale g_set_xy_loc < set_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_image by (rule g_image_impl)

sublocale g_set_xy_loc < set_inj_image s1.\<alpha> s1.invar s2.\<alpha> s2.invar
  g_inj_image by (rule g_inj_image_impl)

locale g_set_xyy_defs_loc =
  s0!: StdSetDefs ops0 +
  g_set_xx_defs_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition g_Union_image
    :: "('x0 \<Rightarrow> 's1) \<Rightarrow> 's0 \<Rightarrow> 's2"
    where "g_Union_image f S
    == s0.iterate S (\<lambda>x res. g_union (f x) res) (s2.empty ())"
end

locale g_set_xyy_loc = g_set_xyy_defs_loc ops0 ops1 ops2 +
  s0!: StdSet ops0 +
  g_set_xx_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin

  lemma g_Union_image_impl:
    "set_Union_image s0.\<alpha> s0.invar s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_Union_image"
  proof -
    {
      fix s f
      have "\<lbrakk>s0.invar s; \<And>x. x \<in> s0.\<alpha> s \<Longrightarrow> s1.invar (f x)\<rbrakk> \<Longrightarrow>
        s2.\<alpha> (g_Union_image f s) = \<Union>(s1.\<alpha> ` f ` s0.\<alpha> s)
        \<and> s2.invar (g_Union_image f s)"
        apply (unfold g_Union_image_def)
        apply (rule_tac I="\<lambda>it res. s2.invar res
          \<and> s2.\<alpha> res = \<Union>(s1.\<alpha>`f`(s0.\<alpha> s - it))" in s0.iterate_rule_P)
        apply (fastforce simp add: s2.empty_correct union_correct)+
        done
    }
    thus ?thesis
      apply unfold_locales
      apply auto
      done
  qed
end

sublocale g_set_xyy_loc <
  set_Union_image s0.\<alpha> s0.invar s1.\<alpha> s1.invar s2.\<alpha> s2.invar g_Union_image
  by (rule g_Union_image_impl)

subsection {* Default Set Operations*}

record ('x,'s) set_basic_ops =
  bset_op_\<alpha> :: "'s \<Rightarrow> 'x set"
  bset_op_invar :: "'s \<Rightarrow> bool"
  bset_op_empty :: "unit \<Rightarrow> 's"
  bset_op_memb :: "'x \<Rightarrow> 's \<Rightarrow> bool"
  bset_op_ins :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_ins_dj :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_delete :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  bset_op_list_it :: "('x,'s) set_list_it"

record ('x,'s) oset_basic_ops = "('x::linorder,'s) set_basic_ops" +
  bset_op_ordered_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
  bset_op_rev_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"

locale StdBasicSetDefs =
  poly_set_iteratei_defs "bset_op_list_it ops"
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == bset_op_\<alpha> ops"
  abbreviation invar where "invar == bset_op_invar ops"
  abbreviation empty where "empty == bset_op_empty ops"
  abbreviation memb where "memb == bset_op_memb ops"
  abbreviation ins where "ins == bset_op_ins ops"
  abbreviation ins_dj where "ins_dj == bset_op_ins_dj ops"
  abbreviation delete where "delete == bset_op_delete ops"
  abbreviation list_it where "list_it \<equiv> bset_op_list_it ops"
end

locale StdBasicOSetDefs = StdBasicSetDefs ops
  + poly_set_iterateoi_defs "bset_op_ordered_list_it ops"
  + poly_set_rev_iterateoi_defs "bset_op_rev_list_it ops"
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
  abbreviation "ordered_list_it \<equiv> bset_op_ordered_list_it ops"
  abbreviation "rev_list_it \<equiv> bset_op_rev_list_it ops"
end

locale StdBasicSet = StdBasicSetDefs ops +
  set \<alpha> invar +
  set_empty \<alpha> invar empty +
  set_memb \<alpha> invar memb +
  set_ins \<alpha> invar ins +
  set_ins_dj \<alpha> invar ins_dj +
  set_delete \<alpha> invar delete +
  poly_set_iteratei \<alpha> invar list_it
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin

  lemmas correct[simp] =
    empty_correct
    memb_correct
    ins_correct
    ins_dj_correct
    delete_correct

end

locale StdBasicOSet =
  StdBasicOSetDefs ops +
  StdBasicSet ops +
  poly_set_iterateoi \<alpha> invar ordered_list_it +
  poly_set_rev_iterateoi \<alpha> invar rev_list_it
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
end

context StdBasicSetDefs
begin
  definition "g_sng x \<equiv> ins x (empty ())"
  definition "g_isEmpty s \<equiv> iteratei s (\<lambda>c. c) (\<lambda>_ _. False) True"
  definition "g_sel' s P \<equiv> iteratei s (op = None)
    (\<lambda>x _. if P x then Some x else None) None"

  definition "g_ball s P \<equiv> iteratei s (\<lambda>c. c) (\<lambda>x \<sigma>. P x) True"
  definition "g_bex s P \<equiv> iteratei s (\<lambda>c. \<not>c) (\<lambda>x \<sigma>. P x) False"
  definition "g_size s \<equiv> iteratei s (\<lambda>_. True) (\<lambda>x n . Suc n) 0"
  definition "g_size_abort m s \<equiv> iteratei s (\<lambda>\<sigma>. \<sigma> < m) (\<lambda>x. Suc) 0"
  definition "g_isSng s \<equiv> (iteratei s (\<lambda>\<sigma>. \<sigma> < 2) (\<lambda>x. Suc) 0 = 1)"

  definition "g_union s1 s2 \<equiv> iterate s1 ins s2"
  definition "g_diff s1 s2 \<equiv> iterate s2 delete s1"

  definition "g_subset s1 s2 \<equiv> g_ball s1 (\<lambda>x. memb x s2)"

  definition "g_equal s1 s2 \<equiv> g_subset s1 s2 \<and> g_subset s2 s1"

  definition "g_to_list s \<equiv> iterate s (op #) []"

  fun g_from_list_aux where
    "g_from_list_aux accs [] = accs" |
    "g_from_list_aux accs (x#l) = g_from_list_aux (ins x accs) l"
    -- {* Tail recursive version *}

  definition "g_from_list l == g_from_list_aux (empty ()) l"

  definition "g_inter s1 s2 \<equiv>
    iterate s1 (\<lambda>x s. if memb x s2 then ins_dj x s else s)
      (empty ())"

  definition "g_union_dj s1 s2 \<equiv> iterate s1 ins_dj s2"
  definition "g_filter P s \<equiv> iterate s
    (\<lambda>x \<sigma>. if P x then ins_dj x \<sigma> else \<sigma>)
    (empty ())"

  definition "g_disjoint_witness s1 s2 \<equiv> g_sel' s1 (\<lambda>x. memb x s2)"
  definition "g_disjoint s1 s2 \<equiv> g_ball s1 (\<lambda>x. \<not>memb x s2)"

  definition dflt_ops
    where [icf_rec_def]: "dflt_ops \<equiv> \<lparr>
      set_op_\<alpha> = \<alpha>,
      set_op_invar = invar,
      set_op_empty = empty,
      set_op_memb = memb,
      set_op_ins = ins,
      set_op_ins_dj = ins_dj,
      set_op_delete = delete,
      set_op_list_it = list_it,
      set_op_sng = g_sng ,
      set_op_isEmpty = g_isEmpty ,
      set_op_isSng = g_isSng ,
      set_op_ball = g_ball ,
      set_op_bex = g_bex ,
      set_op_size = g_size ,
      set_op_size_abort = g_size_abort ,
      set_op_union = g_union ,
      set_op_union_dj = g_union_dj ,
      set_op_diff = g_diff ,
      set_op_filter = g_filter ,
      set_op_inter = g_inter ,
      set_op_subset = g_subset ,
      set_op_equal = g_equal ,
      set_op_disjoint = g_disjoint ,
      set_op_disjoint_witness = g_disjoint_witness ,
      set_op_sel = g_sel' ,
      set_op_to_list = g_to_list ,
      set_op_from_list = g_from_list
    \<rparr>"

  local_setup {* Locale_Code.lc_decl_del @{term dflt_ops} *}
end

context StdBasicSet
begin

  lemma g_ins_dj_impl: "set_ins_dj \<alpha> invar ins"
    by unfold_locales (auto simp: ins_correct)

  lemma g_isEmpty_impl: "set_isEmpty \<alpha> invar g_isEmpty"
  proof
    fix s assume I: "invar s"
    have A: "g_isEmpty s = iterate_is_empty (iteratei s)"
      unfolding g_isEmpty_def iterate_is_empty_def ..
    from iterate_is_empty_correct[OF iteratei_correct[OF I]]
    show "g_isEmpty s \<longleftrightarrow> \<alpha> s = {}" unfolding A .
  qed

  lemma g_sel'_impl: "set_sel' \<alpha> invar g_sel'"
  proof -
    have A: "\<And>s P. g_sel' s P = iterate_sel_no_map (iteratei s) P"
      unfolding g_sel'_def iterate_sel_no_map_alt_def
      apply (rule arg_cong[where f="iteratei", THEN cong, THEN cong, THEN cong])
      by auto

    show ?thesis
      unfolding set_sel'_def A
      using iterate_sel_no_map_correct[OF iteratei_correct]
      apply (simp add: Bex_def Ball_def)
      apply (metis option.exhaust)
      done
  qed

  lemma g_ball_alt: "g_ball s P = iterate_ball (iteratei s) P"
    unfolding g_ball_def iterate_ball_def by (simp add: id_def)
  lemma g_bex_alt: "g_bex s P = iterate_bex (iteratei s) P"
    unfolding g_bex_def iterate_bex_def ..

  lemma g_bex_impl: "set_bex \<alpha> invar g_bex"
    apply unfold_locales
    unfolding g_bex_alt
    apply (rule iterate_bex_correct)
    by (rule iteratei_correct)

  lemma g_size_alt: "g_size s = iterate_size (iteratei s)"
    unfolding g_size_def iterate_size_def ..
  lemma g_size_abort_alt: "g_size_abort m s = iterate_size_abort (iteratei s) m"
    unfolding g_size_abort_def iterate_size_abort_def ..

  lemma g_size_impl: "set_size \<alpha> invar g_size"
    apply unfold_locales
    unfolding g_size_alt
    apply (rule conjunct1[OF iterate_size_correct])
    by (rule iteratei_correct)

  lemma g_size_abort_impl: "set_size_abort \<alpha> invar g_size_abort"
    apply unfold_locales
    unfolding g_size_abort_alt
    apply (rule conjunct1[OF iterate_size_abort_correct])
    by (rule iteratei_correct)

  lemma g_isSng_alt: "g_isSng s = iterate_is_sng (iteratei s)"
    unfolding g_isSng_def iterate_is_sng_def iterate_size_abort_def ..

  lemma g_isSng_impl: "set_isSng \<alpha> invar g_isSng"
    apply unfold_locales
    unfolding g_isSng_alt
    apply (drule iterate_is_sng_correct[OF iteratei_correct])
    apply (simp add: card_Suc_eq)
    done

  lemma g_union_impl: "set_union \<alpha> invar \<alpha> invar \<alpha> invar g_union"
    unfolding g_union_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P, simp_all)+
    done

  lemma g_diff_impl: "set_diff \<alpha> invar \<alpha> invar g_diff"
    unfolding g_diff_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = \<alpha> s1 - it"
      in iterate_rule_insert_P, auto)+
    done

  lemma g_subset_impl: "set_subset \<alpha> invar \<alpha> invar g_subset"
  proof -
    interpret set_ball \<alpha> invar g_ball by (rule g_ball_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_subset_def
      by (auto simp add: ball_correct memb_correct)
  qed

  lemma g_equal_impl: "set_equal \<alpha> invar \<alpha> invar g_equal"
  proof -
    interpret set_subset \<alpha> invar \<alpha> invar g_subset by (rule g_subset_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_equal_def
      by (auto simp add: subset_correct)
  qed

  lemma g_to_list_impl: "set_to_list \<alpha> invar g_to_list"
  proof
    fix s
    assume I: "invar s"
    have A: "g_to_list s = iterate_to_list (iteratei s)"
      unfolding g_to_list_def iterate_to_list_def ..

    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    show "set (g_to_list s) = \<alpha> s" and "distinct (g_to_list s)"
      unfolding A
      by auto
  qed

  lemma g_from_list_impl: "list_to_set \<alpha> invar g_from_list"
  proof -
    { -- "Show a generalized lemma"
      fix l accs
      have "invar accs \<Longrightarrow> \<alpha> (g_from_list_aux accs l) = set l \<union> \<alpha> accs
            \<and> invar (g_from_list_aux accs l)"
        by (induct l arbitrary: accs)
           (auto simp add: ins_correct)
    } thus ?thesis
      apply (unfold_locales)
      apply (unfold g_from_list_def)
      apply (auto simp add: empty_correct)
      done
  qed

  lemma g_inter_impl: "set_inter \<alpha> invar \<alpha> invar \<alpha> invar g_inter"
    unfolding g_inter_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> \<alpha> s2"
      in iterate_rule_insert_P, auto) []
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> \<alpha> s2"
      in iterate_rule_insert_P, auto)
    done

  lemma g_union_dj_impl: "set_union_dj \<alpha> invar \<alpha> invar \<alpha> invar g_union_dj"
    unfolding g_union_dj_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "x\<notin>\<alpha> \<sigma>")
    apply simp
    apply blast
    apply simp
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<union> \<alpha> s2"
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "x\<notin>\<alpha> \<sigma>")
    apply simp
    apply blast
    apply simp
    done

  lemma g_filter_impl: "set_filter \<alpha> invar \<alpha> invar g_filter"
    unfolding g_filter_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> Collect P"
      in iterate_rule_insert_P, auto)
    apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma> \<and> \<alpha> \<sigma> = it \<inter> Collect P"
      in iterate_rule_insert_P, auto)
    done

  lemma g_disjoint_witness_impl: "set_disjoint_witness
    \<alpha> invar \<alpha> invar g_disjoint_witness"
  proof -
    interpret set_sel' \<alpha> invar g_sel' by (rule g_sel'_impl)
    show ?thesis
      unfolding g_disjoint_witness_def[abs_def]
      apply unfold_locales
      by (auto dest: sel'_noneD sel'_someD simp: memb_correct)
  qed

  lemma g_disjoint_impl: "set_disjoint
    \<alpha> invar \<alpha> invar g_disjoint"
  proof -
    interpret set_ball \<alpha> invar g_ball by (rule g_ball_impl)
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: memb_correct ball_correct)
  qed

end

context StdBasicSet
begin

context StdBasicOSetDefs
begin
  definition "g_min s P \<equiv> iterateoi s (\<lambda>x. x = None)
    (\<lambda>x _. if P x then Some x else None) None"
  definition "g_max s P \<equiv> rev_iterateoi s (\<lambda>x. x = None)
    (\<lambda>x _. if P x then Some x else None) None"

  definition "g_to_sorted_list s \<equiv> rev_iterateo s (op #) []"
  definition "g_to_rev_list s \<equiv> iterateo s (op #) []"

  definition dflt_oops :: "('x::linorder,'s) oset_ops"
    where [icf_rec_def]:
    "dflt_oops \<equiv> set_ops.extend
      dflt_ops
      \<lparr>
        set_op_ordered_list_it = ordered_list_it,
        set_op_rev_list_it = rev_list_it,
        set_op_min = g_min,
        set_op_max = g_max,
        set_op_to_sorted_list = g_to_sorted_list,
        set_op_to_rev_list = g_to_rev_list
      \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term dflt_oops} *}

end

context StdBasicOSet
begin
  lemma g_min_impl: "set_min \<alpha> invar g_min"
  proof
    fix s P

    assume I: "invar s"

    from iterateoi_correct[OF I]
    have iti': "set_iterator_linord (iterateoi s) (\<alpha> s)" by simp
    note sel_correct = iterate_sel_no_map_linord_correct[OF iti', of P]

    have A: "g_min s P = iterate_sel_no_map (iterateoi s) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix x
      assume "x\<in>\<alpha> s" "P x"
      with sel_correct
      show "g_min s P \<in> Some ` {x\<in>\<alpha> s. P x}" and "the (g_min s P) \<le> x"
        unfolding A by auto
    }

    { assume "{x\<in>\<alpha> s. P x} = {}"
       with sel_correct show "g_min s P = None"
        unfolding A by auto
    }
  qed

  lemma g_max_impl: "set_max \<alpha> invar g_max"
  proof
    fix s P

    assume I: "invar s"

    from rev_iterateoi_correct[OF I]
    have iti': "set_iterator_rev_linord (rev_iterateoi s) (\<alpha> s)" by simp
    note sel_correct = iterate_sel_no_map_rev_linord_correct[OF iti', of P]

    have A: "g_max s P = iterate_sel_no_map (rev_iterateoi s) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix x
      assume "x\<in>\<alpha> s" "P x"
      with sel_correct
      show "g_max s P \<in> Some ` {x\<in>\<alpha> s. P x}" and "the (g_max s P) \<ge> x"
        unfolding A by auto
    }

    { assume "{x\<in>\<alpha> s. P x} = {}"
       with sel_correct show "g_max s P = None"
        unfolding A by auto
    }
  qed

  lemma g_to_sorted_list_impl: "set_to_sorted_list \<alpha> invar g_to_sorted_list"
  proof
    fix s
    assume I: "invar s"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_rev_linord_correct[OF iti]
    show "sorted (g_to_sorted_list s)"
         "distinct (g_to_sorted_list s)"
         "set (g_to_sorted_list s) = \<alpha> s"
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "set_to_rev_list \<alpha> invar g_to_rev_list"
  proof
    fix s
    assume I: "invar s"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_linord_correct[OF iti]
    show "sorted (rev (g_to_rev_list s))"
         "distinct (g_to_rev_list s)"
         "set (g_to_rev_list s) = \<alpha> s"
      unfolding g_to_rev_list_def iterate_to_list_def
      by (simp_all)
  qed

  lemma dflt_oops_impl: "StdOSet dflt_oops"
  proof -
    interpret aux!: StdSet dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOSet_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

subsection "More Generic Set Algorithms"
text {*
  These algorithms do not have a function specification in a locale, but
  their specification is done  ad-hoc in the correctness lemma.
*}

subsubsection "Image and Filter of Cartesian Product"

locale image_filter_cp_defs_loc =
  s1!: StdSetDefs ops1 +
  s2!: StdSetDefs ops2 +
  s3!: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (\<lambda>x res.
      s2.iterate s2 (\<lambda>y res.
        case (f (x, y)) of
          None \<Rightarrow> res
        | Some z \<Rightarrow> (s3.ins z res)
      ) res
    ) (s3.empty ())"

  lemma image_filter_cartesian_product_alt:
    "image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2)))"
    unfolding image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def
    by simp

  definition image_filter_cp where
    "image_filter_cp f P s1 s2 \<equiv>
     image_filter_cartesian_product
      (\<lambda>xy. if P xy then Some (f xy) else None) s1 s2"

end

locale image_filter_cp_loc = image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1!: StdSet ops1 +
  s2!: StdSet ops2 +
  s3!: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma image_filter_cartesian_product_correct:
    fixes f :: "'x \<times> 'y \<rightharpoonup> 'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.\<alpha> (image_filter_cartesian_product f s1 s2)
     = { z | x y z. f (x,y) = Some z \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator
        (set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2))
        (s1.\<alpha> s1 \<times> s2.\<alpha> s2)"
        by simp

      have LIS:
        "set_ins s3.\<alpha> s3.invar s3.ins"
        "set_empty s3.\<alpha> s3.invar s3.empty"
        by unfold_locales

      from iterate_image_filter_to_set_correct[OF LIS it_s12, of f]
      show ?T1 ?T2
        unfolding image_filter_cartesian_product_alt by auto
  qed

  lemma image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    shows
    "s3.\<alpha> (image_filter_cp f P s1 s2)
     = { f (x, y) | x y. P (x, y) \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    from image_filter_cartesian_product_correct [OF I]
    show "?T1" "?T2"
      unfolding image_filter_cp_def
      by auto
  qed

end

locale inj_image_filter_cp_defs_loc =
  s1!: StdSetDefs ops1 +
  s2!: StdSetDefs ops2 +
  s3!: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "inj_image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (\<lambda>x res.
      s2.iterate s2 (\<lambda>y res.
        case (f (x, y)) of
          None \<Rightarrow> res
        | Some z \<Rightarrow> (s3.ins_dj z res)
      ) res
    ) (s3.empty ())"

  lemma inj_image_filter_cartesian_product_alt:
    "inj_image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins_dj (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2)))"
    unfolding inj_image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def
    by simp

  definition inj_image_filter_cp where
    "inj_image_filter_cp f P s1 s2 \<equiv>
     inj_image_filter_cartesian_product
      (\<lambda>xy. if P xy then Some (f xy) else None) s1 s2"

end

locale inj_image_filter_cp_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1!: StdSet ops1 +
  s2!: StdSet ops2 +
  s3!: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma inj_image_filter_cartesian_product_correct:
    fixes f :: "'x \<times> 'y \<rightharpoonup> 'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f (s1.\<alpha> s1 \<times> s2.\<alpha> s2 \<inter> dom f)"
    shows "s3.\<alpha> (inj_image_filter_cartesian_product f s1 s2)
     = { z | x y z. f (x,y) = Some z \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator
        (set_iterator_product (s1.iteratei s1) (\<lambda>_. s2.iteratei s2))
        (s1.\<alpha> s1 \<times> s2.\<alpha> s2)"
        by simp

      have LIS:
        "set_ins_dj s3.\<alpha> s3.invar s3.ins_dj"
        "set_empty s3.\<alpha> s3.invar s3.empty"
        by unfold_locales

      from iterate_inj_image_filter_to_set_correct[OF LIS it_s12 INJ]
      show ?T1 ?T2
        unfolding inj_image_filter_cartesian_product_alt by auto
  qed

  lemma inj_image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f {x\<in>s1.\<alpha> s1 \<times> s2.\<alpha> s2. P x}"
    shows
    "s3.\<alpha> (inj_image_filter_cp f P s1 s2)
     = { f (x, y) | x y. P (x, y) \<and> x\<in>s1.\<alpha> s1 \<and> y\<in>s2.\<alpha> s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    let ?f = "\<lambda>xy. if P xy then Some (f xy) else None"
    from INJ have INJ': "inj_on ?f (s1.\<alpha> s1 \<times> s2.\<alpha> s2 \<inter> dom ?f)"
      by (force intro!: inj_onI dest: inj_onD split: split_if_asm)

    from inj_image_filter_cartesian_product_correct [OF I INJ']
    show "?T1" "?T2"
      unfolding inj_image_filter_cp_def
      by auto
  qed

end

subsubsection "Cartesian Product"

locale cart_defs_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x\<times>'y,'s3,'more3) set_ops_scheme"
begin

  definition "cart s1 s2 \<equiv>
    s1.iterate s1
      (\<lambda>x. s2.iterate s2 (\<lambda>y res. s3.ins_dj (x,y) res))
      (s3.empty ())"

  lemma cart_alt: "cart s1 s2 ==
    inj_image_filter_cartesian_product Some s1 s2"
    unfolding cart_def inj_image_filter_cartesian_product_def
    by simp

end

locale cart_loc = cart_defs_loc ops1 ops2 ops3
  + inj_image_filter_cp_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x\<times>'y,'s3,'more3) set_ops_scheme"
begin

  lemma cart_correct:
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.\<alpha> (cart s1 s2)
           = s1.\<alpha> s1 \<times> s2.\<alpha> s2" (is ?T1)
    "s3.invar (cart s1 s2)" (is ?T2)
    unfolding cart_alt
    by (auto simp add:
      inj_image_filter_cartesian_product_correct[OF I, where f=Some])

end

subsection {* Generic Algorithms outside basic-set *}
text {*
  In this section, we present some generic algorithms that are not
  formulated in terms of basic-set. They are useful for setting up
  some data structures.
*}

subsection {* Image (by image-filter) *}
definition "iflt_image iflt f s == iflt (\<lambda>x. Some (f x)) s"

lemma iflt_image_correct:
  assumes "set_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_image \<alpha>1 invar1 \<alpha>2 invar2 (iflt_image iflt)"
proof -
  interpret set_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact
  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def)
    apply (auto simp add: image_filter_correct)
    done
qed

subsection{* Injective Image-Filter (by image-filter)*}

definition [code_unfold]: "iflt_inj_image = iflt_image"

lemma iflt_inj_image_correct:
  assumes "set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_inj_image \<alpha>1 invar1 \<alpha>2 invar2 (iflt_inj_image iflt)"
proof -
  interpret set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact

  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def iflt_inj_image_def)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    done
qed

subsection{* Filter (by image-filter)*}
definition "iflt_filter iflt P s == iflt (\<lambda>x. if P x then Some x else None) s"

lemma iflt_filter_correct:
  fixes \<alpha>1 :: "'s1 \<Rightarrow> 'a set"
  fixes \<alpha>2 :: "'s2 \<Rightarrow> 'a set"
  assumes "set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt"
  shows "set_filter \<alpha>1 invar1 \<alpha>2 invar2 (iflt_filter iflt)"
proof (rule set_filter.intro)
  fix s P
  assume invar_s: "invar1 s"
  interpret S: set_inj_image_filter \<alpha>1 invar1 \<alpha>2 invar2 iflt by fact

  let ?f' = "\<lambda>x::'a. if P x then Some x else None"
  have inj_f': "inj_on ?f' (\<alpha>1 s \<inter> dom ?f')"
    by (simp add: inj_on_def Ball_def domIff)
  note correct' = S.inj_image_filter_correct [OF invar_s inj_f',
    folded iflt_filter_def]

  show "invar2 (iflt_filter iflt P s)"
       "\<alpha>2 (iflt_filter iflt P s) = {e \<in> \<alpha>1 s. P e}"
    by (auto simp add: correct')
qed

end


section \<open>Asymptotic real interval arithmetic\<close>
(*
  File:     Multiseries_Expansion_Bounds.thy
  Author:   Manuel Eberl, TU München

  Automatic computation of upper and lower expansions for real-valued functions.
  Allows limited handling of functions involving oscillating functions like sin, cos, floor, etc.
*)
theory Multiseries_Expansion_Bounds
imports
  Multiseries_Expansion
begin

lemma expands_to_cong_reverse:
  "eventually (\<lambda>x. f x = g x) at_top \<Longrightarrow> (g expands_to F) bs \<Longrightarrow> (f expands_to F) bs"
  using expands_to_cong[of g F bs f] by (simp add: eq_commute)

lemma expands_to_trivial_bounds: "(f expands_to F) bs \<Longrightarrow> eventually (\<lambda>x. f x \<in> {f x..f x}) at_top"
  by simp

lemma eventually_in_atLeastAtMostI:
  assumes "eventually (\<lambda>x. f x \<ge> l x) at_top" "eventually (\<lambda>x. f x \<le> u x) at_top"
  shows   "eventually (\<lambda>x. f x \<in> {l x..u x}) at_top"
  using assms by eventually_elim simp_all

lemma tendsto_sandwich':
  fixes l f u :: "'a \<Rightarrow> 'b :: order_topology"
  shows "eventually (\<lambda>x. l x \<le> f x) F \<Longrightarrow> eventually (\<lambda>x. f x \<le> u x) F \<Longrightarrow>
           (l \<longlongrightarrow> L1) F \<Longrightarrow> (u \<longlongrightarrow> L2) F \<Longrightarrow> L1 = L2 \<Longrightarrow> (f \<longlongrightarrow> L1) F"
  using tendsto_sandwich[of l f F u L1] by simp

(* TODO: Move? *)
lemma filterlim_at_bot_mono:
  fixes l f u :: "'a \<Rightarrow> 'b :: linorder_topology"
  assumes "filterlim u at_bot F" and "eventually (\<lambda>x. f x \<le> u x) F"
  shows   "filterlim f at_bot F"
  unfolding filterlim_at_bot
proof
  fix Z :: 'b
  from assms(1) have "eventually (\<lambda>x. u x \<le> Z) F" by (auto simp: filterlim_at_bot)
  with assms(2) show "eventually (\<lambda>x. f x \<le> Z) F" by eventually_elim simp
qed

context
begin

qualified lemma eq_zero_imp_nonneg: "x = (0::real) \<Longrightarrow> x \<ge> 0"
  by simp

qualified lemma exact_to_bound: "(f expands_to F) bs \<Longrightarrow> eventually (\<lambda>x. f x \<le> f x) at_top"
  by simp

qualified lemma expands_to_abs_nonneg: "(f expands_to F) bs \<Longrightarrow> eventually (\<lambda>x. abs (f x) \<ge> 0) at_top"
  by simp

qualified lemma eventually_nonpos_flip: "eventually (\<lambda>x. f x \<le> (0::real)) F \<Longrightarrow> eventually (\<lambda>x. -f x \<ge> 0) F"
  by simp

qualified lemma bounds_uminus:
  fixes a b :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. a x \<le> b x) at_top"
  shows   "eventually (\<lambda>x. -b x \<le> -a x) at_top"
  using assms by eventually_elim simp

qualified lemma
  fixes a b c d :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. a x \<le> b x) at_top" "eventually (\<lambda>x. c x \<le> d x) at_top"
  shows   combine_bounds_add:  "eventually (\<lambda>x. a x + c x \<le> b x + d x) at_top"
    and   combine_bounds_diff: "eventually (\<lambda>x. a x - d x \<le> b x - c x) at_top"
  by (use assms in eventually_elim; simp add: add_mono diff_mono)+

qualified lemma
  fixes a b c d :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. a x \<le> b x) at_top" "eventually (\<lambda>x. c x \<le> d x) at_top"
  shows   combine_bounds_min: "eventually (\<lambda>x. min (a x) (c x) \<le> min (b x) (d x)) at_top"
    and   combine_bounds_max: "eventually (\<lambda>x. max (a x) (c x) \<le> max (b x) (d x)) at_top"
  by (blast intro: eventually_elim2[OF assms] min.mono max.mono)+

qualified lemma trivial_bounds_sin:  "\<forall>x::real. sin x \<in> {-1..1}"
  and trivial_bounds_cos:  "\<forall>x::real. cos x \<in> {-1..1}"
  and trivial_bounds_frac: "\<forall>x::real. frac x \<in> {0..1}"
  by (auto simp: less_imp_le[OF frac_lt_1])

qualified lemma trivial_boundsI:
  fixes f g:: "real \<Rightarrow> real"
  assumes "\<forall>x. f x \<in> {l..u}" and "g \<equiv> g"
  shows   "eventually (\<lambda>x. f (g x) \<ge> l) at_top" "eventually (\<lambda>x. f (g x) \<le> u) at_top"
  using assms by auto

qualified lemma
  fixes f f' :: "real \<Rightarrow> real"
  shows transfer_lower_bound:
          "eventually (\<lambda>x. g x \<ge> l x) at_top \<Longrightarrow> f \<equiv> g \<Longrightarrow> eventually (\<lambda>x. f x \<ge> l x) at_top"
  and   transfer_upper_bound:
          "eventually (\<lambda>x. g x \<le> u x) at_top \<Longrightarrow> f \<equiv> g \<Longrightarrow> eventually (\<lambda>x. f x \<le> u x) at_top"
  by simp_all

qualified lemma mono_bound:
  fixes f g h :: "real \<Rightarrow> real"
  assumes "mono h" "eventually (\<lambda>x. f x \<le> g x) at_top"
  shows   "eventually (\<lambda>x. h (f x) \<le> h (g x)) at_top"
  by (intro eventually_mono[OF assms(2)] monoD[OF assms(1)])

qualified lemma
  fixes f l :: "real \<Rightarrow> real"
  assumes "(l expands_to L) bs" "trimmed_pos L" "basis_wf bs" "eventually (\<lambda>x. l x \<le> f x) at_top"
  shows   expands_to_lb_ln: "eventually (\<lambda>x. ln (l x) \<le> ln (f x)) at_top"
    and   expands_to_ub_ln:
            "eventually (\<lambda>x. f x \<le> u x) at_top \<Longrightarrow> eventually (\<lambda>x. ln (f x) \<le> ln (u x)) at_top"
proof -
  from assms(3,1,2) have pos: "eventually (\<lambda>x. l x > 0) at_top"
    by (rule expands_to_imp_eventually_pos)
  from pos and assms(4)
    show "eventually (\<lambda>x. ln (l x) \<le> ln (f x)) at_top" by eventually_elim simp
  assume "eventually (\<lambda>x. f x \<le> u x) at_top"
  with pos and assms(4) show "eventually (\<lambda>x. ln (f x) \<le> ln (u x)) at_top"
    by eventually_elim simp
qed

qualified lemma eventually_sgn_ge_1D:
  assumes "eventually (\<lambda>x::real. sgn (f x) \<ge> l x) at_top"
          "(l expands_to (const_expansion 1 :: 'a :: multiseries)) bs"
  shows   "((\<lambda>x. sgn (f x)) expands_to (const_expansion 1 :: 'a)) bs"
proof (rule expands_to_cong)
  from assms(2) have "eventually (\<lambda>x. l x = 1) at_top"
    by (simp add: expands_to.simps)
  with assms(1) show "eventually (\<lambda>x. 1 = sgn (f x)) at_top"
    by eventually_elim (auto simp: sgn_if split: if_splits)
qed (insert assms, auto simp: expands_to.simps)

qualified lemma eventually_sgn_le_neg1D:
  assumes "eventually (\<lambda>x::real. sgn (f x) \<le> u x) at_top"
          "(u expands_to (const_expansion (-1) :: 'a :: multiseries)) bs"
  shows   "((\<lambda>x. sgn (f x)) expands_to (const_expansion (-1) :: 'a)) bs"
proof (rule expands_to_cong)
  from assms(2) have "eventually (\<lambda>x. u x = -1) at_top"
    by (simp add: expands_to.simps eq_commute)
  with assms(1) show "eventually (\<lambda>x. -1 = sgn (f x)) at_top"
    by eventually_elim (auto simp: sgn_if split: if_splits)
qed (insert assms, auto simp: expands_to.simps)

qualified lemma expands_to_squeeze:
  assumes "eventually (\<lambda>x. l x \<le> f x) at_top" "eventually (\<lambda>x. f x \<le> g x) at_top"
          "(l expands_to L) bs" "(g expands_to L) bs"
  shows   "(f expands_to L) bs"
proof (rule expands_to_cong[OF assms(3)])
  from assms have "eventually (\<lambda>x. eval L x = l x) at_top" "eventually (\<lambda>x. eval L x = g x) at_top"
    by (simp_all add: expands_to.simps)
  with assms(1,2) show "eventually (\<lambda>x. l x = f x) at_top"
    by eventually_elim simp
qed

qualified lemma mono_exp_real: "mono (exp :: real \<Rightarrow> real)"
  by (auto intro!: monoI)

qualified lemma mono_sgn_real: "mono (sgn :: real \<Rightarrow> real)"
  by (auto intro!: monoI simp: sgn_if)

qualified lemma mono_arctan_real: "mono (arctan :: real \<Rightarrow> real)"
  by (auto intro!: monoI arctan_monotone')

qualified lemma mono_root_real: "n \<equiv> n \<Longrightarrow> mono (root n :: real \<Rightarrow> real)"
  by (cases n) (auto simp: mono_def)

qualified lemma mono_rfloor: "mono rfloor" and mono_rceil: "mono rceil"
  by (auto intro!: monoI simp: rfloor_def floor_mono rceil_def ceiling_mono)

qualified lemma lower_bound_cong:
  "eventually (\<lambda>x. f x = g x) at_top \<Longrightarrow> eventually (\<lambda>x. l x \<le> g x) at_top \<Longrightarrow>
     eventually (\<lambda>x. l x \<le> f x) at_top"
  by (erule (1) eventually_elim2) simp

qualified lemma upper_bound_cong:
  "eventually (\<lambda>x. f x = g x) at_top \<Longrightarrow> eventually (\<lambda>x. g x \<le> u x) at_top \<Longrightarrow>
     eventually (\<lambda>x. f x \<le> u x) at_top"
  by (erule (1) eventually_elim2) simp

qualified lemma
  assumes "eventually (\<lambda>x. f x = (g x :: real)) at_top"
  shows   eventually_eq_min: "eventually (\<lambda>x. min (f x) (g x) = f x) at_top"
    and   eventually_eq_max: "eventually (\<lambda>x. max (f x) (g x) = f x) at_top"
  by (rule eventually_mono[OF assms]; simp)+

qualified lemma rfloor_bound:
    "eventually (\<lambda>x. l x \<le> f x) at_top \<Longrightarrow> eventually (\<lambda>x. l x - 1 \<le> rfloor (f x)) at_top"
    "eventually (\<lambda>x. f x \<le> u x) at_top \<Longrightarrow> eventually (\<lambda>x. rfloor (f x) \<le> u x) at_top"
  and rceil_bound:
    "eventually (\<lambda>x. l x \<le> f x) at_top \<Longrightarrow> eventually (\<lambda>x. l x \<le> rceil (f x)) at_top"
    "eventually (\<lambda>x. f x \<le> u x) at_top \<Longrightarrow> eventually (\<lambda>x. rceil (f x) \<le> u x + 1) at_top"
  unfolding rfloor_def rceil_def by (erule eventually_mono, linarith)+

qualified lemma natmod_trivial_lower_bound:
  fixes f g :: "real \<Rightarrow> real"
  assumes "f \<equiv> f" "g \<equiv> g"
  shows "eventually (\<lambda>x. rnatmod (f x) (g x) \<ge> 0) at_top"
  by (simp add: rnatmod_def)

qualified lemma natmod_upper_bound:
  fixes f g :: "real \<Rightarrow> real"
  assumes "f \<equiv> f" and "eventually (\<lambda>x. l2 x \<le> g x) at_top" and "eventually (\<lambda>x. g x \<le> u2 x) at_top"
  assumes "eventually (\<lambda>x. l2 x - 1 \<ge> 0) at_top"
  shows "eventually (\<lambda>x. rnatmod (f x) (g x) \<le> u2 x - 1) at_top"
  using assms(2-)
proof eventually_elim
  case (elim x)
  have "rnatmod (f x) (g x) = real (nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor>)"
    by (simp add: rnatmod_def)
  also have "nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor> < nat \<lfloor>g x\<rfloor>"
    using elim by (intro mod_less_divisor) auto
  hence "real (nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor>) \<le> u2 x - 1"
    using elim by linarith
  finally show ?case .
qed

qualified lemma natmod_upper_bound':
  fixes f g :: "real \<Rightarrow> real"
  assumes "g \<equiv> g" "eventually (\<lambda>x. u1 x \<ge> 0) at_top" and "eventually (\<lambda>x. f x \<le> u1 x) at_top"
  shows "eventually (\<lambda>x. rnatmod (f x) (g x) \<le> u1 x) at_top"
  using assms(2-)
proof eventually_elim
  case (elim x)
  have "rnatmod (f x) (g x) = real (nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor>)"
    by (simp add: rnatmod_def)
  also have "nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor> \<le> nat \<lfloor>f x\<rfloor>"
    by auto
  hence "real (nat \<lfloor>f x\<rfloor> mod nat \<lfloor>g x\<rfloor>) \<le> real (nat \<lfloor>f x\<rfloor>)"
    by simp
  also have "\<dots> \<le> u1 x" using elim by linarith
  finally show "rnatmod (f x) (g x) \<le> \<dots>" .
qed

qualified lemma expands_to_natmod_nonpos:
  fixes f g :: "real \<Rightarrow> real"
  assumes "g \<equiv> g" "eventually (\<lambda>x. u1 x \<le> 0) at_top" "eventually (\<lambda>x. f x \<le> u1 x) at_top"
          "((\<lambda>_. 0) expands_to C) bs"
  shows "((\<lambda>x. rnatmod (f x) (g x)) expands_to C) bs"
  by (rule expands_to_cong[OF assms(4)])
     (insert assms, auto elim: eventually_elim2 simp: rnatmod_def)

qualified lemma eventually_atLeastAtMostI:
  fixes f l r :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. l x \<le> f x) at_top" "eventually (\<lambda>x. f x \<le> u x) at_top"
  shows   "eventually (\<lambda>x. f x \<in> {l x..u x}) at_top"
  using assms by eventually_elim simp

qualified lemma eventually_atLeastAtMostD:
  fixes f l r :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. f x \<in> {l x..u x}) at_top"
  shows   "eventually (\<lambda>x. l x \<le> f x) at_top" "eventually (\<lambda>x. f x \<le> u x) at_top"
  using assms by (simp_all add: eventually_conj_iff)

qualified lemma eventually_0_imp_prod_zero:
  fixes f g :: "real \<Rightarrow> real"
  assumes "eventually (\<lambda>x. f x = 0) at_top"
  shows   "eventually (\<lambda>x. f x * g x = 0) at_top" "eventually (\<lambda>x. g x * f x = 0) at_top"
  by (use assms in eventually_elim; simp)+

qualified lemma mult_right_bounds:
  fixes f g :: "real \<Rightarrow> real"
  shows "\<forall>x. f x \<in> {l x..u x} \<longrightarrow> g x \<ge> 0 \<longrightarrow> f x * g x \<in> {l x * g x..u x * g x}"
    and "\<forall>x. f x \<in> {l x..u x} \<longrightarrow> g x \<le> 0 \<longrightarrow> f x * g x \<in> {u x * g x..l x * g x}"
  by (auto intro: mult_right_mono mult_right_mono_neg)

qualified lemma mult_left_bounds:
  fixes f g :: "real \<Rightarrow> real"
  shows "\<forall>x. g x \<in> {l x..u x} \<longrightarrow> f x \<ge> 0 \<longrightarrow> f x * g x \<in> {f x * l x..f x * u x}"
    and "\<forall>x. g x \<in> {l x..u x} \<longrightarrow> f x \<le> 0 \<longrightarrow> f x * g x \<in> {f x * u x..f x * l x}"
  by (auto intro: mult_left_mono mult_left_mono_neg)

qualified lemma mult_mono_nonpos_nonneg:
  "a \<le> c \<Longrightarrow> d \<le> b \<Longrightarrow> a \<le> 0 \<Longrightarrow> d \<ge> 0 \<Longrightarrow> a * b \<le> c * (d :: 'a :: linordered_ring)"
  using mult_mono[of "-c" "-a" d b] by simp

qualified lemma mult_mono_nonneg_nonpos:
  "c \<le> a \<Longrightarrow> b \<le> d \<Longrightarrow> a \<ge> 0 \<Longrightarrow> d \<le> 0 \<Longrightarrow> a * b \<le> c * (d :: 'a :: {comm_ring, linordered_ring})"
  using mult_mono[of c a "-d" "-b"] by (simp add: mult.commute)

qualified lemma mult_mono_nonpos_nonpos:
  "c \<le> a \<Longrightarrow> d \<le> b \<Longrightarrow> c \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a * b \<le> c * (d :: 'a :: linordered_ring)"
  using mult_mono[of "-a" "-c" "-b" "-d"] by simp

qualified lemmas mult_monos =
  mult_mono mult_mono_nonpos_nonneg mult_mono_nonneg_nonpos mult_mono_nonpos_nonpos

qualified lemma mult_bounds_real:
  fixes f g l1 u1 l2 u2 l u :: "real \<Rightarrow> real"
  defines "P \<equiv> \<lambda>l u x. f x \<in> {l1 x..u1 x} \<longrightarrow> g x \<in> {l2 x..u2 x} \<longrightarrow> f x * g x \<in> {l..u}"
  shows   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x * l2 x) (u1 x * u2 x) x"
    and   "\<forall>x. u1 x \<le> 0 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x * u2 x) (u1 x * l2 x) x"
    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x * l2 x) (l1 x * u2 x) x"
    and   "\<forall>x. u1 x \<le> 0 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x * u2 x) (l1 x * l2 x) x"

    and   "\<forall>x. l1 x \<le> 0 \<longrightarrow> u1 x \<ge> 0 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x * u2 x) (u1 x * u2 x) x"
    and   "\<forall>x. l1 x \<le> 0 \<longrightarrow> u1 x \<ge> 0 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x * l2 x) (l1 x * l2 x) x"
    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> P (u1 x * l2 x) (u1 x * u2 x) x"
    and   "\<forall>x. u1 x \<le> 0 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> P (l1 x * u2 x) (l1 x * l2 x) x"

    and   "\<forall>x. l1 x \<le> 0 \<longrightarrow> u1 x \<ge> 0 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> l x \<le> l1 x * u2 x \<longrightarrow>
             l x \<le> u1 x * l2 x \<longrightarrow> u x \<ge> l1 x* l2 x \<longrightarrow> u x \<ge> u1 x * u2 x \<longrightarrow> P (l x) (u x) x"
proof goal_cases
  case 1
  show ?case by (auto intro: mult_mono simp: P_def)
next
  case 2
  show ?case by (auto intro: mult_monos(2) simp: P_def)
next
  case 3
  show ?case unfolding P_def
    by (subst (1 2 3) mult.commute) (auto intro: mult_monos(2) simp: P_def)
next
  case 4
  show ?case by (auto intro: mult_monos(4) simp: P_def)
next
  case 5
  show ?case by (auto intro: mult_monos(1,2) simp: P_def)
next
  case 6
  show ?case by (auto intro: mult_monos(3,4) simp: P_def)
next
  case 7
  show ?case unfolding P_def
    by (subst (1 2 3) mult.commute) (auto intro: mult_monos(1,2))
next
  case 8
  show ?case unfolding P_def
    by (subst (1 2 3) mult.commute) (auto intro: mult_monos(3,4))
next
  case 9
  show ?case
  proof (safe, goal_cases)
    case (1 x)
    from 1(1-4) show ?case unfolding P_def
      by (cases "f x \<ge> 0"; cases "g x \<ge> 0";
          fastforce intro: mult_monos 1(5,6)[THEN order.trans] 1(7,8)[THEN order.trans[rotated]])
  qed
qed

qualified lemma powr_bounds_real:
  fixes f g l1 u1 l2 u2 l u :: "real \<Rightarrow> real"
  defines "P \<equiv> \<lambda>l u x. f x \<in> {l1 x..u1 x} \<longrightarrow> g x \<in> {l2 x..u2 x} \<longrightarrow> f x powr g x \<in> {l..u}"
  shows   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l1 x \<ge> 1 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x powr l2 x) (u1 x powr u2 x) x"
    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> u1 x \<le> 1 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x powr u2 x) (u1 x powr l2 x) x"
    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l1 x \<ge> 1 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x powr l2 x) (l1 x powr u2 x) x"
    and   "\<forall>x. l1 x > 0 \<longrightarrow> u1 x \<le> 1 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x powr u2 x) (l1 x powr l2 x) x"

    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l1 x \<le> 1 \<longrightarrow> u1 x \<ge> 1 \<longrightarrow> l2 x \<ge> 0 \<longrightarrow> P (l1 x powr u2 x) (u1 x powr u2 x) x"
    and   "\<forall>x. l1 x > 0 \<longrightarrow> l1 x \<le> 1 \<longrightarrow> u1 x \<ge> 1 \<longrightarrow> u2 x \<le> 0 \<longrightarrow> P (u1 x powr l2 x) (l1 x powr l2 x) x"
    and   "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l1 x \<ge> 1 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> P (u1 x powr l2 x) (u1 x powr u2 x) x"
    and   "\<forall>x. l1 x > 0 \<longrightarrow> u1 x \<le> 1 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> P (l1 x powr u2 x) (l1 x powr l2 x) x"

    and   "\<forall>x. l1 x > 0 \<longrightarrow> l1 x \<le> 1 \<longrightarrow> u1 x \<ge> 1 \<longrightarrow> l2 x \<le> 0 \<longrightarrow> u2 x \<ge> 0 \<longrightarrow> l x \<le> l1 x powr u2 x \<longrightarrow>
             l x \<le> u1 x powr l2 x \<longrightarrow> u x \<ge> l1 x powr l2 x \<longrightarrow> u x \<ge> u1 x powr u2 x \<longrightarrow> P (l x) (u x) x"
proof goal_cases
  case 1
  show ?case by (auto simp: P_def powr_def intro: mult_monos)
next
  case 2
  show ?case by (auto simp: P_def powr_def intro: mult_monos)
next
  case 3
  show ?case by (auto simp: P_def powr_def intro: mult_monos)
next
  case 4
  show ?case by (auto simp: P_def powr_def intro: mult_monos)
next
  case 5
  note comm = mult.commute[of _ "ln x" for x :: real]
  show ?case by (auto simp: P_def powr_def comm intro: mult_monos)
next
  case 6
  note comm = mult.commute[of _ "ln x" for x :: real]
  show ?case by (auto simp: P_def powr_def comm intro: mult_monos)
next
  case 7
  show ?case by (auto simp: P_def powr_def intro: mult_monos)
next
  case 8
  show ?case
    by (auto simp: P_def powr_def intro: mult_monos)
next
  case 9
  show ?case unfolding P_def
  proof (safe, goal_cases)
    case (1 x)
    define l' where "l' = (\<lambda>x. min (ln (l1 x) * u2 x) (ln (u1 x) * l2 x))"
    define u' where "u' = (\<lambda>x. max (ln (l1 x) * l2 x) (ln (u1 x) * u2 x))"
    from 1 spec[OF mult_bounds_real(9)[of "\<lambda>x. ln (l1 x)" "\<lambda>x. ln (u1 x)" l2 u2 l' u'
                                          "\<lambda>x. ln (f x)" g], of x]
      have "ln (f x) * g x \<in> {l' x..u' x}" by (auto simp: powr_def mult.commute l'_def u'_def)
    with 1 have "f x powr g x \<in> {exp (l' x)..exp (u' x)}"
      by (auto simp: powr_def mult.commute)
    also from 1 have "exp (l' x) = min (l1 x powr u2 x) (u1 x powr l2 x)"
      by (auto simp add: l'_def powr_def min_def mult.commute)
    also from 1 have "exp (u' x) = max (l1 x powr l2 x) (u1 x powr u2 x)"
      by (auto simp add: u'_def powr_def max_def mult.commute)
    finally show ?case using 1(5-9) by auto
  qed
qed

qualified lemma powr_right_bounds:
  fixes f g :: "real \<Rightarrow> real"
  shows "\<forall>x. l x \<ge> 0 \<longrightarrow> f x \<in> {l x..u x} \<longrightarrow> g x \<ge> 0 \<longrightarrow> f x powr g x \<in> {l x powr g x..u x powr g x}"
    and "\<forall>x. l x > 0 \<longrightarrow> f x \<in> {l x..u x} \<longrightarrow> g x \<le> 0 \<longrightarrow> f x powr g x \<in> {u x powr g x..l x powr g x}"
  by (auto intro: powr_mono2 powr_mono2')

(* TODO Move *)
lemma powr_mono': "a \<le> (b::real) \<Longrightarrow> x \<ge> 0 \<Longrightarrow> x \<le> 1 \<Longrightarrow> x powr b \<le> x powr a"
  using powr_mono[of "-b" "-a" "inverse x"] by (auto simp: powr_def ln_inverse ln_div field_split_simps)

qualified lemma powr_left_bounds:
  fixes f g :: "real \<Rightarrow> real"
  shows "\<forall>x. f x > 0 \<longrightarrow> g x \<in> {l x..u x} \<longrightarrow> f x \<ge> 1 \<longrightarrow> f x powr g x \<in> {f x powr l x..f x powr u x}"
    and "\<forall>x. f x > 0 \<longrightarrow> g x \<in> {l x..u x} \<longrightarrow> f x \<le> 1 \<longrightarrow> f x powr g x \<in> {f x powr u x..f x powr l x}"
  by (auto intro: powr_mono powr_mono')

qualified lemma powr_nat_bounds_transfer_ge:
  "\<forall>x. l1 x \<ge> 0 \<longrightarrow> f x \<ge> l1 x \<longrightarrow> f x powr g x \<ge> l x \<longrightarrow> powr_nat (f x) (g x) \<ge> l x"
  by (auto simp: powr_nat_def)

qualified lemma powr_nat_bounds_transfer_le:
  "\<forall>x. l1 x > 0 \<longrightarrow> f x \<ge> l1 x \<longrightarrow> f x powr g x \<le> u x \<longrightarrow> powr_nat (f x) (g x) \<le> u x"
  "\<forall>x. l1 x \<ge> 0 \<longrightarrow> l2 x > 0 \<longrightarrow> f x \<ge> l1 x \<longrightarrow> g x \<ge> l2 x \<longrightarrow>
      f x powr g x \<le> u x \<longrightarrow> powr_nat (f x) (g x) \<le> u x"
  "\<forall>x. l1 x \<ge> 0 \<longrightarrow> u2 x < 0 \<longrightarrow> f x \<ge> l1 x \<longrightarrow> g x \<le> u2 x \<longrightarrow>
      f x powr g x \<le> u x \<longrightarrow> powr_nat (f x) (g x) \<le> u x"
  "\<forall>x. l1 x \<ge> 0 \<longrightarrow> f x \<ge> l1 x \<longrightarrow>  f x powr g x \<le> u x \<longrightarrow> u x \<le> u' x \<longrightarrow> 1 \<le> u' x \<longrightarrow>
     powr_nat (f x) (g x) \<le> u' x"
  by (auto simp: powr_nat_def)

lemma abs_powr_nat_le: "abs (powr_nat x y) \<le> powr_nat (abs x) y"
  by (simp add: powr_nat_def abs_mult)

qualified lemma powr_nat_bounds_ge_neg:
  assumes "powr_nat (abs x) y \<le> u"
  shows   "powr_nat x y \<ge> -u" "powr_nat x y \<le> u"
proof -
  have "abs (powr_nat x y) \<le> powr_nat (abs x) y"
    by (rule abs_powr_nat_le)
  also have "\<dots> \<le> u" using assms by auto
  finally show "powr_nat x y \<ge> -u" "powr_nat x y \<le> u" by auto
qed

qualified lemma powr_nat_bounds_transfer_abs [eventuallized]:
  "\<forall>x. powr_nat (abs (f x)) (g x) \<le> u x \<longrightarrow> powr_nat (f x) (g x) \<ge> -u x"
  "\<forall>x. powr_nat (abs (f x)) (g x) \<le> u x \<longrightarrow> powr_nat (f x) (g x) \<le> u x"
  using powr_nat_bounds_ge_neg by blast+

qualified lemma eventually_powr_const_nonneg:
  "f \<equiv> f \<Longrightarrow> p \<equiv> p \<Longrightarrow> eventually (\<lambda>x. f x powr p \<ge> (0::real)) at_top"
  by simp

qualified lemma eventually_powr_const_mono_nonneg:
  assumes "p \<ge> (0 :: real)" "eventually (\<lambda>x. l x \<ge> 0) at_top" "eventually (\<lambda>x. l x \<le> f x) at_top"
          "eventually (\<lambda>x. f x \<le> g x) at_top"
  shows   "eventually (\<lambda>x. f x powr p \<le> g x powr p) at_top"
  using assms(2-4) by eventually_elim (auto simp: assms(1) intro!: powr_mono2)

qualified lemma eventually_powr_const_mono_nonpos:
  assumes "p \<le> (0 :: real)" "eventually (\<lambda>x. l x > 0) at_top" "eventually (\<lambda>x. l x \<le> f x) at_top"
          "eventually (\<lambda>x. f x \<le> g x) at_top"
  shows   "eventually (\<lambda>x. f x powr p \<ge> g x powr p) at_top"
  using assms(2-4) by eventually_elim (auto simp: assms(1) intro!: powr_mono2')

qualified lemma eventually_power_mono:
  assumes "eventually (\<lambda>x. 0 \<le> l x) at_top" "eventually (\<lambda>x. l x \<le> f x) at_top"
          "eventually (\<lambda>x. f x \<le> g x) at_top" "n \<equiv> n"
  shows   "eventually (\<lambda>x. f x ^ n \<le> (g x :: real) ^ n) at_top"
  using assms(1-3) by eventually_elim (auto intro: power_mono)

qualified lemma eventually_mono_power_odd:
  assumes "odd n" "eventually (\<lambda>x. f x \<le> (g x :: real)) at_top"
  shows   "eventually (\<lambda>x. f x ^ n \<le> g x ^ n) at_top"
  using assms(2) by eventually_elim (insert assms(1), auto intro: power_mono_odd)

qualified lemma eventually_lower_bound_power_even_nonpos:
  assumes "even n" "eventually (\<lambda>x. u x \<le> (0::real)) at_top"
          "eventually (\<lambda>x. f x \<le> u x) at_top"
  shows   "eventually (\<lambda>x. u x ^ n \<le> f x ^ n) at_top"
  using assms(2-) by eventually_elim (rule power_mono_even, auto simp: assms(1))

qualified lemma eventually_upper_bound_power_even_nonpos:
  assumes "even n" "eventually (\<lambda>x. u x \<le> (0::real)) at_top"
          "eventually (\<lambda>x. l x \<le> f x) at_top" "eventually (\<lambda>x. f x \<le> u x) at_top"
  shows   "eventually (\<lambda>x. f x ^ n \<le> l x ^ n) at_top"
  using assms(2-) by eventually_elim (rule power_mono_even, auto simp: assms(1))

qualified lemma eventually_lower_bound_power_even_indet:
  assumes "even n" "f \<equiv> f"
  shows   "eventually (\<lambda>x. (0::real) \<le> f x ^ n) at_top"
  using assms by (simp add: zero_le_even_power)

qualified lemma eventually_lower_bound_power_indet:
  assumes "eventually (\<lambda>x. l x \<le> f x) at_top"
  assumes "eventually (\<lambda>x. l' x \<le> l x ^ n) at_top" "eventually (\<lambda>x. l' x \<le> 0) at_top"
  shows   "eventually (\<lambda>x. l' x \<le> (f x ^ n :: real)) at_top"
  using assms
proof eventually_elim
  case (elim x)
  thus ?case
    using power_mono_odd[of n "l x" "f x"] zero_le_even_power[of n "f x"]
    by (cases "even n") auto
qed

qualified lemma eventually_upper_bound_power_indet:
  assumes "eventually (\<lambda>x. l x \<le> f x) at_top" "eventually (\<lambda>x. f x \<le> u x) at_top"
          "eventually (\<lambda>x. u' x \<ge> -l x) at_top" "eventually (\<lambda>x. u' x \<ge> u x) at_top" "n \<equiv> n"
  shows   "eventually (\<lambda>x. f x ^ n \<le> (u' x ^ n :: real)) at_top"
  using assms(1-4)
proof eventually_elim
  case (elim x)
  have "f x ^ n \<le> \<bar>f x ^ n\<bar>" by simp
  also have "\<dots> = \<bar>f x\<bar> ^ n" by (simp add: power_abs)
  also from elim have "\<dots> \<le> u' x ^ n" by (intro power_mono) auto
  finally show ?case .
qed

qualified lemma expands_to_imp_exp_ln_eq:
  assumes "(l expands_to L) bs" "eventually (\<lambda>x. l x \<le> f x) at_top"
          "trimmed_pos L" "basis_wf bs"
  shows   "eventually (\<lambda>x. exp (ln (f x)) = f x) at_top"
proof -
  from expands_to_imp_eventually_pos[of bs l L] assms
    have "eventually (\<lambda>x. l x > 0) at_top" by simp
  with assms(2) show ?thesis by eventually_elim simp
qed

qualified lemma expands_to_imp_ln_powr_eq:
  assumes "(l expands_to L) bs" "eventually (\<lambda>x. l x \<le> f x) at_top"
          "trimmed_pos L" "basis_wf bs"
  shows   "eventually (\<lambda>x. ln (f x powr g x) = ln (f x) * g x) at_top"
proof -
  from expands_to_imp_eventually_pos[of bs l L] assms
    have "eventually (\<lambda>x. l x > 0) at_top" by simp
  with assms(2) show ?thesis by eventually_elim (simp add: powr_def)
qed

qualified lemma inverse_bounds_real:
  fixes f l u :: "real \<Rightarrow> real"
  shows "\<forall>x. l x > 0 \<longrightarrow> l x \<le> f x \<longrightarrow> f x \<le> u x \<longrightarrow> inverse (f x) \<in> {inverse (u x)..inverse (l x)}"
    and "\<forall>x. u x < 0 \<longrightarrow> l x \<le> f x \<longrightarrow> f x \<le> u x \<longrightarrow> inverse (f x) \<in> {inverse (u x)..inverse (l x)}"
  by (auto simp: field_simps)

qualified lemma pos_imp_inverse_pos: "\<forall>x::real. f x > 0 \<longrightarrow> inverse (f x) > (0::real)"
  and neg_imp_inverse_neg: "\<forall>x::real. f x < 0 \<longrightarrow> inverse (f x) < (0::real)"
  by auto

qualified lemma transfer_divide_bounds:
  fixes f g :: "real \<Rightarrow> real"
  shows "Trueprop (eventually (\<lambda>x. f x \<in> {h x * inverse (i x)..j x}) at_top) \<equiv>
         Trueprop (eventually (\<lambda>x. f x \<in> {h x / i x..j x}) at_top)"
    and "Trueprop (eventually (\<lambda>x. f x \<in> {j x..h x * inverse (i x)}) at_top) \<equiv>
         Trueprop (eventually (\<lambda>x. f x \<in> {j x..h x / i x}) at_top)"
    and "Trueprop (eventually (\<lambda>x. f x * inverse (g x) \<in> A x) at_top) \<equiv>
         Trueprop (eventually (\<lambda>x. f x / g x \<in> A x) at_top)"
    and "Trueprop (((\<lambda>x. f x * inverse (g x)) expands_to F) bs) \<equiv>
         Trueprop (((\<lambda>x. f x / g x) expands_to F) bs)"
  by (simp_all add: field_simps)

qualified lemma eventually_le_self: "eventually (\<lambda>x::real. f x \<le> (f x :: real)) at_top"
  by simp

qualified lemma max_eventually_eq:
  "eventually (\<lambda>x. f x = (g x :: real)) at_top \<Longrightarrow> eventually (\<lambda>x. max (f x) (g x) = f x) at_top"
  by (erule eventually_mono) simp

qualified lemma min_eventually_eq:
  "eventually (\<lambda>x. f x = (g x :: real)) at_top \<Longrightarrow> eventually (\<lambda>x. min (f x) (g x) = f x) at_top"
  by (erule eventually_mono) simp

qualified lemma
  assumes "eventually (\<lambda>x. f x = (g x :: 'a :: preorder)) F"
  shows   eventually_eq_imp_ge: "eventually (\<lambda>x. f x \<ge> g x) F"
    and   eventually_eq_imp_le: "eventually (\<lambda>x. f x \<le> g x) F"
  by (use assms in eventually_elim; simp)+

qualified lemma eventually_less_imp_le:
  assumes "eventually (\<lambda>x. f x < (g x :: 'a :: order)) F"
  shows   "eventually (\<lambda>x. f x \<le> g x) F"
  using assms by eventually_elim auto

qualified lemma
  fixes f :: "real \<Rightarrow> real"
  shows eventually_abs_ge_0: "eventually (\<lambda>x. abs (f x) \<ge> 0) at_top"
    and nonneg_abs_bounds: "\<forall>x. l x \<ge> 0 \<longrightarrow> f x \<in> {l x..u x} \<longrightarrow> abs (f x) \<in> {l x..u x}"
    and nonpos_abs_bounds: "\<forall>x. u x \<le> 0 \<longrightarrow> f x \<in> {l x..u x} \<longrightarrow> abs (f x) \<in> {-u x..-l x}"
    and indet_abs_bounds:
          "\<forall>x. l x \<le> 0 \<longrightarrow> u x \<ge> 0 \<longrightarrow> f x \<in> {l x..u x} \<longrightarrow> -l x \<le> h x \<longrightarrow> u x \<le> h x \<longrightarrow>
             abs (f x) \<in> {0..h x}"
  by auto

qualified lemma eventually_le_abs_nonneg:
  "eventually (\<lambda>x. l x \<ge> 0) at_top \<Longrightarrow> eventually (\<lambda>x. f x \<ge> l x) at_top \<Longrightarrow>
     eventually (\<lambda>x::real. l x \<le> (\<bar>f x\<bar> :: real)) at_top"
  by (auto elim: eventually_elim2)

qualified lemma eventually_le_abs_nonpos:
  "eventually (\<lambda>x. u x \<le> 0) at_top \<Longrightarrow> eventually (\<lambda>x. f x \<le> u x) at_top \<Longrightarrow>
     eventually (\<lambda>x::real. -u x \<le> (\<bar>f x\<bar> :: real)) at_top"
  by (auto elim: eventually_elim2)

qualified lemma
  fixes f g h :: "'a \<Rightarrow> 'b :: order"
  shows eventually_le_less:"eventually (\<lambda>x. f x \<le> g x) F \<Longrightarrow> eventually (\<lambda>x. g x < h x) F \<Longrightarrow>
           eventually (\<lambda>x. f x < h x) F"
  and   eventually_less_le:"eventually (\<lambda>x. f x < g x) F \<Longrightarrow> eventually (\<lambda>x. g x \<le> h x) F \<Longrightarrow>
           eventually (\<lambda>x. f x < h x) F"
  by (erule (1) eventually_elim2; erule (1) order.trans le_less_trans less_le_trans)+

qualified lemma eventually_pos_imp_nz [eventuallized]: "\<forall>x. f x > 0 \<longrightarrow> f x \<noteq> (0 :: 'a :: linordered_semiring)"
  and eventually_neg_imp_nz [eventuallized]: "\<forall>x. f x < 0 \<longrightarrow> f x \<noteq> 0"
  by auto

qualified lemma
  fixes f g l1 l2 u1 :: "'a \<Rightarrow> real"
  assumes "eventually (\<lambda>x. l1 x \<le> f x) F"
  assumes "eventually (\<lambda>x. f x \<le> u1 x) F"
  assumes "eventually (\<lambda>x. abs (g x) \<ge> l2 x) F"
  assumes "eventually (\<lambda>x. l2 x \<ge> 0) F"
  shows   bounds_smallo_imp_smallo: "l1 \<in> o[F](l2) \<Longrightarrow> u1 \<in> o[F](l2) \<Longrightarrow> f \<in> o[F](g)"
    and   bounds_bigo_imp_bigo:     "l1 \<in> O[F](l2) \<Longrightarrow> u1 \<in> O[F](l2) \<Longrightarrow> f \<in> O[F](g)"
proof -
  assume *: "l1 \<in> o[F](l2)" "u1 \<in> o[F](l2)"
  show "f \<in> o[F](g)"
  proof (rule landau_o.smallI, goal_cases)
    case (1 c)
    from *[THEN landau_o.smallD[OF _ 1]] and assms show ?case
    proof eventually_elim
      case (elim x)
      from elim have "norm (f x) \<le> c * l2 x" by simp
      also have "\<dots> \<le> c * norm (g x)" using 1 elim by (intro mult_left_mono) auto
      finally show ?case .
    qed
  qed
next
  assume *: "l1 \<in> O[F](l2)" "u1 \<in> O[F](l2)"
  then obtain C1 C2 where **: "C1 > 0" "C2 > 0" "eventually (\<lambda>x. norm (l1 x) \<le> C1 * norm (l2 x)) F"
    "eventually (\<lambda>x. norm (u1 x) \<le> C2 * norm (l2 x)) F" by (auto elim!: landau_o.bigE)
  from this(3,4) and assms have "eventually (\<lambda>x. norm (f x) \<le> max C1 C2 * norm (g x)) F"
  proof eventually_elim
    case (elim x)
    from elim have "norm (f x) \<le> max C1 C2 * l2 x" by (subst max_mult_distrib_right) auto
    also have "\<dots> \<le> max C1 C2 * norm (g x)" using elim ** by (intro mult_left_mono) auto
    finally show ?case .
  qed
  thus "f \<in> O[F](g)" by (rule bigoI)
qed

qualified lemma real_root_mono: "mono (root n)"
  by (cases n) (auto simp: mono_def)

(* TODO: support for rintmod *)

ML_file \<open>multiseries_expansion_bounds.ML\<close>

method_setup real_asymp = \<open>
let
  type flags = {verbose : bool, fallback : bool}
  fun join_flags
        {verbose = verbose1, fallback = fallback1}
        {verbose = verbose2, fallback = fallback2} =
    {verbose = verbose1 orelse verbose2, fallback = fallback1 orelse fallback2}
  val parse_flag =
    (Args.$$$ "verbose" >> K {verbose = true, fallback = false}) ||
    (Args.$$$ "fallback" >> K {verbose = false, fallback = true})
  val default_flags = {verbose = false, fallback = false}
  val parse_flags =
    Scan.optional (Args.parens (Parse.list1 parse_flag)) [] >>
      (fn xs => fold join_flags xs default_flags)
in
  Scan.lift parse_flags --| Method.sections Simplifier.simp_modifiers >>
    (fn flags => SIMPLE_METHOD' o
      (if #fallback flags then Real_Asymp_Basic.tac else Real_Asymp_Bounds.tac) (#verbose flags))
end
\<close> "Semi-automatic decision procedure for asymptotics of exp-log functions"

end

lemma "filterlim (\<lambda>x::real. sin x / x) (nhds 0) at_top"
  by real_asymp

lemma "(\<lambda>x::real. exp (sin x)) \<in> O(\<lambda>_. 1)"
  by real_asymp

lemma "(\<lambda>x::real. exp (real_of_int (floor x))) \<in> \<Theta>(\<lambda>x. exp x)"
  by real_asymp

lemma "(\<lambda>n::nat. n div 2 * ln (n div 2)) \<in> \<Theta>(\<lambda>n::nat. n * ln n)"
  by real_asymp

end


theory Hopcroft_Tarjan_Explicit_Stack
  imports
    Hopcroft_Tarjan
begin

type_synonym ('a, 'b) component = "('a, 'b) Directed_Multigraph.edge list"

record ('b, 't, 'g, 'a) state =
  root :: 'b
  tree :: 't
  multigraph :: 'g
  stack :: "('a, 'b) Directed_Multigraph.edge list"
  ESTACK :: "('a, 'b) Directed_Multigraph.edge list"
  Cs :: "('a, 'b) component list"

locale path_search =
  other
  where other = other +
    T: Map
  where empty = T_empty
    and update = T_update
    and delete = T_delete
    and lookup = T_lookup
    and invar = T_invar +
    P: Incidence_Structure
  where insert = insert
  for other :: "('a::linorder, 'b::linorder) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
    and T_empty
    and T_update :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and T_delete
    and T_lookup
    and T_invar
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes algorithm_5 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  fixes algorithm_6 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  assumes root_algorithm_5: "root (algorithm_5 N e \<sigma>) = root \<sigma>"
  assumes root_algorithm_6: "root (algorithm_6 N e \<sigma>) = root \<sigma>"
begin

definition tree_arc_2 where
  "tree_arc_2 e \<sigma> \<equiv> tree.tree_arc (T_lookup (tree \<sigma>)) e"

definition incidence_2 where
  "incidence_2 G \<equiv> Directed_Multigraph.incidence (\<lambda>v. incidence v G)"

definition DONE where
  "DONE \<sigma> \<equiv> stack \<sigma> = []"

(* FIXME: This specification is not correct! *)
function (domintros) path_search where
  "path_search N \<sigma> =
   (if \<not> DONE \<sigma>
    then let e = hd (stack \<sigma>);
             \<sigma>1 = \<sigma>\<lparr>stack := tl (stack \<sigma>)\<rparr>
         in if tree_arc_2 e \<sigma>1
            then let \<sigma>2 = path_search N (\<sigma>1\<lparr>stack := incidence_2 (multigraph \<sigma>1) (head e) @ stack \<sigma>1\<rparr>);
                     \<sigma>3 = \<sigma>2\<lparr>ESTACK := e # ESTACK \<sigma>2\<rparr>;
                     \<sigma>4 = algorithm_5 N e \<sigma>3;
                     \<sigma>5 = algorithm_6 N e \<sigma>4
                 in \<sigma>5
            else \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>
    else \<sigma>)"
  by pat_completeness simp
thm path_search.pinduct

end

locale algorithm_3_pre = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
begin

definition init where
  "init r T P \<equiv>
   \<lparr>root = r,
    tree = T,
    multigraph = P,
    stack = Directed_Multigraph.incidence (\<lambda>v. incidence v P) r,
    ESTACK = [],
    Cs = []\<rparr>"

definition algorithm_3 where
  "algorithm_3 r T P N \<equiv>
   let \<sigma> = path_search N (init r T P)
   in ESTACK \<sigma> # Cs \<sigma>"

end

locale algorithm_3 = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes T :: "'g \<Rightarrow> 'b \<Rightarrow> 't"
  fixes N :: "'g \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> nat"
  fixes I :: "'g \<Rightarrow> 'b \<Rightarrow> 'g"
  assumes steps_1_2_3_high_3:
    "\<lbrakk> biconnected_multigraph other (P.E G); r \<in> Multigraph.V (P.E G) \<rbrakk> \<Longrightarrow>
     steps_1_2_3_high_3 other r (\<lambda>v. incidence v (I G r)) (N G r) (P.E G) (T_lookup (T G r))"
begin

definition algorithm_3' :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Multigraph.edge list list" where
  "algorithm_3' G r \<equiv> map (map undirect) (algorithm_3 r (T G r) (I G r) (N G r))"

end

subsection \<open>Verification of the correctness of the algorithm\<close>

subsubsection \<open>Assumptions on the input\<close>

locale path_search_valid_input = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes N :: "'b \<Rightarrow> nat"
  assumes "0 \<le> N v"
begin
end

locale algorithm_3_pre_valid_input = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes r :: 'b
  fixes T :: 't
  fixes P :: 'g
  fixes N :: "'b \<Rightarrow> nat"
  assumes steps_1_2_3_high_2: "steps_1_2_3_high_2 r (\<lambda>v. incidence v P) (T_lookup T) N"
begin
sublocale path_search_valid_input
  sorry
end

abbreviation (in algorithm_3_pre) algorithm_3_pre_valid_input' where
  "algorithm_3_pre_valid_input' \<equiv>
   algorithm_3_pre_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T_update
    insert"

locale algorithm_3_valid_input = algorithm_3
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes G :: 'g
  fixes r :: 'b
  assumes biconnected_multigraph: "biconnected_multigraph other (P.E G)"
  assumes r_mem_V: "r \<in> Multigraph.V (P.E G)"
begin
sublocale algorithm_3_pre_valid_input
  where T = "T G r"
    and P = "I G r"
    and N = "N G r"
  sorry
end

abbreviation (in algorithm_3) algorithm_3_valid_input' where
  "algorithm_3_valid_input' \<equiv>
   algorithm_3_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T
    N
    I
    T_update
    insert"

subsubsection \<open>Loop invariants\<close>

locale path_search_invar = path_search_valid_input
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes \<sigma> :: "('b, 't, 'g, 'a) state"
    (* QUESTION: Use P.E instead? *)
  assumes finite_multigraph: "finite (undirect ` P.A (multigraph \<sigma>))"
  assumes simple_multigraph: "simple (undirect ` P.A (multigraph \<sigma>))"
  assumes finite_Cs: "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) finite"
  assumes no_separation_pair_Cs: "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>))). \<not> (\<exists>a b. is_separation_pair G a b)"
    (* TODO: Order. *)
  assumes palm_tree_2: "palm_tree_2 (root \<sigma>) (T_lookup (tree \<sigma>)) (\<lambda>v. incidence v (multigraph \<sigma>))"
begin
end

abbreviation (in path_search) path_search_invar' where
  "path_search_invar' N \<equiv>
   path_search_invar
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    N
    T_update
    insert"

abbreviation (in path_search_valid_input) path_search_invar'' where
  "path_search_invar'' \<equiv> path_search_invar' N"

lemma (in algorithm_3_pre_valid_input) path_search_invar_init:
  shows "path_search_invar' N (init r T P)"
  sorry

subsubsection \<open>Termination\<close>

lemma (in path_search_valid_input) path_search_dom:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_dom (N, \<sigma>)"
  sorry

lemma (in path_search_invar) path_search_dom:
  shows "path_search_dom (N, \<sigma>)"
  using path_search_invar_axioms
  by (intro path_search_dom)

lemma (in path_search) path_search_simps:
  assumes "path_search_invar' N \<sigma>"
  shows
    "path_search N \<sigma> =
     (if \<not> DONE \<sigma>
      then let e = hd (stack \<sigma>);
               \<sigma>1 = \<sigma>\<lparr>stack := tl (stack \<sigma>)\<rparr>
           in if tree_arc_2 e \<sigma>1
              then let \<sigma>2 = path_search N (\<sigma>1\<lparr>stack := incidence_2 (multigraph \<sigma>1) (head e) @ stack \<sigma>1\<rparr>);
                       \<sigma>3 = \<sigma>2\<lparr>ESTACK := e # ESTACK \<sigma>2\<rparr>;
                       \<sigma>4 = algorithm_5 N e \<sigma>3;
                       \<sigma>5 = algorithm_6 N e \<sigma>4
                   in \<sigma>5
              else \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>
      else \<sigma>)"
  using assms
  by (intro path_search_invar.path_search_dom path_search.psimps)

lemma (in path_search) path_search_induct:
  assumes "path_search_invar' N \<sigma>"
  assumes
    "\<And>N \<sigma>.
        (\<And>e \<sigma>1.
            \<not> DONE \<sigma> \<Longrightarrow>
            e = hd (stack \<sigma>) \<Longrightarrow>
            \<sigma>1 = \<sigma>\<lparr>stack := tl (stack \<sigma>)\<rparr> \<Longrightarrow>
            tree_arc_2 e \<sigma>1 \<Longrightarrow> P N (\<sigma>1\<lparr>stack := incidence_2 (multigraph \<sigma>1) (head e) @ stack \<sigma>1\<rparr>)) \<Longrightarrow>
        P N \<sigma>"
  shows "P N \<sigma>"
  using assms
  by (blast intro: path_search_invar.path_search_dom path_search.pinduct)

subsubsection \<open>Correctness\<close>

lemma (in path_search_valid_input) root_path_search:
  assumes "path_search_invar'' \<sigma>"
  shows "root (path_search N \<sigma>) = root \<sigma>"
  using assms
proof (induct rule: path_search_induct[OF assms])
  case (1 N \<sigma>)
  then show ?case sorry
qed

end


section \<open>The $A_{T,E}$ Algorithm\<close>

theory Ate_Defs
imports Heard_Of.HOModel "../Consensus_Types"
begin

text \<open>The contents of this file have been taken almost verbatim from the
  Heard Of Model AFP entry. The only difference is that the types have been
  changed.\<close>

subsection \<open>Model of the algorithm\<close>

text \<open>The following record models the local state of a process.\<close>

record 'val pstate =
  x :: "'val"              \<comment> \<open>current value held by process\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, but no
  decision has yet been taken.
\<close>

definition Ate_initState where
  "Ate_initState p st \<equiv> (decide st = None)"

locale ate_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes TNaE:"T \<ge> 2*(N + 2*\<alpha> - E)"
      and TltN:"T < N"
      and EltN:"E < N"

begin

text \<open>The following are consequences of the assumptions on the parameters.\<close>

lemma majE: "2 * (E - \<alpha>) \<ge> N"
using TNaE TltN by auto

lemma Egta: "E > \<alpha>"
using majE EltN by auto

lemma Tge2a: "T \<ge> 2 * \<alpha>"
using TNaE EltN by auto

text \<open>
  At every round, each process sends its current \<open>x\<close>.
  If it received more than \<open>T\<close> messages, it selects the smallest value
  and store it in \<open>x\<close>. As in algorithm \emph{OneThirdRule}, we
  therefore require values to be linearly ordered.

  If more than \<open>E\<close> messages holding the same value are received,
  the process decides that value.
\<close>

definition mostOftenRcvd where
  "mostOftenRcvd (msgs::process \<Rightarrow> 'val option) \<equiv>
   {v. \<forall>w. card {qq. msgs qq = Some w} \<le> card {qq. msgs qq = Some v}}"

definition
  Ate_sendMsg :: "nat \<Rightarrow> process \<Rightarrow> process \<Rightarrow> 'val pstate \<Rightarrow> 'val"
where
  "Ate_sendMsg r p q st \<equiv> x st"

definition
  Ate_nextState :: "nat \<Rightarrow> process \<Rightarrow> ('val::linorder) pstate \<Rightarrow> (process \<Rightarrow> 'val option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ate_nextState r p st msgs st' \<equiv>
     (if card {q. msgs q \<noteq> None} > T
      then x st' = Min (mostOftenRcvd msgs)
      else x st' = x st)
   \<and> (   (\<exists>v. card {q. msgs q = Some v} > E  \<and> decide st' = Some v)
       \<or> \<not> (\<exists>v. card {q. msgs q = Some v} > E)
         \<and> decide st' = decide st)"

subsection \<open>Communication predicate for $A_{T,E}$\<close>

definition Ate_commPerRd where
  "Ate_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>"

text \<open>
  The global communication predicate stipulates the three following
  conditions:
  \begin{itemize}
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>T\<close> messages,
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>E\<close> uncorrupted messages,
  \item and there are infinitely many rounds in which more than
    \<open>E - \<alpha>\<close> processes receive uncorrupted messages from the
    same set of processes, which contains more than \<open>T\<close> processes.
  \end{itemize}
\<close>
definition
  Ate_commGlobal where
  "Ate_commGlobal HOs SHOs \<equiv>
     (\<forall>r p. \<exists>r' > r. card (HOs r' p) > T)
   \<and> (\<forall>r p.  \<exists>r' > r. card (SHOs r' p \<inter> HOs r' p) > E)
   \<and> (\<forall>r. \<exists>r' > r. \<exists>\<pi>1 \<pi>2.
        card \<pi>1 > E - \<alpha>
      \<and> card \<pi>2 > T
      \<and> (\<forall>p \<in> \<pi>1. HOs r' p = \<pi>2 \<and> SHOs r' p \<inter> HOs r' p = \<pi>2))"

subsection \<open>The $A_{T,E}$ Heard-Of machine\<close>

text \<open>
  We now define the non-coordinated SHO machine for the Ate algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition Ate_SHOMachine where
  "Ate_SHOMachine = \<lparr>
    CinitState =  (\<lambda> p st crd. Ate_initState p (st::('val::linorder) pstate)),
    sendMsg =  Ate_sendMsg,
    CnextState = (\<lambda> r p st msgs crd st'. Ate_nextState r p st msgs st'),
    SHOcommPerRd = (Ate_commPerRd:: process HO \<Rightarrow> process HO \<Rightarrow> bool),
    SHOcommGlobal = Ate_commGlobal
   \<rparr>"

abbreviation
  "Ate_M \<equiv> (Ate_SHOMachine::(process, 'val::linorder pstate, 'val) SHOMachine)"

end   \<comment> \<open>locale @{text "ate_parameters"}\<close>

end   (* theory AteDefs *)


theory PrettyPrinting
  imports
    ExecutiblePolyProps
    PolyAtoms
    Polynomials.Show_Polynomials
    Polynomials.Power_Products
begin

global_interpretation drlex_pm: linorder drlex_pm drlex_pm_strict
  defines Min_drlex_pm = "linorder.Min drlex_pm"
    and Max_drlex_pm = "linorder.Max drlex_pm"
    and sorted_drlex_pm = "linorder.sorted drlex_pm"
    and sorted_list_of_set_drlex_pm = "linorder.sorted_list_of_set drlex_pm"
    and sort_key_drlex_pm = "linorder.sort_key drlex_pm"
    and insort_key_drlex_pm = "linorder.insort_key drlex_pm"
    and part_drlex_pm = "drlex_pm.part"
  apply unfold_locales
  subgoal by (simp add: drlex_pm_strict_def)
  subgoal by (simp add: drlex_pm_refl)
  subgoal using drlex_pm_trans by auto
  subgoal by (simp add: drlex_pm_antisym)
  subgoal by (simp add: drlex_pm_lin)
  done

definition "monomials_list mp = drlex_pm.sorted_list_of_set (monomials mp)"

definition shows_monomial_gen::"((nat \<times> nat) \<Rightarrow> shows) \<Rightarrow> ('a \<Rightarrow> shows) \<Rightarrow> shows \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option \<Rightarrow> shows" where
  "shows_monomial_gen shows_factor shows_coeff sep mon cff =
    shows_sep (\<lambda>s. case s of
        Inl cff \<Rightarrow> shows_coeff cff
      | Inr factor \<Rightarrow> shows_factor factor
    ) sep ((case cff of None \<Rightarrow> [] | Some cff \<Rightarrow> [Inl cff]) @ map Inr (Poly_Mapping.items mon))"

definition "shows_factor_compact factor =
  (case factor of (k, v) \<Rightarrow> shows_string ''x'' +@+ shows k +@+
    (if v = 1 then shows_string '''' else shows_string ''^'' +@+ shows v))"

definition "shows_factor_Var factor =
  (case factor of (k, v) \<Rightarrow> shows_string ''(Var '' +@+ shows k +@+ shows_string '')'' +@+
    (if v = 1 then shows_string '''' else shows_string ''^'' +@+ shows v))"

definition shows_monomial_compact::"('a \<Rightarrow> shows) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option \<Rightarrow> shows" where
  "shows_monomial_compact shows_coeff m =
    shows_monomial_gen shows_factor_compact shows_coeff (shows_string '' '') m"

definition shows_monomial_Var::"('a \<Rightarrow> shows) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option \<Rightarrow> shows" where
  "shows_monomial_Var shows_coeff m =
    shows_monomial_gen shows_factor_Var shows_coeff (shows_string ''*'') m"

fun shows_mpoly :: "bool \<Rightarrow> ('a \<Rightarrow> shows) \<Rightarrow> 'a::{zero,one} mpoly \<Rightarrow> shows" where
  "shows_mpoly input shows_coeff p = shows_sep (\<lambda>mon.
    (if input then shows_monomial_Var (\<lambda>x. shows_paren (shows_string ''Const '' +@+ shows_paren (shows_coeff x))) else shows_monomial_compact shows_coeff)
      mon
      (let cff = MPoly_Type.coeff p mon in if cff = 1 then None else Some cff)
  )
    (shows_string '' + '')
    (monomials_list p)"

definition "rat_of_real (x::real) =
  (if (\<exists>r::rat. x = of_rat r) then (THE r. x = of_rat r) else 99999999999.99999999999)"

lemma rat_of_real: "rat_of_real x = r" if "x = of_rat r"
  using that
  unfolding rat_of_real_def
  by simp

lemma rat_of_real_code[code]: "rat_of_real (Ratreal r) = r"
  by (simp add: rat_of_real)

definition "shows_real x = shows (rat_of_real x)"

experiment begin
abbreviation "foo \<equiv> ((Var 0::real mpoly) + Const (0.5) * Var 1 + Var 2)^3"
value [code] "shows_mpoly True shows_real foo ''''"
  (* rhs of foo\\_eq is the output of this \<open>value\<close> command *)
lemma foo_eq: "foo = (Var 0)^3 + (Const (3/2))*(Var 0)^2*(Var 1) + (Const (3))*(Var 0)^2*(Var 2) + (Const (3/4))*(Var 0)*(Var 1)^2 + (Const (3))*(Var 0)*(Var 1)*(Var 2) + (Const (3))*(Var 0)*(Var 2)^2 + (Const (1/8))*(Var 1)^3 + (Const (3/4))*(Var 1)^2*(Var 2) + (Const (3/2))*(Var 1)*(Var 2)^2 + (Var 2)^3"
  by code_simp
value [code] "shows_mpoly False shows_real foo ''''"
value [code] "shows_mpoly False (shows_paren o shows_mpoly False shows_real) (extract_var foo 0) ''''"
value [code] "shows_list_gen (shows_mpoly False shows_real)
  ''[]'' ''['' '', '' '']''
   (Polynomial.coeffs (mpoly_to_nested_poly foo 0)) ''''"
end

fun shows_atom :: "bool \<Rightarrow> atom \<Rightarrow> shows" where
  "shows_atom c (Eq p) = (shows_string ''('' +@+ shows_mpoly c shows_real p +@+ shows_string ''=0)'')"|
  "shows_atom c (Less p) = (shows_string ''('' +@+ shows_mpoly c shows_real p +@+ shows_string ''<0)'')"|
  "shows_atom c (Leq p) = (shows_string ''('' +@+ shows_mpoly c shows_real p +@+ shows_string ''<=0)'')"|
  "shows_atom c(Neq p) = (shows_string ''('' +@+ shows_mpoly c shows_real p +@+ shows_string ''~=0)'')"

fun depth' :: "'a fm \<Rightarrow> nat"where
  "depth' TrueF = 1"|
  "depth' FalseF = 1"|
  "depth' (Atom _) = 1"|
  "depth' (And \<phi> \<psi>) = max (depth' \<phi>) (depth' \<psi>) + 1"|
  "depth' (Or \<phi> \<psi>) = max (depth' \<phi>) (depth' \<psi>) + 1"|
  "depth' (Neg \<phi>) = depth' \<phi> + 1"|
  "depth' (ExQ \<phi>) = depth' \<phi> + 1"|
  "depth' (AllQ \<phi>) = depth' \<phi> + 1"|
  "depth' (AllN i \<phi>) = depth' \<phi>  + i * 2 + 1"|
  "depth' (ExN i \<phi>) = depth' \<phi>  + i * 2 + 1"

function shows_fm :: "bool \<Rightarrow> atom fm \<Rightarrow> shows" where
  "shows_fm c (Atom a) = shows_atom c a"|
  "shows_fm c (TrueF) = shows_string ''(T)''"|
  "shows_fm c (FalseF) = shows_string ''(F)''"|
  "shows_fm c (And \<phi> \<psi>) = (shows_string ''('' +@+ shows_fm c \<phi> +@+ shows_string '' and '' +@+ shows_fm c \<psi> +@+ shows_string ('')''))"|
  "shows_fm c (Or \<phi> \<psi>) = (shows_string ''('' +@+ shows_fm c \<phi> +@+ shows_string '' or '' +@+ shows_fm c \<psi>  +@+ shows_string '')'')"|
  "shows_fm c (Neg \<phi>) = (shows_string ''(neg '' +@+ shows_fm c \<phi> +@+ shows_string '')'')"|
  "shows_fm c (ExQ \<phi>) = (shows_string ''(exists'' +@+ shows_fm c \<phi> +@+ shows_string '')'')"|
  "shows_fm c (AllQ \<phi>) = (shows_string ''(forall'' +@+ shows_fm c \<phi> +@+ shows_string '')'')"|
  "shows_fm c (ExN 0 \<phi>) = shows_fm c \<phi>"|
  "shows_fm c (ExN (Suc n) \<phi>) = shows_fm c (ExQ(ExN n \<phi>))"|
  "shows_fm c (AllN 0 \<phi>) = shows_fm c \<phi>"|
  "shows_fm c (AllN (Suc n) \<phi>) = shows_fm c (AllQ(AllN n \<phi>))"
  by pat_completeness auto
termination
  apply(relation "measures [\<lambda>(_,A). depth' A]")
  by auto

value "shows_fm False (ExQ (Or (AllQ(And (Neg TrueF) (Neg FalseF))) (Atom(Eq(Const 4))))) []"
value "shows_fm True (ExQ (Or (AllQ(And (Neg TrueF) (Neg FalseF))) (Atom(Eq(Const 4))))) []"

end


(*
 * @TAG(OTHER_BSD)
 *)

section\<open>Increment and Decrement Machine Words Without Wrap-Around\<close>

theory Word_Next
imports
  Aligned
begin

text\<open>Previous and next words addresses, without wrap around.\<close>

definition word_next :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_next a \<equiv> if a = max_word then max_word else a + 1"

definition word_prev :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_prev a \<equiv> if a = 0 then 0 else a - 1"

text\<open>Examples:\<close>

lemma plus_one_helper[elim!]:
  "x < n + (1 :: 'a :: len word) \<Longrightarrow> x \<le> n"
  apply (simp add: word_less_nat_alt word_le_nat_alt field_simps)
  apply (case_tac "1 + n = 0")
   apply simp
  apply (subst(asm) unatSuc, assumption)
  apply arith
  done

lemma less_x_plus_1:
  fixes x :: "'a :: len word" shows
  "x \<noteq> max_word \<Longrightarrow> (y < (x + 1)) = (y < x \<or> y = x)"
  apply (rule iffI)
   apply (rule disjCI)
   apply (drule plus_one_helper)
   apply simp
  apply (subgoal_tac "x < x + 1")
   apply (erule disjE, simp_all)
  apply (rule plus_one_helper2 [OF order_refl])
  apply (rule notI, drule max_word_wrap)
  apply simp
  done

lemma word_Suc_leq: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
  using less_x_plus_1 word_le_less_eq by auto

lemma word_Suc_le: fixes k::"'a::len word" shows "x \<noteq> max_word \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
  by (meson not_less word_Suc_leq)

lemma word_lessThan_Suc_atMost: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> {..< k + 1} = {..k}"
  by(simp add: lessThan_def atMost_def word_Suc_leq)

lemma word_atLeastLessThan_Suc_atLeastAtMost:
  fixes l::"'a::len word" shows "u \<noteq> max_word \<Longrightarrow> {l..< u + 1} = {l..u}"
  by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)

lemma word_atLeastAtMost_Suc_greaterThanAtMost: fixes l::"'a::len word"
  shows "m \<noteq> max_word \<Longrightarrow> {m<..u} = {m + 1..u}"
  by(simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)

lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
  fixes l::"'a::len word"
  assumes "m \<noteq> max_word" and "l \<le> m" and "m \<le> u"
  shows "{l..m} \<union> {m+1..u} = {l..u}"
  proof -
  from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
  with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
  qed

lemma word_adjacent_union:
  "word_next e = s' \<Longrightarrow> s \<le> e \<Longrightarrow> s' \<le> e' \<Longrightarrow> {s..e} \<union> {s'..e'} = {s .. e'}"
  by (metis Un_absorb2 atLeastatMost_subset_iff ivl_disj_un_two(7) max_word_max
            word_atLeastLessThan_Suc_atLeastAtMost word_le_less_eq word_next_def linorder_not_le)

end