(*  Title:      HOL/Matrix_LP/ComputeFloat.thy
    Author:     Steven Obua
*)

section {* Floating Point Representation of the Reals *}

theory ComputeFloat
imports Complex_Main "~~/src/HOL/Library/Lattice_Algebras"
begin

ML_file "~~/src/Tools/float.ML"

definition int_of_real :: "real \<Rightarrow> int"
  where "int_of_real x = (SOME y. real y = x)"

definition real_is_int :: "real \<Rightarrow> bool"
  where "real_is_int x = (EX (u::int). x = real u)"

lemma real_is_int_def2: "real_is_int x = (x = real (int_of_real x))"
  by (auto simp add: real_is_int_def int_of_real_def)

lemma real_is_int_real[simp]: "real_is_int (real (x::int))"
by (auto simp add: real_is_int_def int_of_real_def)

lemma int_of_real_real[simp]: "int_of_real (real x) = x"
by (simp add: int_of_real_def)

lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real (int_of_real x) = x"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
apply (subst real_is_int_def2)
apply (simp add: real_is_int_add_int_of_real real_int_of_real)
done

lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_sub real_int_of_real)
done

lemma real_is_int_rep: "real_is_int x \<Longrightarrow> ?! (a::int). real a = x"
by (auto simp add: real_is_int_def)

lemma int_of_real_mult:
  assumes "real_is_int a" "real_is_int b"
  shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
  using assms
  by (auto simp add: real_is_int_def real_of_int_mult[symmetric]
           simp del: real_of_int_mult)

lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_mult)
done

lemma real_is_int_0[simp]: "real_is_int (0::real)"
by (simp add: real_is_int_def int_of_real_def)

lemma real_is_int_1[simp]: "real_is_int (1::real)"
proof -
  have "real_is_int (1::real) = real_is_int(real (1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_n1: "real_is_int (-1::real)"
proof -
  have "real_is_int (-1::real) = real_is_int(real (-1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_numeral[simp]: "real_is_int (numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "numeral x"])

lemma real_is_int_neg_numeral[simp]: "real_is_int (- numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "- numeral x"])

lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
by (simp add: int_of_real_def)

lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
proof -
  have 1: "(1::real) = real (1::int)" by auto
  show ?thesis by (simp only: 1 int_of_real_real)
qed

lemma int_of_real_numeral[simp]: "int_of_real (numeral b) = numeral b"
  unfolding int_of_real_def
  by (intro some_equality)
     (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)

lemma int_of_real_neg_numeral[simp]: "int_of_real (- numeral b) = - numeral b"
  unfolding int_of_real_def
  by (intro some_equality)
     (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)

lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
by (rule zdiv_int)

lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
by (rule zmod_int)

lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
by arith

lemma norm_0_1: "(1::_::numeral) = Numeral1"
  by auto

lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
  by simp

lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
  by simp

lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
  by simp

lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
  by simp

lemma int_pow_0: "(a::int)^0 = 1"
  by simp

lemma int_pow_1: "(a::int)^(Numeral1) = a"
  by simp

lemma one_eq_Numeral1_nring: "(1::'a::numeral) = Numeral1"
  by simp

lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
  by simp

lemma zpower_Pls: "(z::int)^0 = Numeral1"
  by simp

lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
  by simp

lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
  by simp

lemma lift_bool: "x \<Longrightarrow> x=True"
  by simp

lemma nlift_bool: "~x \<Longrightarrow> x=False"
  by simp

lemma not_false_eq_true: "(~ False) = True" by simp

lemma not_true_eq_false: "(~ True) = False" by simp

lemmas powerarith = nat_numeral zpower_numeral_even
  zpower_numeral_odd zpower_Pls

definition float :: "(int \<times> int) \<Rightarrow> real" where
  "float = (\<lambda>(a, b). real a * 2 powr real b)"

lemma float_add_l0: "float (0, e) + x = x"
  by (simp add: float_def)

lemma float_add_r0: "x + float (0, e) = x"
  by (simp add: float_def)

lemma float_add:
  "float (a1, e1) + float (a2, e2) =
  (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1) else float (a1*2^(nat (e1-e2))+a2, e2))"
  by (simp add: float_def algebra_simps powr_realpow[symmetric] powr_divide2[symmetric])

lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
  by (simp add: float_def)

lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
  by (simp add: float_def)

lemma float_mult:
  "float (a1, e1) * float (a2, e2) = (float (a1 * a2, e1 + e2))"
  by (simp add: float_def powr_add)

lemma float_minus:
  "- (float (a,b)) = float (-a, b)"
  by (simp add: float_def)

lemma zero_le_float:
  "(0 <= float (a,b)) = (0 <= a)"
  using powr_gt_zero[of 2 "real b", arith]
  by (simp add: float_def zero_le_mult_iff)

lemma float_le_zero:
  "(float (a,b) <= 0) = (a <= 0)"
  using powr_gt_zero[of 2 "real b", arith]
  by (simp add: float_def mult_le_0_iff)

lemma float_abs:
  "abs (float (a,b)) = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
  using powr_gt_zero[of 2 "real b", arith]
  by (simp add: float_def abs_if mult_less_0_iff)

lemma float_zero:
  "float (0, b) = 0"
  by (simp add: float_def)

lemma float_pprt:
  "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

lemma float_nprt:
  "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

definition lbound :: "real \<Rightarrow> real"
  where "lbound x = min 0 x"

definition ubound :: "real \<Rightarrow> real"
  where "ubound x = max 0 x"

lemma lbound: "lbound x \<le> x"
  by (simp add: lbound_def)

lemma ubound: "x \<le> ubound x"
  by (simp add: ubound_def)

lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
  by (auto simp: float_def lbound_def)

lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
  by (auto simp: float_def ubound_def)

lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
          float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound

(* for use with the compute oracle *)
lemmas arith = arith_simps rel_simps diff_nat_numeral nat_0
  nat_neg_numeral powerarith floatarith not_false_eq_true not_true_eq_false

ML_file "float_arith.ML"

end


theory Ex039
  imports Main
begin

lemma "\<not>(((A \<longrightarrow> B)  \<and>  A) \<and> (B \<longrightarrow> \<not>C \<and> \<not>C \<longrightarrow> B)) \<longrightarrow> ((\<not>D \<longrightarrow> B) \<or> (B \<longrightarrow> (\<not>B \<longrightarrow> \<not>A)))"
proof -
  {
    assume "\<not>(((A \<longrightarrow> B)  \<and>  A) \<and> (B \<longrightarrow> \<not>C \<and> \<not>C \<longrightarrow> B))"
    {
      assume a:"B"
      {
        assume b:"\<not>B"
        from a and b have False by contradiction
        hence "\<not>A" by (rule FalseE)
      }
      hence "\<not>B \<longrightarrow> \<not>A" by (rule impI)
    }
    hence "B \<longrightarrow> \<not>B \<longrightarrow> \<not>A" by (rule impI)
    hence "(\<not>D \<longrightarrow> B) \<or> (B \<longrightarrow> (\<not>B \<longrightarrow> \<not>A))" by (rule disjI2)
  }
  thus ?thesis by (rule impI)
qed


(* Title: Models of Quantales
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Models of Quantales\<close>

theory Quantale_Models
  imports Quantales
  "Dioid_Models_New"

begin

text \<open>Most of the models in this section expand those of dioids (and hence Kleene algebras). They really belong here,
because quantales form a stronger setting than dioids or Kleene algebras. They are, however, subsumed by the general lifting
results of partial semigroups and monoids from another AFP entry~\<^cite>\<open>"DongolGHS17"\<close>.\<close>

subsection \<open>Quantales of Booleans\<close>

instantiation bool :: bool_ab_unital_quantale
begin

definition "one_bool = True"

definition "times_bool = (\<and>)"

instance
  by intro_classes (auto simp: times_bool_def one_bool_def)

end

lemma bool_sep_eq_conj [simp]: "((x :: bool) * y) = (x \<and> y)"
  by (auto simp: times_bool_def)

lemma bool_impl_eq [simp]: "(x :: bool) \<rightarrow> y = -x \<squnion> y"
  by (clarsimp simp: bres_def)

subsection \<open>Powerset Quantales of Semigroups and Monoids\<close>

instance set :: (semigroup_mult) quantale
  by intro_classes (auto simp: times_set_def)

text \<open>With the definition of products on powersets (from the component of models of dioids) one
can prove the following mixed distributivity law.\<close>

lemma comp_dist_mix: "\<Squnion>(X::'a::quantale set) \<cdot> \<Squnion>Y = \<Squnion>(X \<cdot> Y)"
proof-
  have "\<Squnion>X \<cdot> \<Squnion>Y = (\<Squnion>x \<in> X. \<Squnion>y \<in> Y. x \<cdot> y)"
    by (metis (no_types, lifting) SUP_cong Sup_distl Sup_distr)
  also have "... = \<Squnion>{\<Squnion>{x \<cdot> y|y. y \<in> Y} |x. x \<in> X}"
    by (simp add: setcompr_eq_image)
  also have "... = \<Squnion>{x \<cdot> y |x y. x \<in> X \<and> y \<in> Y}"
    apply (rule antisym)
     apply (rule Sup_least, smt Collect_mono Sup_subset_mono mem_Collect_eq)
    by (rule Sup_least, smt Sup_upper calculation mem_Collect_eq psrpq.mult_isol_var)
  finally show ?thesis
    by (simp add: times_set_def)
qed

text \<open>Powerset quantales of monoids can nevertheless be formalised as instances.\<close>

instance set :: (monoid_mult) unital_quantale..

text \<open>There is much more to this example. In fact, every quantale can be represented, up to isomorphism,
as a certain quotient of a powerset quantale over some semigroup~\<^cite>\<open>"Rosenthal90"\<close>. This representation theorem is
formalised in the section on nuclei.\<close>

subsection \<open>Language, Relation, Trace and Path Quantales\<close>

text \<open>The language quantale is implcit in the powerset quantale over a semigroup or monoid. The free list monoid has
already been linked with the class of monoid as an instance in Isabelle's dioid components~\<^cite>\<open>"ArmstrongSW13"\<close>. I provide an alternative
interpretation. In all of the following locale statements, an interpretation for Sup-quantales fails, due to the occurance of some low level
less operations in the underlying model...\<close>

interpretation lan_quantale: unital_quantale "1::'a lan" "(\<cdot>)" Inf Sup inf "(\<subseteq>)" "(\<subset>)" sup "0" UNIV
  by unfold_locales (simp_all add: Inf_lower Inter_greatest Sup_upper Sup_least zero_set_def Sup_distr Sup_distl)

text \<open>The relation quantale follows.\<close>

interpretation rel_quantale: unital_quantale Id relcomp Inf Sup inf "(\<subseteq>)" "(\<subset>)" sup "{}" "UNIV"
  by (unfold_locales, auto)

text \<open>Traces alternate between state and action symbols, the first and last symbol of a trace being state symbols.
They can be associated with behaviours of automata or executions of programs.\<close>

interpretation trace_quantale: unital_quantale t_one t_prod Inf Sup inf "(\<subseteq>)" "(\<subset>)" sup t_zero UNIV
  by unfold_locales (auto simp: Inf_lower Inf_greatest Sup_upper Sup_least t_zero_def t_prod_def t_fusion_def)

text \<open>The final model corresponds to paths as sequences of states of an automata, transition system or graph.\<close>

interpretation path_quantale: unital_quantale p_one p_prod Inter Union "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV
  by unfold_locales (auto simp: p_prod_def)

text \<open>Rosenthal's book contains a wealth of other examples. Many of them come from ring theory
(e.g. the additive subgroups of a ring form a quantale and so do the left, right and two-sided ideals). Others are based
on the interval $[0,\infty]$. The first line of models was the original motivation for the study of quantales, the second
one is important to Lawvere's categorical generalisation of metric spaces. These examples are left for future consideration.\<close>

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Binary Predicates Restricted to Elements of a Given Set *}

theory Restricted_Predicates
imports Main
begin

definition restrict_to :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
  "restrict_to P A = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> P x y)"

definition reflp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "reflp_on P A \<longleftrightarrow> (\<forall>a\<in>A. P a a)"

definition transp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "transp_on P A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. P x y \<and> P y z \<longrightarrow> P x z)"

definition total_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "total_on P A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x = y \<or> P x y \<or> P y x)"

abbreviation "strict P \<equiv> \<lambda>x y. P x y \<and> \<not> (P y x)"

abbreviation "chain_on P f A \<equiv> \<forall>i. f i \<in> A \<and> P (f i) (f (Suc i))"

abbreviation "incomparable P \<equiv> \<lambda>x y. \<not> P x y \<and> \<not> P y x"

abbreviation "antichain_on P f A \<equiv> \<forall>(i::nat) j. f i \<in> A \<and> (i < j \<longrightarrow> incomparable P (f i) (f j))"

lemma strict_reflclp_conv [simp]:
  "strict (P\<^sup>=\<^sup>=) = strict P" by auto

lemma reflp_onI [Pure.intro]:
  "(\<And>a. a \<in> A \<Longrightarrow> P a a) \<Longrightarrow> reflp_on P A"
  unfolding reflp_on_def by blast

lemma transp_onI [Pure.intro]:
  "(\<And>x y z. \<lbrakk>x \<in> A; y \<in> A; z \<in> A; P x y; P y z\<rbrakk> \<Longrightarrow> P x z) \<Longrightarrow> transp_on P A"
  unfolding transp_on_def by blast

lemma total_onI [Pure.intro]:
  "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> x = y \<or> P x y \<or> P y x) \<Longrightarrow> total_on P A"
  unfolding total_on_def by blast

lemma reflp_on_reflclp_simp [simp]:
  assumes "reflp_on P A" and "a \<in> A" and "b \<in> A"
  shows "P\<^sup>=\<^sup>= a b = P a b"
  using assms by (auto simp: reflp_on_def)

lemma reflp_on_reflclp:
  "reflp_on (P\<^sup>=\<^sup>=) A"
  by (auto simp: reflp_on_def)

lemma reflp_on_converse_simp [simp]:
  "reflp_on P\<inverse>\<inverse> A \<longleftrightarrow> reflp_on P A"
  by (auto simp: reflp_on_def)

lemma transp_on_converse:
  "transp_on P A \<Longrightarrow> transp_on P\<inverse>\<inverse> A"
  unfolding transp_on_def by blast

lemma transp_on_converse_simp [simp]:
  "transp_on P\<inverse>\<inverse> A \<longleftrightarrow> transp_on P A"
  unfolding transp_on_def by blast

lemma transp_on_reflclp:
  "transp_on P A \<Longrightarrow> transp_on P\<^sup>=\<^sup>= A"
  unfolding transp_on_def by blast

lemma transp_on_strict:
  "transp_on P A \<Longrightarrow> transp_on (strict P) A"
  unfolding transp_on_def by blast

lemma reflp_on_subset:
  "A \<subseteq> B \<Longrightarrow> reflp_on P B \<Longrightarrow> reflp_on P A"
  by (auto simp: reflp_on_def)

lemma transp_on_subset:
  "A \<subseteq> B \<Longrightarrow> transp_on P B \<Longrightarrow> transp_on P A"
  by (auto simp: transp_on_def)

definition wfp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where
  "wfp_on P A \<longleftrightarrow> \<not> (\<exists>f. \<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i))"

definition inductive_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "inductive_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y) \<longrightarrow> (\<forall>x\<in>A. Q x))"

lemma inductive_onI [Pure.intro]:
  assumes "\<And>Q x. \<lbrakk>x \<in> A; (\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y)\<rbrakk> \<Longrightarrow>  Q x"
  shows "inductive_on P A"
  using assms unfolding inductive_on_def by metis

text {*
  If @{term P} is well-founded on @{term A} then every non-empty subset @{term Q} of @{term A} has a
  minimal element @{term z} w.r.t. @{term P}, i.e., all elements that are @{term P}-smaller than
  @{term z} are not in @{term Q}.
*}
lemma wfp_on_imp_minimal:
  assumes "wfp_on P A"
  shows "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x where *: "x \<in> Q" "Q \<subseteq> A"
    and "\<forall>z. \<exists>y. z \<in> Q \<longrightarrow> P y z \<and> y \<in> Q" by metis
  from choice [OF this(3)] obtain f
    where **: "\<forall>x\<in>Q. P (f x) x \<and> f x \<in> Q" by blast
  let ?S = "\<lambda>i. (f ^^ i) x"
  have ***: "\<forall>i. ?S i \<in> Q"
  proof
    fix i show "?S i \<in> Q" by (induct i) (auto simp: * **)
  qed
  then have "\<forall>i. ?S i \<in> A" using * by blast
  moreover have "\<forall>i. P (?S (Suc i)) (?S i)"
  proof
    fix i show "P (?S (Suc i)) (?S i)"
      by (induct i) (auto simp: * ** ***)
  qed
  ultimately have "\<forall>i. ?S i \<in> A \<and> P (?S (Suc i)) (?S i)" by blast
  with assms(1) show False
    unfolding wfp_on_def by fast
qed

lemma minimal_imp_inductive_on:
  assumes "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
  shows "inductive_on P A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x
    where *: "\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y"
    and **: "x \<in> A" "\<not> Q x"
    by (auto simp: inductive_on_def)
  let ?Q = "{x\<in>A. \<not> Q x}"
  from ** have "x \<in> ?Q" by auto
  moreover have "?Q \<subseteq> A" by auto
  ultimately obtain z where "z \<in> ?Q"
    and min: "\<forall>y. P y z \<longrightarrow> y \<notin> ?Q"
    using assms [THEN spec [of _ ?Q], THEN spec [of _ x]] by blast
  from `z \<in> ?Q` have "z \<in> A" and "\<not> Q z" by auto
  with * obtain y where "y \<in> A" and "P y z" and "\<not> Q y" by auto
  then have "y \<in> ?Q" by auto
  with `P y z` and min show False by auto
qed

lemmas wfp_on_imp_inductive_on =
  wfp_on_imp_minimal [THEN minimal_imp_inductive_on]

lemma inductive_on_induct [consumes 2, case_names less, induct pred: inductive_on]:
  assumes "inductive_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms unfolding inductive_on_def by metis

lemma inductive_on_imp_wfp_on:
  assumes "inductive_on P A"
  shows "wfp_on P A"
proof -
  let ?Q = "\<lambda>x. \<not> (\<exists>f. f 0 = x \<and> (\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)))"
  { fix x assume "x \<in> A"
    with assms have "?Q x"
    proof (induct rule: inductive_on_induct)
      fix y assume "y \<in> A" and IH: "\<And>x. x \<in> A \<Longrightarrow> P x y \<Longrightarrow> ?Q x"
      show "?Q y"
      proof (rule ccontr)
        assume "\<not> ?Q y"
        then obtain f where *: "f 0 = y"
          "\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)" by auto
        then have "P (f (Suc 0)) (f 0)" and "f (Suc 0) \<in> A" by auto
        with IH and * have "?Q (f (Suc 0))" by auto
        with * show False by auto
      qed
    qed }
  then show ?thesis unfolding wfp_on_def by blast
qed

definition antisymp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "antisymp_on P A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>A. P a b \<and> P b a \<longrightarrow> a = b)"

lemma antisymp_onI [Pure.intro]:
  "(\<And>a b. \<lbrakk>a \<in> A; b \<in> A; P a b; P b a\<rbrakk> \<Longrightarrow> a = b) \<Longrightarrow> antisymp_on P A"
  by (auto simp: antisymp_on_def)

lemma antisymp_on_reflclp [simp]:
  "antisymp_on P\<^sup>=\<^sup>= A = antisymp_on P A"
  by (auto simp: antisymp_on_def)

definition qo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "qo_on P A \<longleftrightarrow> reflp_on P A \<and> transp_on P A"

definition irreflp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "irreflp_on P A \<longleftrightarrow> (\<forall>a\<in>A. \<not> P a a)"

definition po_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "po_on P A \<longleftrightarrow> (irreflp_on P A \<and> transp_on P A)"

lemma po_onI [Pure.intro]:
  "\<lbrakk>irreflp_on P A; transp_on P A\<rbrakk> \<Longrightarrow> po_on P A"
  by (auto simp: po_on_def)

lemma irreflp_onI [Pure.intro]:
  "(\<And>a. a \<in> A \<Longrightarrow> \<not> P a a) \<Longrightarrow> irreflp_on P A"
  unfolding irreflp_on_def by blast

lemma irreflp_on_converse:
  "irreflp_on P A \<Longrightarrow> irreflp_on P\<inverse>\<inverse> A"
  unfolding irreflp_on_def by blast

lemma irreflp_on_converse_simp [simp]:
  "irreflp_on P\<inverse>\<inverse> A \<longleftrightarrow> irreflp_on P A"
  by (auto simp: irreflp_on_def)

lemma po_on_converse_simp [simp]:
  "po_on P\<inverse>\<inverse> A \<longleftrightarrow> po_on P A"
  by (simp add: po_on_def)

lemma po_on_imp_qo_on:
  "po_on P A \<Longrightarrow> qo_on (P\<^sup>=\<^sup>=) A"
  unfolding po_on_def qo_on_def
  by (metis reflp_on_reflclp transp_on_reflclp)

lemma po_on_imp_irreflp_on:
  "po_on P A \<Longrightarrow> irreflp_on P A"
  by (auto simp: po_on_def)

lemma po_on_imp_transp_on:
  "po_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: po_on_def)

lemma irreflp_on_subset:
  assumes "A \<subseteq> B" and "irreflp_on P B"
  shows "irreflp_on P A"
  using assms by (auto simp: irreflp_on_def)

lemma po_on_subset:
  assumes "A \<subseteq> B" and "po_on P B"
  shows "po_on P A"
  using transp_on_subset and irreflp_on_subset and assms
  unfolding po_on_def by blast

lemma transp_on_irreflp_on_imp_antisymp_on:
  assumes "transp_on P A" and "irreflp_on P A"
  shows "antisymp_on (P\<^sup>=\<^sup>=) A"
proof
  fix a b assume "a \<in> A"
    and "b \<in> A" and "P\<^sup>=\<^sup>= a b" and "P\<^sup>=\<^sup>= b a"
  show "a = b"
  proof (rule ccontr)
    assume "a \<noteq> b"
    with `P\<^sup>=\<^sup>= a b` and `P\<^sup>=\<^sup>= b a` have "P a b" and "P b a" by auto
    with `transp_on P A` and `a \<in> A` and `b \<in> A` have "P a a" unfolding transp_on_def by blast
    with `irreflp_on P A` and `a \<in> A` show False unfolding irreflp_on_def by blast
  qed
qed

lemma po_on_imp_antisymp_on:
  assumes "po_on P A"
  shows "antisymp_on (P\<^sup>=\<^sup>=) A"
  using transp_on_irreflp_on_imp_antisymp_on [of P A]
    and assms
  unfolding po_on_def by blast

lemma strict_reflclp [simp]:
  assumes "x \<in> A" and "y \<in> A"
    and "transp_on P A" and "irreflp_on P A"
  shows "strict (P\<^sup>=\<^sup>=) x y = P x y"
  using assms unfolding transp_on_def irreflp_on_def
  by blast

lemma qo_on_imp_reflp_on:
  "qo_on P A \<Longrightarrow> reflp_on P A"
  by (auto simp: qo_on_def)

lemma qo_on_imp_transp_on:
  "qo_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: qo_on_def)

lemma qo_on_subset:
  "A \<subseteq> B \<Longrightarrow> qo_on P B \<Longrightarrow> qo_on P A"
  unfolding qo_on_def
  using reflp_on_subset
    and transp_on_subset by blast

text {*
  Quasi-orders are instances of the @{class preorder} class.
*}
lemma qo_on_UNIV_conv:
  "qo_on P UNIV \<longleftrightarrow> class.preorder P (strict P)" (is "?lhs = ?rhs")
proof
  assume "?lhs" then show "?rhs"
    unfolding qo_on_def class.preorder_def
    using qo_on_imp_reflp_on [of P UNIV]
      and qo_on_imp_transp_on [of P UNIV]
    by (auto simp: reflp_on_def) (unfold transp_on_def, blast)
next
  assume "?rhs" then show "?lhs"
    unfolding class.preorder_def
    by (auto simp: qo_on_def reflp_on_def transp_on_def)
qed

lemma wfp_on_iff_inductive_on:
  "wfp_on P A \<longleftrightarrow> inductive_on P A"
  by (blast intro: inductive_on_imp_wfp_on wfp_on_imp_inductive_on)

lemma wfp_on_iff_minimal:
  "wfp_on P A \<longleftrightarrow> (\<forall>Q x.
     x \<in> Q \<and> Q \<subseteq> A \<longrightarrow>
     (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q))"
  using wfp_on_imp_minimal [of P A]
    and minimal_imp_inductive_on [of A P]
    and inductive_on_imp_wfp_on [of P A]
    by blast

text {*
  Every non-empty well-founded set @{term A} has a minimal element, i.e., an element that is not
  greater than any other element.
*}
lemma wfp_on_imp_has_min_elt:
  assumes "wfp_on P A" and "A \<noteq> {}"
  shows "\<exists>x\<in>A. \<forall>y\<in>A. \<not> P y x"
  using assms unfolding wfp_on_iff_minimal by force

lemma wfp_on_induct [consumes 2, case_names less, induct pred: wfp_on]:
  assumes "wfp_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms and inductive_on_induct [of P A x]
  unfolding wfp_on_iff_inductive_on by blast

lemma wfp_on_UNIV [simp]:
  "wfp_on P UNIV \<longleftrightarrow> wfP P"
  unfolding wfp_on_iff_inductive_on inductive_on_def wfP_def wf_def by force

subsection {* Measures on Sets (Instead of Full Types) *}

definition
  inv_image_betw ::
    "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
where
  "inv_image_betw P f A B = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y))"

definition
  measure_on :: "('a \<Rightarrow> nat) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "measure_on f A = inv_image_betw (op <) f A UNIV"

lemma in_inv_image_betw [simp]:
  "inv_image_betw P f A B x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y)"
  by (auto simp: inv_image_betw_def)

lemma in_measure_on [simp, code_unfold]:
  "measure_on f A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x < f y"
  by (simp add: measure_on_def)

lemma wfp_on_inv_image_betw [simp, intro!]:
  assumes "wfp_on P B"
  shows "wfp_on (inv_image_betw P f A B) A" (is "wfp_on ?P A")
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain g where "\<forall>i. g i \<in> A \<and> ?P (g (Suc i)) (g i)" by (auto simp: wfp_on_def)
  with assms show False by (auto simp: wfp_on_def)
qed

lemma wfp_less:
  "wfp_on (op <) (UNIV :: nat set)"
  using wf_less by (auto simp: wfP_def)

lemma wfp_on_measure_on [iff]:
  "wfp_on (measure_on f A) A"
  unfolding measure_on_def
  by (rule wfp_less [THEN wfp_on_inv_image_betw])

lemma wfp_on_mono:
  "A \<subseteq> B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> wfp_on Q B \<Longrightarrow> wfp_on P A"
  unfolding wfp_on_def by (metis set_mp)

lemma wfp_on_subset:
  "A \<subseteq> B \<Longrightarrow> wfp_on P B \<Longrightarrow> wfp_on P A"
  using wfp_on_mono by blast

lemma restrict_to_iff [iff]:
  "restrict_to P A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> P x y"
  by (simp add: restrict_to_def)

lemma wfp_on_restrict_to [simp]:
  "wfp_on (restrict_to P A) A = wfp_on P A"
  by (auto simp: wfp_on_def)

lemma irreflp_on_strict [simp, intro]:
  "irreflp_on (strict P) A"
  by (auto simp: irreflp_on_def)

lemma transp_on_map':
  assumes "transp_on Q B"
    and "g ` A \<subseteq> B"
    and "h ` A \<subseteq> B"
    and "\<And>x. x \<in> A \<Longrightarrow> Q\<^sup>=\<^sup>= (h x) (g x)"
  shows "transp_on (\<lambda>x y. Q (g x) (h y)) A"
  using assms unfolding transp_on_def
  by auto (metis imageI set_mp)

lemma transp_on_map:
  assumes "transp_on Q B"
    and "h ` A \<subseteq> B"
  shows "transp_on (\<lambda>x y. Q (h x) (h y)) A"
  using transp_on_map' [of Q B h A h, simplified, OF assms] by blast

lemma irreflp_on_map:
  assumes "irreflp_on Q B"
    and "h ` A \<subseteq> B"
  shows "irreflp_on (\<lambda>x y. Q (h x) (h y)) A"
  using assms unfolding irreflp_on_def by auto

lemma po_on_map:
  assumes "po_on Q B"
    and "h ` A \<subseteq> B"
  shows "po_on (\<lambda>x y. Q (h x) (h y)) A"
  using assms and transp_on_map and irreflp_on_map
  unfolding po_on_def by auto

lemma chain_on_transp_on_less:
  assumes "chain_on P f A" and "transp_on P A" and "i < j"
  shows "P (f i) (f j)"
using `i < j`
proof (induct j)
  case 0 then show ?case by simp
next
  case (Suc j)
  show ?case
  proof (cases "i = j")
    case True
    with Suc show ?thesis using assms(1) by simp
  next
    case False
    with Suc have "P (f i) (f j)" by force
    moreover from assms have "P (f j) (f (Suc j))" by auto
    ultimately show ?thesis using assms(1, 2) unfolding transp_on_def by blast
  qed
qed

lemma wfp_on_imp_irreflp_on:
  assumes "wfp_on P A"
  shows "irreflp_on P A"
proof
  fix x
  assume "x \<in> A"
  show "\<not> P x x"
  proof
    let ?f = "\<lambda>_. x"
    assume "P x x"
    then have "\<forall>i. P (?f (Suc i)) (?f i)" by blast
    with `x \<in> A` have "\<not> wfp_on P A" by (auto simp: wfp_on_def)
    with assms show False by contradiction
  qed
qed

inductive
  accessible_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool"
  for P and A
where
  accessible_onI [Pure.intro]:
    "\<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> accessible_on P A y\<rbrakk> \<Longrightarrow> accessible_on P A x"

lemma accessible_on_imp_mem:
  assumes "accessible_on P A a"
  shows "a \<in> A"
  using assms by (induct) auto

lemma accessible_on_induct [consumes 1, induct pred: accessible_on]:
  assumes *: "accessible_on P A a"
    and IH: "\<And>x. \<lbrakk>accessible_on P A x; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
  shows "Q a"
  by (rule * [THEN accessible_on.induct]) (auto intro: IH accessible_onI)

lemma accessible_on_downward:
  "accessible_on P A b \<Longrightarrow> a \<in> A \<Longrightarrow> P a b \<Longrightarrow> accessible_on P A a"
  by (cases rule: accessible_on.cases) fast

lemma accessible_on_restrict_to_downwards:
  assumes "(restrict_to P A)\<^sup>+\<^sup>+ a b" and "accessible_on P A b"
  shows "accessible_on P A a"
  using assms by (induct) (auto dest: accessible_on_imp_mem accessible_on_downward)

lemma accessible_on_imp_inductive_on:
  assumes "\<forall>x\<in>A. accessible_on P A x"
  shows "inductive_on P A"
proof
  fix Q x
  assume "x \<in> A"
    and *: "\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y"
  with assms have "accessible_on P A x" by auto
  then show "Q x"
  proof (induct)
    case (1 z)
    then have "z \<in> A" by (blast dest: accessible_on_imp_mem)
    show ?case by (rule *) fact+
  qed
qed

lemmas accessible_on_imp_wfp_on = accessible_on_imp_inductive_on [THEN inductive_on_imp_wfp_on]

lemma wfp_on_tranclp_imp_wfp_on:
  assumes "wfp_on (P\<^sup>+\<^sup>+) A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma inductive_on_imp_accessible_on:
  assumes "inductive_on P A"
  shows "\<forall>x\<in>A. accessible_on P A x"
proof
  fix x
  assume "x \<in> A"
  with assms show "accessible_on P A x"
    by (induct) (auto intro: accessible_onI)
qed

lemma inductive_on_accessible_on_conv:
  "inductive_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
  using inductive_on_imp_accessible_on
    and accessible_on_imp_inductive_on
    by blast

lemmas wfp_on_imp_accessible_on =
  wfp_on_imp_inductive_on [THEN inductive_on_imp_accessible_on]

lemma accessible_on_tranclp:
  assumes "accessible_on P A x"
  shows "accessible_on ((restrict_to P A)\<^sup>+\<^sup>+) A x"
    (is "accessible_on ?P A x")
  using assms
proof (induct)
  case (1 x)
  then have "x \<in> A" by (blast dest: accessible_on_imp_mem)
  then show ?case
  proof (rule accessible_onI)
    fix y
    assume "y \<in> A"
    assume "?P y x"
    then show "accessible_on ?P A y"
    proof (cases)
      assume "restrict_to P A y x"
      with 1 and `y \<in> A` show ?thesis by blast
    next
      fix z
      assume "?P y z" and "restrict_to P A z x"
      with 1 have "accessible_on ?P A z" by (auto simp: restrict_to_def)
      from accessible_on_downward [OF this `y \<in> A` `?P y z`]
        show ?thesis .
    qed
  qed
qed

lemma wfp_on_restrict_to_tranclp:
  assumes "wfp_on P A"
  shows "wfp_on ((restrict_to P A)\<^sup>+\<^sup>+) A"
  using wfp_on_imp_accessible_on [OF assms]
    and accessible_on_tranclp [of P A]
    and accessible_on_imp_wfp_on [of A "(restrict_to P A)\<^sup>+\<^sup>+"]
    by blast

lemma wfp_on_restrict_to_tranclp':
  assumes "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma wfp_on_restrict_to_tranclp_wfp_on_conv:
  "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A \<longleftrightarrow> wfp_on P A"
  using wfp_on_restrict_to_tranclp [of P A]
    and wfp_on_restrict_to_tranclp' [of P A]
    by blast

lemma tranclp_idemp [simp]:
  "(P\<^sup>+\<^sup>+)\<^sup>+\<^sup>+ = P\<^sup>+\<^sup>+" (is "?l = ?r")
proof (intro ext)
  fix x y
  show "?l x y = ?r x y"
  proof
    assume "?l x y" then show "?r x y" by (induct) auto
  next
    assume "?r x y" then show "?l x y" by (induct) auto
  qed
qed

(*TODO: move the following 3 lemmas to Transitive_Closure?*)
lemma stepfun_imp_tranclp:
  assumes "f 0 = x" and "f (Suc n) = z"
    and "\<forall>i\<le>n. P (f i) (f (Suc i))"
  shows "P\<^sup>+\<^sup>+ x z"
  using assms
  by (induct n arbitrary: x z)
     (auto intro: tranclp.trancl_into_trancl)

lemma tranclp_imp_stepfun:
  assumes "P\<^sup>+\<^sup>+ x z"
  shows "\<exists>f n. f 0 = x \<and> f (Suc n) = z \<and> (\<forall>i\<le>n. P (f i) (f (Suc i)))"
    (is "\<exists>f n. ?P x z f n")
  using assms
proof (induct rule: tranclp_induct)
  case (base y)
  let ?f = "(\<lambda>_. y)(0 := x)"
  have "?f 0 = x" and "?f (Suc 0) = y" by auto
  moreover have "\<forall>i\<le>0. P (?f i) (?f (Suc i))"
    using base by auto
  ultimately show ?case by blast
next
  case (step y z)
  then obtain f n where IH: "?P x y f n" by blast
  then have *: "\<forall>i\<le>n. P (f i) (f (Suc i))"
    and [simp]: "f 0 = x" "f (Suc n) = y"
    by auto
  let ?n = "Suc n"
  let ?f = "f(Suc ?n := z)"
  have "?f 0 = x" and "?f (Suc ?n) = z" by auto
  moreover have "\<forall>i\<le>?n. P (?f i) (?f (Suc i))"
    using `P y z` and * by auto
  ultimately show ?case by blast
qed

lemma tranclp_stepfun_conv:
  "P\<^sup>+\<^sup>+ x y \<longleftrightarrow> (\<exists>f n. f 0 = x \<and> f (Suc n) = y \<and> (\<forall>i\<le>n. P (f i) (f (Suc i))))"
  using tranclp_imp_stepfun and stepfun_imp_tranclp by metis

subsection {* Facts About Predecessor Sets *}

lemma qo_on_predecessor_subset_conv':
  assumes "qo_on P A" and "B \<subseteq> A" and "C \<subseteq> A"
  shows "{x\<in>A. \<exists>y\<in>B. P x y} \<subseteq> {x\<in>A. \<exists>y\<in>C. P x y} \<longleftrightarrow> (\<forall>x\<in>B. \<exists>y\<in>C. P x y)"
  using assms
  by (auto simp: subset_eq qo_on_def reflp_on_def, unfold transp_on_def) metis+

lemma qo_on_predecessor_subset_conv:
  "\<lbrakk>qo_on P A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> {z\<in>A. P z x} \<subseteq> {z\<in>A. P z y} \<longleftrightarrow> P x y"
  using qo_on_predecessor_subset_conv' [of P A "{x}" "{y}"] by simp

lemma po_on_predecessors_eq_conv:
  assumes "po_on P A" and "x \<in> A" and "y \<in> A"
  shows "{z\<in>A. P\<^sup>=\<^sup>= z x} = {z\<in>A. P\<^sup>=\<^sup>= z y} \<longleftrightarrow> x = y"
  using assms(2-)
    and reflp_on_reflclp [of P A]
    and po_on_imp_antisymp_on [OF `po_on P A`]
    unfolding antisymp_on_def reflp_on_def
    by blast

lemma restrict_to_rtranclp:
  assumes "transp_on P A"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P\<^sup>=\<^sup>= x y"
proof -
  { assume "(restrict_to P A)\<^sup>*\<^sup>* x y"
    then have "P\<^sup>=\<^sup>= x y" using assms
      by (induct) (auto, unfold transp_on_def, blast) }
  with assms show ?thesis by auto
qed

lemma reflp_on_restrict_to_rtranclp:
  assumes "reflp_on P A" and "transp_on P A"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P x y"
  unfolding restrict_to_rtranclp [OF assms(2-)]
  unfolding reflp_on_reflclp_simp [OF assms(1, 3-)] ..

end


(*  Title:      Depth-First Search
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Maintainer: Yasuhiko Minamide <minamide at cs.tsukuba.ac.jp>
*)

section "Depth-First Search"

theory DFS
imports Main
begin

subsection "Definition of Graphs"

typedecl node
type_synonym graph = "(node * node) list"

primrec nexts :: "[graph, node] \<Rightarrow> node list"
where
  "nexts [] n = []"
| "nexts (e#es) n = (if fst e = n then snd e # nexts es n else nexts es n)"

definition nextss :: "[graph, node list] \<Rightarrow> node set"
  where "nextss g xs = set g `` set xs"

lemma nextss_Cons: "nextss g (x#xs) = set (nexts g x) \<union> nextss g xs"
  unfolding nextss_def by (auto simp add:Image_def nexts_set)

definition reachable :: "[graph, node list] \<Rightarrow> node set"
  where "reachable g xs = (set g)\<^sup>* `` set xs"

subsection "Depth-First Search with Stack"

definition nodes_of :: "graph \<Rightarrow> node set"
  where "nodes_of g = set (map fst g @ map snd g)"

lemma [simp]: "finite (nodes_of g - set ys)"
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

function
  dfs :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  dfs_base: "dfs g [] ys = ys"
| dfs_inductive: "dfs g (x#xs) ys = (if List.member ys x then dfs g xs ys
                        else dfs g (nexts g x@xs) (x#ys))"
by pat_completeness auto

termination
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
by (case_tac  "x \<in> nodes_of g") (auto simp add: List.member_def)

text \<open>
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
\<close>

subsection "Depth-First Search with Nested-Recursion"

function
  dfs2 :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  "dfs2 g [] ys = ys"
|  dfs2_inductive:
          "dfs2 g (x#xs) ys = (if List.member ys x then dfs2 g xs ys
                               else dfs2 g xs (dfs2 g (nexts g x) (x#ys)))"
by pat_completeness auto

lemma dfs2_invariant: "dfs2_dom (g, xs, ys) \<Longrightarrow> set ys \<subseteq> set (dfs2 g xs ys)"
by (induct g xs ys rule: dfs2.pinduct) (force simp add: dfs2.psimps)+

termination dfs2
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
apply (case_tac  "x \<in> nodes_of g")
apply (auto simp add: List.member_def)[2]
by (insert dfs2_invariant) force

(*lemma dfs2_induct[induct type]:
  assumes B: "\<And>g ys. P g [] ys" and
  H: "\<And>g x xs ys.
        \<lbrakk>\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys));
         \<not> x mem ys \<longrightarrow> P g (nexts g x) (x # ys); x mem ys \<longrightarrow> P g xs ys\<rbrakk>
         \<Longrightarrow> P g (x # xs) ys"
  shows "P u v w"

proof (induct u v w rule: dfs2.induct)
  case 1 show ?case by (rule B)
next
  case (2 g x xs ys)
  show ?case
  proof (rule H)
    show "\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys))"
    proof
      assume *: "\<not> x mem ys"
      have "set (x#ys) \<subseteq> set (dfs2 (g, nexts g x, x # ys))"
        by (rule dfs2_inv)
      with 2 * show "P g xs (dfs2 (g, nexts g x, x # ys))"
        by auto
    qed
  qed (rule 2)+
qed
*)

lemma dfs_app: "dfs g (xs@ys) zs = dfs g ys (dfs g xs zs)"
  by (induct g xs zs rule: dfs.induct) auto

lemma "dfs2 g xs ys = dfs g xs ys"
  by (induct g xs ys rule: dfs2.induct) (auto simp add: dfs_app)

subsection "Basic Properties"

lemma visit_subset_dfs: "set ys \<subseteq> set (dfs g xs ys)"
  by (induct g xs ys rule: dfs.induct) auto

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
proof(induct g xs ys rule:dfs.induct)
  case(2 g x xs ys)
  show ?case
  proof(cases "x \<in> set ys")
    case True
    have "set ys \<subseteq> set (dfs g xs ys)"
      by (rule visit_subset_dfs)
    with 2 and True show ?thesis
      by (auto simp add: List.member_def)
  next
    case False
    have "set (x#ys) \<subseteq> set (dfs g (nexts g x @ xs) (x#ys))"
      by(rule visit_subset_dfs)
    with 2 and False show ?thesis
      by (auto simp add: List.member_def)
  qed
qed(simp)

lemma nextss_closed_dfs'[rule_format]:
 "nextss g ys \<subseteq> set xs \<union> set ys \<longrightarrow> nextss g (dfs g xs ys) \<subseteq> set (dfs g xs ys)"
  by (induct g xs ys rule:dfs.induct, auto simp add:nextss_Cons List.member_def)

lemma nextss_closed_dfs: "nextss g (dfs g xs []) \<subseteq> set (dfs g xs [])"
  by (rule nextss_closed_dfs', simp add: nextss_def)

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    {
      fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X"
        by (induct) (insert assms y, auto simp add: Image_def)
    }
    then show ?thesis unfolding Image_def by auto
  qed
qed auto

lemma reachable_closed_dfs: "reachable g xs \<subseteq> set(dfs g xs [])"
proof -
  have "reachable g xs \<subseteq> reachable g (dfs g xs [])"
    unfolding reachable_def by (rule Image_mono) (auto simp add: next_subset_dfs)
  also have "\<dots> = set(dfs g xs [])"
    unfolding reachable_def
  proof (rule Image_closed_trancl)
    from nextss_closed_dfs
    show "set g `` set (dfs g xs []) \<subseteq> set (dfs g xs [])"
      by (simp add: nextss_def)
  qed
  finally show ?thesis .
qed

lemma reachable_nexts: "reachable g (nexts g x) \<subseteq> reachable g [x]"
  unfolding reachable_def
  by (auto intro: converse_rtrancl_into_rtrancl simp: nexts_set)

lemma reachable_append: "reachable g (xs @ ys) = reachable g xs \<union> reachable g ys"
  unfolding reachable_def by auto

lemma dfs_subset_reachable_visit_nodes: "set (dfs g xs ys) \<subseteq> reachable g xs \<union> set ys"
proof(induct g xs ys rule: dfs.induct)
  case 1
  then show ?case by simp
next
  case (2 g x xs ys)
  show ?case
  proof (cases "x \<in> set ys")
    case True
    with 2 show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  next
    case False
    have "reachable g (nexts g x) \<subseteq> reachable g [x]"
      by (rule reachable_nexts)
    hence a: "reachable g (nexts g x @ xs) \<subseteq> reachable g (x#xs)"
      by(simp add: reachable_append, auto simp add: reachable_def)
    with False 2
    show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  qed
qed

subsection "Correctness"

theorem dfs_eq_reachable: "set (dfs g xs []) = reachable g xs"
proof
  have "set (dfs g xs []) \<subseteq> reachable g xs \<union> set []"
    by (rule dfs_subset_reachable_visit_nodes[of g xs "[]"])
 thus "set (dfs g xs []) \<subseteq> reachable g xs"
   by simp
qed(rule reachable_closed_dfs)

theorem "y \<in> set (dfs g [x] []) = ((x,y) \<in> (set g)\<^sup>*)"
  by(simp only:dfs_eq_reachable reachable_def, auto)

subsection "Executable Code"

consts Node :: "int \<Rightarrow> node"

code_datatype Node

instantiation node :: equal
begin

definition equal_node :: "node \<Rightarrow> node \<Rightarrow> bool"
where
  [code del]: "equal_node = HOL.eq"

instance proof
qed (simp add: equal_node_def)

end

declare [[code abort: "HOL.equal :: node \<Rightarrow> node \<Rightarrow> bool"]]

export_code dfs dfs2 in SML file \<open>dfs.ML\<close>

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory ListLibLemmas
imports List_Lib LemmaBucket
begin

(* This theory contains various list results that
are used in proofs related to the abstract cdt_list.*)

(* Sorting a list given a partial ordering, where
        elements are only necessarily comparable if
        relation R holds between them. *)
locale partial_sort =
  fixes less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

  assumes all_comp: "\<And>x y. R x y \<Longrightarrow> (less x y \<or> less y x)"

  (*This is only necessary to guarantee the uniqueness of
    sorted lists. *)
  assumes antisym: "\<And>x y. R x y \<Longrightarrow> less x y \<and> less y x \<Longrightarrow> x = y"

  assumes trans: "\<And>x y z. less x y \<Longrightarrow>  less y z \<Longrightarrow> less x z"

begin

primrec pinsort :: " 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "pinsort x [] = [x]" |
   "pinsort x (y#ys) = (if (less x y) then (x#y#ys) else y#(pinsort x ys))"

inductive psorted :: "'a list \<Rightarrow> bool" where
  Nil [iff]: "psorted []"
| Cons: "\<forall>y\<in>set xs. less x y \<Longrightarrow> psorted xs \<Longrightarrow> psorted (x # xs)"

definition R_set where
"R_set S \<equiv> \<forall>x y. x \<in> S \<longrightarrow> y \<in> S \<longrightarrow> R x y"

abbreviation R_list where
"R_list xs \<equiv> R_set (set xs)"

definition psort :: "'a list \<Rightarrow> 'a list" where
"psort xs = foldr pinsort xs []"

end

context partial_sort begin

lemma psorted_Cons: "psorted (x#xs) = (psorted xs & (\<forall> y \<in> set xs. less x y))"
  apply (rule iffI)
  apply (erule psorted.cases,simp)
   apply clarsimp
  apply (rule psorted.Cons,clarsimp+)
  done

lemma psorted_distinct_set_unique:
assumes "psorted xs" "distinct xs" "psorted ys" "distinct ys" "set xs = set ys"
        "R_list xs"
shows "xs = ys"
proof -
  from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  from assms show ?thesis
  proof(induct rule:list_induct2[OF 1])
    case 1 show ?case by simp
  next
    case 2 thus ?case
    by (simp add: psorted_Cons R_set_def)
         (metis Diff_insert_absorb antisym insertE insert_iff)
  qed
qed

lemma pinsort_set: "set (pinsort a xs) = insert a (set xs)"
  apply (induct xs)
  apply simp
  apply simp
  apply blast
  done

lemma all_comp': "R x y \<Longrightarrow> \<not>less x y \<Longrightarrow> less y x"
  apply (cut_tac x=x and y=y in all_comp,simp+)
  done

lemma pinsort_sorted: "R_set (insert a (set xs)) \<Longrightarrow> psorted xs \<Longrightarrow> psorted (pinsort a xs)"
  apply (induct xs arbitrary: a)
  apply (simp add: psorted_Cons)
  apply (simp add: psorted_Cons)
  apply clarsimp
  apply (simp add: pinsort_set)
  apply (intro impI conjI)
    apply (intro ballI)
    apply (drule_tac x=x in bspec)
     apply simp
    apply (frule(1) trans)
    apply simp
   apply (simp add: R_set_def)
  apply (rule all_comp')
   apply (simp add: R_set_def)
  apply simp
  done

lemma psort_set: "set (psort xs) = set xs"
  apply (simp add: psort_def)
  apply (induct xs)
   apply simp
  apply (simp add: pinsort_set)
  done

lemma psort_psorted: "R_list xs \<Longrightarrow> psorted (psort xs)"
  apply (simp add: psort_def)
  apply (induct xs)
   apply simp
  apply simp
  apply (cut_tac xs =xs in psort_set)
  apply (simp add: psort_def)
  apply (rule pinsort_sorted)
   apply simp
  apply (simp add: R_set_def)
  done

lemma insort_length: "length (pinsort a xs) = Suc (length xs)"
  apply (induct xs)
  apply simp
  apply simp
  done

lemma psort_length: "length (psort xs) = length xs"
  apply (simp add: psort_def)
  apply (induct xs)
   apply simp
  apply simp
  apply (simp add: insort_length)
  done

lemma pinsort_distinct: "\<lbrakk>a \<notin> set xs; distinct xs\<rbrakk>
       \<Longrightarrow> distinct (pinsort a xs)"
  apply (induct xs)
  apply simp
  apply (clarsimp simp add: pinsort_set)
  done

lemma psort_distinct: "distinct xs \<Longrightarrow> distinct (psort xs)"
  apply (simp add: psort_def)
  apply (induct xs)
   apply simp
  apply simp
  apply (rule pinsort_distinct)
   apply (fold psort_def)
   apply (simp add: psort_set)+
  done

lemma in_can_split: "y \<in> set list \<Longrightarrow> \<exists>ys xs. list = xs @ (y # ys)"
  apply (induct list)
   apply simp
  apply clarsimp
  apply (elim disjE)
   apply simp
   apply force
  apply simp
  apply (elim exE)
  apply simp
  apply (rule_tac x=ys in exI)
  apply force
  done

lemma lsorted_sorted:
assumes lsorted: "\<And>x y xs ys . list = xs @ (x # y # ys) \<Longrightarrow> less x y"
shows "psorted list"
  apply (insert lsorted)
  apply atomize
  apply simp
  apply (induct list)
   apply simp
  apply (simp add: psorted_Cons)
  apply (rule context_conjI)
   apply (erule meta_mp)
   apply clarsimp
   apply (drule_tac x="a#xs" in spec)
   apply (drule_tac x=x in spec)
   apply (drule_tac x=y in spec)
   apply (erule mp)
   apply force
  apply (intro ballI)
  apply clarsimp
  apply (drule in_can_split)
  apply (elim exE)
  apply (drule_tac x="[]" in spec)
  apply simp
  apply (case_tac xs)
   apply simp
  apply (clarsimp simp add: psorted_Cons)
  apply (blast intro: trans)
  done

lemma psorted_set: "finite A \<Longrightarrow> R_set A \<Longrightarrow> \<exists>!xs. set xs = A \<and> psorted xs \<and> distinct xs"
  apply (drule finite_distinct_list)
  apply clarify
  apply (rule_tac a="psort xs" in ex1I)
   apply (auto simp: psorted_distinct_set_unique psort_set psort_psorted psort_distinct)
done

end

text \<open>These list operations roughly correspond to cdt
        operations.\<close>

lemma after_can_split: "after_in_list list x = Some y \<Longrightarrow> \<exists>ys xs. list = xs @ (x # y # ys)"
  apply (induct list x rule: after_in_list.induct)
  apply simp+
  apply (simp split: if_split_asm)
   apply force
  apply (elim exE)
  apply simp
  apply (rule_tac x="ys" in exI)
  apply simp
  done

lemma distinct_inj_middle: "distinct list \<Longrightarrow> list = (xa @ x # xb) \<Longrightarrow> list = (ya @ x # yb) \<Longrightarrow> xa = ya \<and> xb = yb"
  apply (induct list arbitrary: xa ya)
  apply simp
  apply clarsimp
  apply (case_tac "xa")
   apply simp
   apply (case_tac "ya")
    apply simp
   apply clarsimp
  apply clarsimp
  apply (case_tac "ya")
   apply (simp (no_asm_simp))
   apply simp
  apply clarsimp
  done

lemma after_can_split_distinct:
  "distinct list \<Longrightarrow> after_in_list list x = Some y \<Longrightarrow> \<exists>!ys. \<exists>!xs. list = xs @ (x # y # ys)"
  apply (frule after_can_split)
  apply (elim exE)
  apply (rule ex1I)
   apply (rule ex1I)
    apply assumption
   apply simp
  apply (elim ex1E)
  apply (thin_tac "\<forall>x. P x" for P)
  apply (frule_tac yb="y#ysa" in distinct_inj_middle,assumption+)
  apply simp
  done

lemma after_ignore_head: "x \<notin> set list \<Longrightarrow> after_in_list (list @ list') x = after_in_list list' x"
  apply (induct list x rule: after_in_list.induct)
  apply simp
   apply simp
   apply (case_tac list',simp+)
  done

lemma after_distinct_one_sibling: "distinct list \<Longrightarrow> list = xs @ x # y # ys \<Longrightarrow> after_in_list list x = Some y"
  apply (induct xs)
  apply simp
  apply simp
  apply clarsimp
  apply (subgoal_tac "after_in_list ((a # xs) @ (x # y # ys)) x = after_in_list (x # y # ys) x")
   apply simp
  apply (rule after_ignore_head)
  apply simp
  done

lemma (in partial_sort) after_order_sorted:
assumes after_order: "\<And>x y. after_in_list list x = Some y \<Longrightarrow> less x y"
assumes distinct: "distinct list"
shows "psorted list"
  apply (rule lsorted_sorted)
  apply (rule after_order)
  apply (erule after_distinct_one_sibling[OF distinct])
  done

lemma hd_not_after_in_list:
  "\<lbrakk>distinct xs; x \<notin> set xs\<rbrakk> \<Longrightarrow> after_in_list (x # xs) a \<noteq> Some x"
  apply (induct xs a rule: after_in_list.induct)
    apply simp+
  apply fastforce
  done

lemma after_in_list_inj:
  "\<lbrakk>distinct list; after_in_list list a = Some x; after_in_list list b = Some x\<rbrakk>
    \<Longrightarrow> a = b"
  apply(induct list)
   apply(simp)
  apply(simp)
  apply(case_tac "a=aa")
   apply(case_tac list, simp)
   apply(simp add: hd_not_after_in_list split: if_split_asm)
  apply(case_tac list, simp)
  apply(simp add: hd_not_after_in_list split: if_split_asm)
  done

lemma list_replace_ignore:"a \<notin> set list \<Longrightarrow> list_replace list a b = list"
  apply (simp add: list_replace_def)
  apply (induct list,clarsimp+)
  done

lemma list_replace_empty[simp]: "list_replace [] a b = []"
  by (simp add: list_replace_def)

lemma list_replace_empty2[simp]:
  "(list_replace list a b = []) = (list = [])"
  by (simp add: list_replace_def)

lemma after_in_list_list_replace: "\<lbrakk>p \<noteq> dest; p \<noteq> src;
         after_in_list list p = Some src\<rbrakk>
        \<Longrightarrow> after_in_list (list_replace list src dest) p = Some dest"
  apply (simp add: list_replace_def)
  apply (induct list)
   apply simp+
  apply (case_tac list)
   apply simp+
  apply (intro conjI impI,simp+)
  done

lemma replace_list_preserve_after: "dest \<notin> set list \<Longrightarrow> distinct list \<Longrightarrow>  after_in_list (list_replace list src dest) dest = after_in_list list src"
  apply (simp add: list_replace_def)
  apply (induct list src rule: after_in_list.induct)
    apply (simp+)
  apply fastforce
  done

lemma replace_list_preserve_after': "\<lbrakk>p \<noteq> dest; p \<noteq> src;
         after_in_list list p \<noteq> Some src\<rbrakk>
        \<Longrightarrow> after_in_list (list_replace list src dest) p = after_in_list list p"
  apply (simp add: list_replace_def)
  apply (induct list p rule: after_in_list.induct)
    apply (simp+)
  apply fastforce
  done

lemma distinct_after_in_list_not_self:
  "distinct list \<Longrightarrow> after_in_list list src \<noteq> Some src"
  apply (induct list,simp+)
  apply (case_tac list,clarsimp+)
  done

lemma set_list_insert_after:
  "set (list_insert_after list a b) = set list \<union> (if a \<in> set list then {b} else {})"
  apply(induct list)
   apply(simp)
  apply(simp)
  done

lemma distinct_list_insert_after:
  "\<lbrakk>distinct list; b \<notin> set list \<or> a \<notin> set list\<rbrakk> \<Longrightarrow> distinct (list_insert_after list a b)"
  apply(induct list)
   apply(simp)
  apply(fastforce simp: set_list_insert_after)
  done

lemma list_insert_after_after:
  "\<lbrakk>distinct list; b \<notin> set list; a \<in> set list\<rbrakk>
    \<Longrightarrow> after_in_list (list_insert_after list a b) p
    = (if p = a then Some b else if p = b then after_in_list list a else after_in_list list p)"
  apply(induct list p rule: after_in_list.induct)
    apply (simp split: if_split_asm)+
  apply fastforce
  done

lemma list_remove_removed:
  "set (list_remove list x) = (set list) - {x}"
  apply (induct list,simp+)
  apply blast
  done

lemma remove_distinct_helper: "\<lbrakk>distinct (list_remove list x); a \<noteq> x; a \<notin> set list;
        distinct list\<rbrakk>
       \<Longrightarrow> a \<notin> set (list_remove list x)"
  apply (induct list)
   apply (simp split: if_split_asm)+
  done

lemma list_remove_distinct:
  "distinct list \<Longrightarrow>  distinct (list_remove list x)"
  apply (induct list)
  apply (simp add: remove_distinct_helper split: if_split_asm)+
  done

lemma list_remove_none: "x \<notin> set list \<Longrightarrow> list_remove list x = list"
  apply (induct list)
  apply clarsimp+
  done

lemma replace_distinct: "x \<notin> set list \<Longrightarrow> distinct list \<Longrightarrow> distinct (list_replace list y x)"
  apply (induct list)
  apply (simp add: list_replace_def)+
  apply blast
  done

lemma set_list_replace_list:
  "\<lbrakk>distinct list; slot \<in> set list; slot \<notin> set list'\<rbrakk>
    \<Longrightarrow> set (list_replace_list list slot list') = set list \<union> set list' - {slot}"
  apply (induct list)
  apply auto
  done

lemma after_in_list_in_list:
  "after_in_list list a = Some b \<Longrightarrow> b \<in> set list"
  apply(induct list a arbitrary: b rule: after_in_list.induct)
  apply (simp split: if_split_asm)+
  done

lemma list_replace_empty_after_empty:
  "\<lbrakk>after_in_list list p = Some slot; distinct list\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot []) p = after_in_list list slot"
  apply(induct list slot rule: after_in_list.induct)
  apply (simp split: if_split_asm)+
   apply (case_tac xs,simp+)
  apply (case_tac xs,simp+)
  apply (auto dest!: after_in_list_in_list)
  done

lemma list_replace_after_fst_list:
  "\<lbrakk>after_in_list list p = Some slot; distinct list\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot (x # xs)) p = Some x"
  apply(induct list p rule: after_in_list.induct)
  apply (simp split: if_split_asm)+
  apply (drule after_in_list_in_list)+
  apply force
  done

lemma after_in_list_append_notin_hd:
  "p \<notin> set list' \<Longrightarrow> after_in_list (list' @ list) p = after_in_list list p"
  apply(induct list', simp, simp)
  apply(case_tac list', simp)
   apply(case_tac list, simp+)
   done

lemma after_in_list_append_last_hd:
  "\<lbrakk>p \<in> set list'; after_in_list list' p = None\<rbrakk>
    \<Longrightarrow> after_in_list (list' @ x # xs) p = Some x"
  apply(induct list' p rule: after_in_list.induct)
    apply(simp)
   apply(simp)
  apply(simp split: if_split_asm)
  done

lemma after_in_list_append_in_hd:
  "after_in_list list p = Some a \<Longrightarrow> after_in_list (list @ list') p = Some a"
  apply(induct list p rule: after_in_list.induct)
    apply(simp split: if_split_asm)+
    done

lemma after_in_list_in_list': "after_in_list list a = Some y \<Longrightarrow> a \<in> set list"
  apply (induct list a rule: after_in_list.induct)
  apply simp+
  apply force
  done

lemma list_replace_after_None_notin_new:
  "\<lbrakk>after_in_list list p = None; p \<notin> set list'\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot list') p = None"
  apply(induct list)
   apply(simp)
  apply(simp)
  apply(intro conjI impI)
   apply(simp)
   apply(case_tac list, simp)
    apply(induct list')
     apply(simp)
    apply(simp)
    apply(case_tac list', simp, simp)
   apply(simp split: if_split_asm)
    apply(simp add: after_in_list_append_notin_hd)
   apply(simp add: after_in_list_append_notin_hd)
  apply(case_tac "list_replace_list list slot list'")
   apply(simp)
  apply(simp)
  apply(case_tac list, simp, simp split: if_split_asm)
  done

lemma list_replace_after_notin_new:
  "\<lbrakk>after_in_list list p = Some a; a \<noteq> slot; p \<notin> set list'; p \<noteq> slot\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot list') p = Some a"
  apply(induct list)
   apply(simp)
  apply(simp)
  apply(intro conjI impI)
   apply(simp add: after_in_list_append_notin_hd)
   apply(case_tac list, simp, simp)
  apply(case_tac list, simp, simp split: if_split_asm)
  apply(insert after_in_list_append_notin_hd)
  apply(atomize)
  apply(erule_tac x=p in allE, erule_tac x="[aa]" in allE, erule_tac x="list' @ lista" in allE)
  apply(simp)
  done

lemma list_replace_after_None_notin_old:
  "\<lbrakk>after_in_list list' p = None; p \<in> set list'; p \<notin> set list\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot list') p = after_in_list list slot"
  apply(induct list)
   apply(simp)
  apply(simp)
  apply(intro conjI impI)
   apply(simp)
   apply(case_tac list)
    apply(simp)
   apply(simp add: after_in_list_append_last_hd)
  apply(case_tac "list_replace_list list slot list'")
   apply(simp)
   apply(case_tac list, simp, simp)
  apply(simp)
  apply(case_tac list, simp, simp)
  done

lemma list_replace_after_notin_old:
  "\<lbrakk>after_in_list list' p = Some a; p \<notin> set list; slot \<in> set list\<rbrakk>
    \<Longrightarrow> after_in_list (list_replace_list list slot list') p = Some a"
  apply(induct list)
   apply(simp)
  apply(simp)
  apply(intro conjI impI)
   apply(simp add: after_in_list_append_in_hd)
  apply(simp)
  apply(case_tac "list_replace_list list slot list'")
   apply(simp)
  apply(simp)
  done

lemma list_replace_set: "x \<in> set list \<Longrightarrow> set (list_replace list x y) = insert y (set (list) - {x})"
  apply (induct list)
  apply (simp add: list_replace_def)+
  apply (intro impI conjI)
  apply blast+
  done

lemma list_swap_both: "x \<in> set list \<Longrightarrow> y \<in> set list \<Longrightarrow> set (list_swap list x y) = set (list)"
  apply (induct list)
  apply (simp add: list_swap_def)+
  apply (intro impI conjI)
  apply blast+
  done

lemma list_swap_self[simp]: "list_swap list x x = list"
  apply (simp add: list_swap_def)
  done

lemma map_ignore: "x \<notin> set list \<Longrightarrow> (map (\<lambda>xa. if xa = x then y else xa)
             list) = list"
  apply (induct list)
  apply simp+
  apply blast
  done

lemma map_ignore2: "y \<notin> set list \<Longrightarrow> (map (\<lambda>xa. if xa = x then y else if xa = y then x else xa)
             list) = (map (\<lambda>xa. if xa = x then y else xa) list)"
  apply (simp add: map_ignore)
  done

lemma map_ignore2': "y \<notin> set list \<Longrightarrow> (map (\<lambda>xa. if xa = y then x else if xa = x then y else xa)
             list) = (map (\<lambda>xa. if xa = x then y else xa) list)"
  apply (simp add: map_ignore)
  apply force
  done

lemma swap_distinct_helper: "\<lbrakk>x \<in> set list; y \<noteq> x; y \<notin> set list; distinct list\<rbrakk>
       \<Longrightarrow> distinct (map (\<lambda>xa. if xa = x then y else xa) list)"
  apply (induct list)
  apply (simp add: map_ignore | elim conjE | intro impI conjI | blast)+
  done

lemma swap_distinct: "x \<in> set list \<Longrightarrow> y \<in> set list \<Longrightarrow> distinct list \<Longrightarrow> distinct (list_swap list x y)"
  apply (induct list)
  apply (simp add: list_swap_def)+
  apply (intro impI conjI,simp_all)
  apply (simp add: map_ignore2 map_ignore2' swap_distinct_helper | elim conjE | force)+
  done

lemma list_swap_none: "x \<notin> set list \<Longrightarrow> y \<notin> set list \<Longrightarrow> list_swap list x y = list"
  apply (induct list)
  apply (simp add: list_swap_def)+
  apply blast
  done

lemma list_swap_one: "x \<in> set list \<Longrightarrow> y \<notin> set list \<Longrightarrow> set (list_swap list x y) = insert y (set (list)) - {x}"
  apply (induct list)
  apply (simp add: list_swap_def)+
  apply (intro impI conjI)
  apply blast+
  done

lemma list_swap_one': "x \<notin> set list \<Longrightarrow> y \<in> set list \<Longrightarrow> set (list_swap list x y) = insert x (set (list)) - {y}"
  apply (induct list)
  apply (simp add: list_swap_def)+
  apply (intro impI conjI)
  apply blast+
  done

lemma in_swapped_list: "y \<in> set list \<Longrightarrow> x \<in> set (list_swap list x y)"
  apply (case_tac "x \<in> set list")
   apply (simp add: list_swap_both)
  apply (simp add: list_swap_one')
  apply (intro notI,simp)
  done

lemma list_swap_empty : "(list_swap list x y = []) = (list = [])"
  by(simp add: list_swap_def)

lemma distinct_after_in_list_antisym:
  "distinct list \<Longrightarrow> after_in_list list a = Some b \<Longrightarrow> after_in_list list b \<noteq> Some a"
  apply (induct list b arbitrary: a rule: after_in_list.induct)
    apply simp+
  apply (case_tac xs)
   apply (clarsimp split: if_split_asm | intro impI conjI)+
  done

lemma after_in_listD: "after_in_list list x = Some y \<Longrightarrow> \<exists>xs ys. list = xs @ (x # y # ys) \<and> x \<notin> set xs"
  apply (induct list x arbitrary: a rule: after_in_list.induct)
    apply (simp split: if_split_asm | elim exE | force)+
  apply (rule_tac x="x # xsa" in exI)
  apply simp
  done

lemma list_swap_symmetric: "list_swap list a b = list_swap list b a"
  apply (simp add: list_swap_def)
  done

lemma list_swap_preserve_after:
  "\<lbrakk>desta \<notin> set list; distinct list\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) desta =
   after_in_list list srca"
  apply (induct list desta rule: after_in_list.induct)
  apply (simp add: list_swap_def)+
  apply force
  done

lemma list_swap_preserve_after':
 "\<lbrakk>p \<noteq> desta; p \<noteq> srca; after_in_list list p = Some srca\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) p = Some desta"
  apply (induct list p rule: after_in_list.induct)
  apply (simp add: list_swap_def)+
  apply force
  done

lemma list_swap_does_swap:
       "\<lbrakk>distinct list; after_in_list list desta = Some srca\<rbrakk>
       \<Longrightarrow> after_in_list (list_swap list srca desta) srca = Some desta"
  apply (induct list srca rule: after_in_list.induct)
    apply (simp add: list_swap_def)+
  apply (elim conjE)
  apply (intro impI conjI,simp_all)
   apply (frule after_in_list_in_list,simp)+
  done

lemma list_swap_does_swap':
  "distinct list \<Longrightarrow> after_in_list list srca = Some desta \<Longrightarrow>
                after_in_list (list_swap list srca desta) srca =
          after_in_list list desta"
  apply (induct list srca rule: after_in_list.induct)
    apply (simp add: list_swap_def)+
  apply (elim conjE)
  apply (intro impI conjI,simp_all)
   apply (case_tac xs)
    apply (clarsimp+)[2]
  apply (case_tac xs)
   apply clarsimp+
done

lemmas list_swap_preserve_after'' = list_swap_preserve_after'[simplified list_swap_symmetric]

lemma list_swap_preserve_Some_other:
 "\<lbrakk>z \<noteq> desta; z \<noteq> srca; after_in_list list srca = Some z\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) desta = Some z"
  apply (induct list srca rule: after_in_list.induct)
  apply (simp add: list_swap_def)+
  apply force
  done

lemmas list_swap_preserve_Some_other' = list_swap_preserve_Some_other[simplified list_swap_symmetric]

lemma list_swap_preserve_None:
 "\<lbrakk>after_in_list list srca = None\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list desta srca) desta = None"
  apply (induct list srca rule: after_in_list.induct)
  apply (simp add: list_swap_def)+
  apply force
  done

lemma list_swap_preserve_None':
 "\<lbrakk>after_in_list list srca = None\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) desta = None"
  apply (subst list_swap_symmetric)
  apply (erule list_swap_preserve_None)
  done

lemma list_swap_preserve_after_None:
 "\<lbrakk>p \<noteq> desta; p \<noteq> srca; after_in_list list p = None\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) p = None"
  apply (induct list p rule: after_in_list.induct)
  apply (simp add: list_swap_def)+
  apply force
  done

lemma list_swap_preserve_Some_other_distinct:
 "\<lbrakk>distinct list; z \<noteq> desta; after_in_list list srca = Some z\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) desta = Some z"
  apply (rule list_swap_preserve_Some_other)
  apply simp+
   apply (rule notI)
   apply simp
   apply (frule distinct_after_in_list_not_self[where src=srca])
   apply simp+
  done

lemma list_swap_preserve_separate:
 "\<lbrakk>p \<noteq> desta; p \<noteq> srca; z \<noteq> desta; z \<noteq> srca; after_in_list list p = Some z\<rbrakk>
\<Longrightarrow> after_in_list (list_swap list srca desta) p = Some z"
  apply (induct list p rule: after_in_list.induct)
  apply (simp add: list_swap_def split: if_split_asm)+
  apply (intro impI conjI)
   apply simp+
  done

fun after_in_list_list where
  "after_in_list_list [] a = []" |
  "after_in_list_list (x # xs) a = (if a = x then xs else after_in_list_list xs a)"

lemma after_in_list_list_in_list:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "y \<in> set (after_in_list_list list x) \<Longrightarrow> y \<in> set list"
  apply(induct list arbitrary:x y)
  apply(simp)
  apply(case_tac "x=a", simp+)
done

lemma range_nat_relation_induct:
"\<lbrakk> m = Suc (n + k) ; m < cap ; \<forall>n. Suc n < cap \<longrightarrow> P n (Suc n );
   \<forall>i j k. i < cap \<and> j < cap \<and> k < cap \<longrightarrow> P i j \<longrightarrow> P j k \<longrightarrow> P i k \<rbrakk> \<Longrightarrow>  P n m"
  apply (clarify)
  apply (thin_tac "m = t" for t)
  apply (induct k)
   apply (drule_tac x = "n" in spec)
   apply (erule impE, simp, simp)
  apply (frule_tac x = "Suc (n + k)" in spec)
  apply (erule impE)
   apply (simp only: add_Suc_right)
  apply (rotate_tac 3, frule_tac x = n in spec)
  apply (rotate_tac -1, drule_tac x = "Suc (n + k)" in spec)
  apply (rotate_tac -1, drule_tac x = "Suc (n + Suc k) " in spec)
  apply (erule impE)
   apply (intro conjI)
     apply (rule_tac y = "Suc (n + Suc k)" in less_trans)
      apply (rule less_SucI)
      apply (simp only: add_Suc_right)+
done

lemma indexed_trancl_as_set_helper : "\<lbrakk>p < q; q < length list; list ! p = a; list ! q = b;
        q = Suc (p + k); Suc n < length list\<rbrakk>
       \<Longrightarrow> (a, b) \<in> {(i, j). \<exists>p. Suc p <length list \<and> list ! p = i \<and> list ! Suc p = j}\<^sup>+"
  apply (induct k arbitrary: p q a b)
   apply (rule r_into_trancl,simp, rule_tac x = p in exI, simp)
  apply (atomize)
  apply (erule_tac x = p in allE, erule_tac x = "Suc (p + k)" in allE, erule_tac x = "a" in allE, erule_tac x = "list ! Suc (p + k)" in allE)
  apply (elim impE)
        apply (simp)+
  apply (rule_tac b = "list ! Suc (p + k)" in trancl_into_trancl)
   apply (simp)+
  apply (rule_tac x = "Suc (p + k)" in exI, simp)
  done

lemma indexed_trancl_as_set: "distinct list \<Longrightarrow> {(i, j). \<exists> p q. p < q \<and> q < length list \<and> list ! p = i \<and> list ! q = j }
      = {(i, j). \<exists> p. Suc p < length list \<and> list ! p = i \<and> list ! Suc p = j }\<^sup>+"
  apply (rule equalityI)
    apply (rule subsetI)
    apply (case_tac x, simp)
    apply (elim exE conjE)
    apply (frule less_imp_Suc_add)
    apply (erule exE)
    apply (rule_tac cap = "length list" and m = q and n = p and k = k in range_nat_relation_induct)
      apply (simp)
      apply (simp)
      apply (rule allI, rule impI)
      apply (rule_tac p = p and q = q and k = k and n = n in indexed_trancl_as_set_helper)
        apply (simp)+
  apply (rule subsetI)
    apply (case_tac x, simp)
    apply (erule trancl_induct)
      apply (simp, elim exE conjE)
      apply (rule_tac x = p in exI, rule_tac x = "Suc p" in exI, simp)
      apply (simp)
      apply (rotate_tac 4, erule exE, rule_tac x = p in exI)
      apply (erule exE, rule_tac x = "Suc pa" in exI)
      apply (intro conjI)
        defer
        apply (simp)
        apply (erule exE, simp)
        apply (simp)
        apply (erule exE)
        apply (subgoal_tac "pa = q")
          apply (simp)
          apply (frule_tac xs = list and i = pa and j = q in nth_eq_iff_index_eq)
            apply (simp)+
done

lemma indexed_trancl_irrefl: "distinct list \<Longrightarrow> (x,x) \<notin> {(i, j). \<exists> p. Suc p < length list \<and> list ! p = i \<and> list ! Suc p = j }\<^sup>+"
 apply (frule indexed_trancl_as_set [THEN sym])
 apply (simp)
 apply (intro allI impI notI)
 apply (frule_tac xs = list and i = p and j = q in nth_eq_iff_index_eq)
 apply (simp+)
done

lemma after_in_list_trancl_indexed_trancl: "distinct list \<Longrightarrow> {(p, q). after_in_list list p = Some q}\<^sup>+ = {(i, j). \<exists> p. Suc p < length list \<and> list ! p = i \<and> list ! Suc p = j }\<^sup>+"
  apply (rule_tac f = "\<lambda> x. x\<^sup>+" in  arg_cong)
  apply (intro equalityI subsetI)

  apply (case_tac x, simp)
  apply (induct list)
   apply (simp)
   apply (case_tac "a = aa")
     apply (rule_tac x = 0 in exI, case_tac list, simp, simp)
     apply (case_tac list, simp, simp)
     apply (atomize, drule_tac x = x in spec, drule_tac x = aa in spec, drule_tac x = b in spec, simp)
     apply (erule exE, rule_tac x = "Suc p" in exI, simp)

  apply (case_tac x, simp)
  apply (induct list)
    apply (simp)
    apply (case_tac "a = aa")
      apply (erule exE)
      apply (subgoal_tac "p = 0")
        apply (case_tac list, simp, simp)
        apply (subgoal_tac "distinct (aa # list)")
          apply (frule_tac i = 0 and j = p and xs = "aa # list" in nth_eq_iff_index_eq)
          apply (simp, simp, simp, simp)
    apply (atomize, drule_tac x = x in spec, drule_tac x = aa in spec, drule_tac x = b in spec, simp)
    apply (drule mp)
      apply (erule exE)
      apply (case_tac p, simp, simp)
      apply (rule_tac x = nat in exI, simp)
   apply (case_tac list, simp, simp)
done

lemma distinct_after_in_list_not_self_trancl:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "distinct list \<Longrightarrow> (x, x) \<notin> {(p, q). after_in_list list p = Some q}\<^sup>+"
  by (simp add: after_in_list_trancl_indexed_trancl indexed_trancl_irrefl)

lemma distinct_after_in_list_in_list_trancl:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "\<lbrakk>distinct list; (x, y) \<in> {(p, q). after_in_list list q = Some p}\<^sup>+\<rbrakk> \<Longrightarrow> x \<in> set list"
  by(erule tranclE2, (drule CollectD, simp, drule after_in_list_in_list, simp)+)

lemma after_in_list_trancl_prepend:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "\<lbrakk>distinct (y # list); x \<in> set list\<rbrakk> \<Longrightarrow> (y, x) \<in> {(n, p). after_in_list (y # list) n = Some p}\<^sup>+"
  apply(induct list arbitrary:x y)
    apply(simp)
    apply(case_tac "x=a")
      apply(rule r_into_trancl)
      apply(simp)
      apply(drule set_ConsD)
      apply(elim disjE)
        apply(simp)
        apply(atomize)
        apply(drule_tac x=x in spec)
        apply(drule_tac x=y in spec)
        apply(drule_tac mp)
          apply(simp)
        apply(drule_tac mp)
          apply(simp)
        apply(erule trancl_induct)
          apply(drule CollectD, simp)
          apply(rule_tac b = a in trancl_into_trancl2)
            apply(simp)
          apply(rule r_into_trancl)
          apply(rule_tac a = "(a,ya)" in CollectI)
          apply(clarsimp)
          apply(case_tac list)
            apply(simp)
            apply(simp)
          apply(case_tac "ya=a")
            apply(drule CollectD)
            apply(simp del:after_in_list.simps)
            apply(drule after_in_list_in_list')
            apply(simp)
            apply(rule_tac b=ya in trancl_into_trancl)
              apply(simp)
              apply(drule CollectD)
              apply(rule CollectI)
              apply(case_tac "ya=y")
                apply(frule_tac x=y in distinct_after_in_list_not_self_trancl)
                apply(simp)
                apply(case_tac list)
                  apply(simp)
                  apply(simp)
done

lemma after_in_list_append_not_hd:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "a \<noteq> x \<Longrightarrow> after_in_list (a # list) x = after_in_list list x"
by (case_tac list, simp, simp)

lemma trancl_Collect_rev:
  "(a, b) \<in> {(x, y). P x y}\<^sup>+ \<Longrightarrow> (b, a) \<in> {(x, y). P y x}\<^sup>+"
  apply(induct rule: trancl_induct)
   apply(fastforce intro: trancl_into_trancl2)+
   done

lemma prepend_after_in_list_distinct : "distinct (a # list) \<Longrightarrow> {(next, p). after_in_list (a # list) p = Some next}\<^sup>+ =
       {(next, p). after_in_list (list) p = Some next}\<^sup>+ \<union>
       set list \<times> {a} "
  apply (rule equalityI)
   (* \<subseteq> direction *)
   apply (rule subsetI, case_tac x)
   apply (simp)
   apply (erule trancl_induct)
     (* base case *)
    apply (drule CollectD, simp)
    apply (case_tac list, simp)
    apply (simp split:if_split_asm)
    apply (rule r_into_trancl)
    apply (rule CollectI, simp)
    (* Inductive case *)
   apply (drule CollectD, simp)
   apply (erule disjE)
    apply (case_tac "a \<noteq> z")
     apply (rule disjI1)
     apply (rule_tac b =y in trancl_into_trancl)
      apply (simp, case_tac list, simp, simp)

    apply (simp)
    apply (rule disjI2)
    apply (erule conjE)
    apply (frule_tac x = aa and y = y in distinct_after_in_list_in_list_trancl)
     apply (simp)
    apply (simp)
   apply (subgoal_tac "after_in_list (a # list) z \<noteq> Some a", simp)
   apply (rule_tac hd_not_after_in_list, simp, simp)
(* \<supseteq> direction *)
  apply (rule subsetI)
  apply (case_tac x)
  apply (simp)
  apply (erule disjE)
    (* transitive case *)
   apply (erule tranclE2)
    apply (drule CollectD, simp)
    apply (subgoal_tac "b \<noteq> a")
     apply (rule r_into_trancl)
     apply (rule CollectI, simp)
     apply (case_tac list, simp, simp)
    apply (frule after_in_list_in_list')
    apply (erule conjE)
    apply (blast)
   apply (rule_tac y = c in trancl_trans)
    apply (subgoal_tac "c \<noteq> a")
     apply (case_tac list, simp, simp)
     apply (case_tac "aaa = aa")
      apply (rule r_into_trancl)
      apply (rule CollectI, simp)

     apply (rule r_into_trancl)
     apply (rule CollectI, simp)
    apply (erule CollectE, simp)
    apply (frule after_in_list_in_list')
    apply (erule conjE, blast)
   apply (erule trancl_induct)
    apply (simp)
    apply (rule r_into_trancl, simp)
    apply (subgoal_tac "y \<noteq> a")
     apply (case_tac list, simp, simp)
    apply (rotate_tac 3)
    apply (frule after_in_list_in_list')
    apply (erule conjE, blast)
   apply (rule_tac b = y in trancl_into_trancl, simp)
   apply (rule CollectI, simp)
   apply (subgoal_tac "a \<noteq> z")
    apply (case_tac list, simp, simp)
   apply (rotate_tac 3)
   apply (frule after_in_list_in_list')
   apply (blast)
(* not so transitive case *)
  apply (subgoal_tac "distinct (a # list)")
   apply (frule_tac x = aa in after_in_list_trancl_prepend, simp, simp)
   apply (rule trancl_Collect_rev, simp)
  apply (simp)
done

lemma after_in_list_in_cons:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "\<lbrakk>after_in_list (x # xs) y = Some z; distinct (x # xs); y \<in> set xs\<rbrakk> \<Longrightarrow> z \<in> set xs"
  apply(case_tac "y=x")
  apply(simp)
  apply(simp add:after_in_list_append_not_hd after_in_list_in_list)
done

lemma after_in_list_list_set:
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "distinct list \<Longrightarrow>
         set (after_in_list_list list x)
         = {a. (a, x) \<in> {(next, p). after_in_list list p = Some next}\<^sup>+}"
  apply(intro equalityI)
  (* \<subseteq> *)
   apply(induct list arbitrary:x)
    apply(simp)
   apply(atomize)
   apply(simp)
   apply(rule conjI, rule impI, rule subsetI)
    apply(rule_tac a = xa in CollectI)
    apply(rule trancl_Collect_rev)
    apply(rule after_in_list_trancl_prepend)
     apply(simp)
    apply(simp)
   apply(clarify)
   apply(drule_tac x=x in spec)
   apply(drule_tac B="{a. (a, x) \<in> {(next, p). after_in_list list p = Some next}\<^sup>+}" in set_rev_mp)
    apply(simp)
   apply(drule CollectD)
   apply(simp add:prepend_after_in_list_distinct)
 (* \<supseteq> *)
  apply(clarsimp)
  apply(drule trancl_Collect_rev)
  apply(erule trancl_induct)
    (* base *)
   apply(simp)
   apply(induct list arbitrary:x)
    apply(simp)
   apply(case_tac "a=x")
    apply(frule_tac src=x in distinct_after_in_list_not_self)
    apply(simp)
    apply(drule after_in_list_in_list)
    apply(simp)+
   apply(drule_tac list=list in after_in_list_append_not_hd)
   apply(simp)
   (* inductive *)
  apply(simp)
  apply(drule trancl_Collect_rev)
  apply(induct list arbitrary: x)
   apply(simp)
  apply(case_tac "a\<noteq>x")
  (* a\<noteq>x *)
   apply(atomize, drule_tac x=y in spec, drule_tac x=z in spec, drule_tac x=x in spec)
   apply(simp add:prepend_after_in_list_distinct)
   apply(case_tac "a=y")
    apply(simp add:after_in_list_list_in_list)
   apply(simp add:after_in_list_append_not_hd)
   (* a=x *)
  apply(frule after_in_list_in_cons, simp+)
done

lemma list_eq_after_in_list':
  "\<lbrakk> distinct xs; p = xs ! i; i < length xs \<rbrakk>
    \<Longrightarrow> \<exists>list. xs = list @ p # after_in_list_list xs p"
   apply (induct xs arbitrary: i)
     apply (simp)
  apply (atomize)
  apply (case_tac i)
   apply (simp)
  apply (drule_tac x = nat in spec, simp)
  apply (erule exE, rule impI, rule_tac x = "a # list" in exI)
  apply (simp)
done

lemma after_in_list_last_None:
  "distinct list \<Longrightarrow> after_in_list list (last list) = None"
  apply(induct list)
   apply(simp)
  apply(case_tac list)
   apply(simp)
  apply(fastforce split: if_split_asm)
  done

lemma after_in_list_None_last:
  "\<lbrakk>after_in_list list x = None; x \<in> set list\<rbrakk> \<Longrightarrow> x = last list"
  by (induct list x rule: after_in_list.induct,(simp split: if_split_asm)+)

lemma map2_append1:
  "map2 f (as @ bs) cs = map2 f as (take (length as) cs) @ map2 f bs (drop (length as) cs)"
  by (simp add: map_def zip_append1)

end