(*  Title:      HOL/Types_To_Sets/Examples/Linear_Algebra_On_With.thy
    Author:     Fabian Immler, TU München
*)
theory Linear_Algebra_On_With
  imports
    Group_On_With
    Complex_Main
begin

definition span_with
  where "span_with pls zero scl b =
    {sum_with pls zero (\<lambda>a. scl (r a) a) t | t r. finite t \<and> t \<subseteq> b}"

lemma span_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> A ===> ((=) ===> A ===> A) ===> rel_set A ===> rel_set A)
    span_with span_with"
  unfolding span_with_def
proof (intro rel_funI)
  fix p p' z z' X X' and s s'::"'c \<Rightarrow> _"
  assume transfer_rules[transfer_rule]: "(A ===> A ===> A) p p'" "A z z'" "((=) ===> A ===> A) s s'" "rel_set A X X'"
  have "Domainp A z" using \<open>A z z'\<close> by force
  have *: "t \<subseteq> X \<Longrightarrow> (\<forall>x\<in>t. Domainp A x)" for t
    by (meson Domainp.DomainI \<open>rel_set A X X'\<close> rel_setD1 subsetD)
  note swt=sum_with_transfer[OF assms(1,2,2), THEN rel_funD, THEN rel_funD, THEN rel_funD, THEN rel_funD, OF transfer_rules(1,2)]
  have DsI: "Domainp A (sum_with p z r t)" if "\<And>x. x \<in> t \<Longrightarrow> Domainp A (r x)" "t \<subseteq> Collect (Domainp A)" for r t
  proof cases
    assume ex: "\<exists>C. r ` t \<subseteq> C \<and> comm_monoid_add_on_with C p z"
    have "Domainp (rel_set A) t" using that by (auto simp: Domainp_set)
    from ex_comm_monoid_add_around_imageE[OF ex transfer_rules(1,2) this that(1)]
    obtain C where C: "comm_monoid_add_on_with C p z" "r ` t \<subseteq> C" "Domainp (rel_set A) C" by auto
    interpret comm_monoid_add_on_with C p z by fact
    from sum_with_mem[OF C(2)] C(3)
    show ?thesis
      by auto (meson C(3) Domainp_set)
  qed (use \<open>A z _\<close> in \<open>auto simp: sum_with_def\<close>)
  from Domainp_apply2I[OF transfer_rules(3)]
  have Domainp_sI: "Domainp A x \<Longrightarrow> Domainp A (s y x)" for x y by auto
  show "rel_set A
    {sum_with p z (\<lambda>a. s (r a) a) t |t r. finite t \<and> t \<subseteq> X}
        {sum_with p' z' (\<lambda>a. s' (r a) a) t |t r. finite t \<and> t \<subseteq> X'}"
    apply (transfer_prover_start, transfer_step+)
    using *
    by (auto simp: intro!: DsI Domainp_sI)
qed

definition dependent_with
  where "dependent_with pls zero scl s =
    (\<exists>t u. finite t \<and> t \<subseteq> s \<and> (sum_with pls zero (\<lambda>v. scl (u v) v) t = zero \<and> (\<exists>v\<in>t. u v \<noteq> 0)))"

lemma dependent_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> A ===> ((=) ===> A ===> A) ===> rel_set A ===> (=))
    dependent_with dependent_with"
  unfolding dependent_with_def dependent_with_def
proof (intro rel_funI)
  fix p p' z z' X X' and s s'::"'c \<Rightarrow> _"
  assume [transfer_rule]: "(A ===> A ===> A) p p'" "A z z'" "((=) ===> A ===> A) s s'" "rel_set A X X'"
  have *: "t \<subseteq> X \<Longrightarrow> (\<forall>x\<in>t. Domainp A x)" for t
    by (meson Domainp.DomainI \<open>rel_set A X X'\<close> rel_setD1 subsetD)
  show "(\<exists>t u. finite t \<and> t \<subseteq> X \<and> sum_with p z (\<lambda>v. s (u v) v) t = z \<and> (\<exists>v\<in>t. u v \<noteq> 0)) =
    (\<exists>t u. finite t \<and> t \<subseteq> X' \<and> sum_with p' z' (\<lambda>v. s' (u v) v) t = z' \<and> (\<exists>v\<in>t. u v \<noteq> 0))"
    apply (transfer_prover_start, transfer_step+)
    using *
    by (auto simp: intro!: comm_monoid_add_on_with.sum_with_mem)
qed

definition subspace_with
  where "subspace_with pls zero scl S \<longleftrightarrow> zero \<in> S \<and> (\<forall>x\<in>S. \<forall>y\<in>S. pls x y \<in> S) \<and> (\<forall>c. \<forall>x\<in>S. scl c x \<in> S)"

lemma subspace_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> A ===> A) ===> A ===> ((=) ===> A ===> A) ===> rel_set A ===> (=))
    subspace_with subspace_with"
  unfolding span_with_def subspace_with_def
  by transfer_prover

definition "module_on_with S pls mns um zero (scl::'a::comm_ring_1\<Rightarrow>_) \<longleftrightarrow>
  ab_group_add_on_with S pls zero mns um \<and>
        ((\<forall>a. \<forall>x\<in>S.
                 \<forall>y\<in>S. scl a (pls x y) = pls (scl a x) (scl a y)) \<and>
         (\<forall>a b. \<forall>x\<in>S. scl (a + b) x = pls (scl a x) (scl b x))) \<and>
        (\<forall>a b. \<forall>x\<in>S. scl a (scl b x) = scl (a * b) x) \<and>
        (\<forall>x\<in>S. scl 1 x = x) \<and>
        (\<forall>a. \<forall>x\<in>S. scl a x \<in> S)"

definition "vector_space_on_with S pls mns um zero (scl::'a::field\<Rightarrow>_) \<longleftrightarrow>
  module_on_with S pls mns um zero scl"

definition "module_pair_on_with S S' pls mns um zero (scl::'a::comm_ring_1\<Rightarrow>_) pls' mns' um' zero' (scl'::'a::comm_ring_1\<Rightarrow>_) \<longleftrightarrow>
  module_on_with S pls mns um zero scl \<and> module_on_with S' pls' mns' um' zero' scl'"

definition "vector_space_pair_on_with S S' pls mns um zero (scl::'a::field\<Rightarrow>_) pls' mns' um' zero' (scl'::'a::field\<Rightarrow>_) \<longleftrightarrow>
  module_pair_on_with S S' pls mns um zero scl pls' mns' um' zero' scl'"

definition "module_hom_on_with S1 S2 plus1 minus1 uminus1 zero1 (scale1::'a::comm_ring_1\<Rightarrow>_)
  plus2 minus2 uminus2 zero2 (scale2::'a::comm_ring_1\<Rightarrow>_) f \<longleftrightarrow>
        module_pair_on_with S1 S2 plus1 minus1 uminus1 zero1 scale1
         plus2 minus2 uminus2 zero2 scale2 \<and>
        (\<forall>x\<in>S1. \<forall>y\<in>S1. f (plus1 x y) = plus2 (f x) (f y)) \<and>
        (\<forall>s. \<forall>x\<in>S1. f (scale1 s x) = scale2 s (f x))"

definition "linear_on_with S1 S2 plus1 minus1 uminus1 zero1 (scale1::'a::field\<Rightarrow>_)
  plus2 minus2 uminus2 zero2 (scale2::'a::field\<Rightarrow>_) f \<longleftrightarrow>
  module_hom_on_with S1 S2 plus1 minus1 uminus1 zero1 scale1
  plus2 minus2 uminus2 zero2 scale2 f"

definition dim_on_with
  where "dim_on_with S pls zero scale V =
    (if \<exists>b \<subseteq> S. \<not> dependent_with pls zero scale b \<and> span_with pls zero scale b = span_with pls zero scale V
      then card (SOME b. b \<subseteq> S \<and>\<not> dependent_with pls zero scale b \<and> span_with pls zero scale b = span_with pls zero scale V)
      else 0)"

definition "finite_dimensional_vector_space_on_with S pls mns um zero (scl::'a::field\<Rightarrow>_) basis \<longleftrightarrow>
  vector_space_on_with S pls mns um zero scl \<and>
    finite basis \<and>
    \<not> dependent_with pls zero scl basis \<and>
    span_with pls zero scl basis = S"

definition "finite_dimensional_vector_space_pair_1_on_with S S' pls mns um zero (scl::'a::field\<Rightarrow>_) b
  pls' mns' um' zero' (scl'::'a::field\<Rightarrow>_) \<longleftrightarrow>
  finite_dimensional_vector_space_on_with S pls mns um zero (scl::'a::field\<Rightarrow>_) b \<and>
  vector_space_on_with S' pls' mns' um' zero' (scl'::'a::field\<Rightarrow>_)"

definition "finite_dimensional_vector_space_pair_on_with S S' pls mns um zero (scl::'a::field\<Rightarrow>_) b
  pls' mns' um' zero' (scl'::'a::field\<Rightarrow>_) b' \<longleftrightarrow>
  finite_dimensional_vector_space_on_with S pls mns um zero (scl::'a::field\<Rightarrow>_) b \<and>
  finite_dimensional_vector_space_on_with S' pls' mns' um' zero' (scl'::'a::field\<Rightarrow>_) b'"

context module begin

lemma span_with:
  "span = (\<lambda>X. span_with (+) 0 scale X)"
  unfolding span_explicit span_with_def sum_with ..

lemma dependent_with:
  "dependent = (\<lambda>X. dependent_with (+) 0 scale X)"
  unfolding dependent_explicit dependent_with_def sum_with ..

lemma subspace_with:
  "subspace = (\<lambda>X. subspace_with (+) 0 scale X)"
  unfolding subspace_def subspace_with_def ..

end

lemmas [explicit_ab_group_add] = module.span_with module.dependent_with module.subspace_with

lemma module_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===> (=))
      module_on_with module_on_with"
  unfolding module_on_with_def
  by transfer_prover

lemma vector_space_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===> (=))
      vector_space_on_with vector_space_on_with"
  unfolding vector_space_on_with_def
  by transfer_prover

context vector_space begin

lemma dim_with: "dim = (\<lambda>X. dim_on_with UNIV (+) 0 scale X)"
  unfolding dim_def dim_on_with_def dependent_with span_with by force

end

lemmas [explicit_ab_group_add] = vector_space.dim_with

lemma module_pair_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A" "right_total C" "bi_unique C"
  shows
    "(rel_set A ===> rel_set C ===>
    (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===>
    (C ===> C ===> C) ===> (C ===> C ===> C) ===> (C ===> C) ===> C ===> ((=) ===> C ===> C) ===>
    (=)) module_pair_on_with module_pair_on_with"
  unfolding module_pair_on_with_def
  by transfer_prover

lemma module_hom_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A" "right_total C" "bi_unique C"
  shows
    "(rel_set A ===> rel_set C ===>
    (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===>
    (C ===> C ===> C) ===> (C ===> C ===> C) ===> (C ===> C) ===> C ===> ((=) ===> C ===> C) ===>
    (A ===> C) ===> (=)) module_hom_on_with module_hom_on_with"
  unfolding module_hom_on_with_def
  by transfer_prover

lemma linear_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A" "right_total C" "bi_unique C"
  shows
    "(rel_set A ===> rel_set C ===>
    (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===>
    (C ===> C ===> C) ===> (C ===> C ===> C) ===> (C ===> C) ===> C ===> ((=) ===> C ===> C) ===>
    (A ===> C) ===> (=)) linear_on_with linear_on_with"
  unfolding linear_on_with_def
  by transfer_prover

subsubsection \<open>Explicit locale formulations\<close>

lemma module_on_with[explicit_ab_group_add]: "module s \<longleftrightarrow> module_on_with UNIV (+) (-) uminus 0 s"
  and vector_space_on_with[explicit_ab_group_add]: "vector_space t \<longleftrightarrow> vector_space_on_with UNIV (+) (-) uminus 0 t"
  by (auto simp: module_def module_on_with_def ab_group_add_axioms
      vector_space_def vector_space_on_with_def)

lemma vector_space_with_imp_module_with[explicit_ab_group_add]:
  "vector_space_on_with S (+) (-) uminus 0 s \<Longrightarrow> module_on_with S (+) (-) uminus 0 s"
  by (simp add: vector_space_on_with_def)

lemma finite_dimensional_vector_space_on_with[explicit_ab_group_add]:
    "finite_dimensional_vector_space t b \<longleftrightarrow> finite_dimensional_vector_space_on_with UNIV (+) (-) uminus 0 t b"
  by (auto simp: finite_dimensional_vector_space_on_with_def finite_dimensional_vector_space_def
    finite_dimensional_vector_space_axioms_def explicit_ab_group_add)

lemma vector_space_with_imp_finite_dimensional_vector_space_with[explicit_ab_group_add]:
  "finite_dimensional_vector_space_on_with S (+) (-) uminus 0 s basis \<Longrightarrow>
  vector_space_on_with S  (+) (-) uminus 0 s"
  by (auto simp: finite_dimensional_vector_space_on_with_def)

lemma module_hom_on_with[explicit_ab_group_add]:
  "module_hom s1 s2 f \<longleftrightarrow> module_hom_on_with UNIV UNIV (+) (-) uminus 0 s1 (+) (-) uminus 0 s2 f"
  and linear_with[explicit_ab_group_add]:
  "Vector_Spaces.linear t1 t2 f \<longleftrightarrow> linear_on_with UNIV UNIV (+) (-) uminus 0 t1 (+) (-) uminus 0 t2 f"
  and module_pair_on_with[explicit_ab_group_add]:
  "module_pair s1 s2 \<longleftrightarrow> module_pair_on_with UNIV UNIV (+) (-) uminus 0 s1 (+) (-) uminus 0 s2"
  by (auto simp: module_hom_def module_hom_on_with_def module_pair_on_with_def
      Vector_Spaces.linear_def linear_on_with_def vector_space_on_with
      module_on_with_def vector_space_on_with_def
      module_hom_axioms_def module_pair_def module_on_with)

lemma vector_space_pair_with[explicit_ab_group_add]:
  "vector_space_pair s1 s2 \<longleftrightarrow> vector_space_pair_on_with UNIV UNIV (+) (-) uminus 0 s1  (+) (-) uminus 0 s2"
  by (auto simp: module_pair_on_with_def explicit_ab_group_add
      vector_space_pair_on_with_def vector_space_pair_def module_on_with_def vector_space_on_with_def)

lemma finite_dimensional_vector_space_pair_1_with[explicit_ab_group_add]:
  "finite_dimensional_vector_space_pair_1 s1 b1 s2 \<longleftrightarrow>
    finite_dimensional_vector_space_pair_1_on_with UNIV UNIV (+) (-) uminus 0 s1 b1 (+) (-) uminus 0 s2"
  by (auto simp: finite_dimensional_vector_space_pair_1_def
      finite_dimensional_vector_space_pair_1_on_with_def finite_dimensional_vector_space_on_with
      vector_space_on_with)

lemma finite_dimensional_vector_space_pair_with[explicit_ab_group_add]:
  "finite_dimensional_vector_space_pair s1 b1 s2 b2 \<longleftrightarrow>
    finite_dimensional_vector_space_pair_on_with UNIV UNIV (+) (-) uminus 0 s1 b1 (+) (-) uminus 0 s2 b2"
  by (auto simp: finite_dimensional_vector_space_pair_def
      finite_dimensional_vector_space_pair_on_with_def finite_dimensional_vector_space_on_with)

lemma module_pair_with_imp_module_with[explicit_ab_group_add]:
  "module_on_with S (+) (-) uminus 0 s"
  "module_on_with T (+) (-) uminus 0 t"
  if "module_pair_on_with S T (+) (-) uminus 0 s (+) (-) uminus 0 t"
  using that
  unfolding module_pair_on_with_def
  by simp_all

lemma vector_space_pair_with_imp_vector_space_with[explicit_ab_group_add]:
  "vector_space_on_with S (+) (-) uminus 0 s"
  "vector_space_on_with T (+) (-) uminus 0 t"
  if "vector_space_pair_on_with S T(+) (-) uminus 0 s (+) (-) uminus 0 t"
  using that
  by (auto simp: vector_space_pair_on_with_def module_pair_on_with_def vector_space_on_with_def)

lemma finite_dimensional_vector_space_pair_1_with_imp_with[explicit_ab_group_add]:
  "vector_space_on_with S (+) (-) uminus 0 s"
  "finite_dimensional_vector_space_on_with S (+) (-) uminus 0 s b"
  "vector_space_on_with T (+) (-) uminus 0 t"
  if "finite_dimensional_vector_space_pair_1_on_with S T (+) (-) uminus 0 s b (+) (-) uminus 0 t"
  using that
  unfolding finite_dimensional_vector_space_pair_1_on_with_def
  by (simp_all add: finite_dimensional_vector_space_on_with_def)

lemma finite_dimensional_vector_space_pair_with_imp_finite_dimensional_vector_space_with[explicit_ab_group_add]:
  "vector_space_on_with S (+) (-) uminus 0 s"
  "finite_dimensional_vector_space_on_with T (+) (-) uminus 0 t c"
  "vector_space_on_with T (+) (-) uminus 0 t"
  "finite_dimensional_vector_space_on_with T (+) (-) uminus 0 t c"
  if "finite_dimensional_vector_space_pair_on_with S T (+) (-) uminus 0 s b (+) (-) uminus 0 t c"
  using that
  unfolding finite_dimensional_vector_space_pair_on_with_def
  by (simp_all add: finite_dimensional_vector_space_on_with_def)

lemma finite_dimensional_vector_space_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "(rel_set A ===>
    (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===>
    rel_set A ===>
    (=)) (finite_dimensional_vector_space_on_with) finite_dimensional_vector_space_on_with"
  unfolding finite_dimensional_vector_space_on_with_def
  by transfer_prover

lemma finite_dimensional_vector_space_pair_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A" "right_total C" "bi_unique C"
  shows
    "(rel_set A ===> rel_set C ===>
    (A ===> A ===> A) ===> (A ===> A ===> A) ===> (A ===> A) ===> A ===> ((=) ===> A ===> A) ===>
    rel_set A ===>
    (C ===> C ===> C) ===> (C ===> C ===> C) ===> (C ===> C) ===> C ===> ((=) ===> C ===> C) ===>
    rel_set C ===>
    (=)) (finite_dimensional_vector_space_pair_on_with) finite_dimensional_vector_space_pair_on_with"
  unfolding finite_dimensional_vector_space_pair_on_with_def
  by transfer_prover

end


theory ConcreteSemantics12_Hoare_Examples
  imports "~~/src/HOL/IMP/Hoare"
begin

fun sum:: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

text\<open>To prove while_sum, it is needed to prove the following lemma and declare sum.simps\<close>
lemma sum_simps[simp]:
"0 < i \<Longrightarrow> sum i = sum (i - 1) + i"
"i \<le> 0 \<Longrightarrow> sum i = 0"
   apply(simp_all)
  done

declare sum.simps[simp del]

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'') DO
  (''y''::= Plus (V ''y'') (V ''x'');;''x''::= Plus (V ''x'') (N (-1)))
"

lemma while_sum: "(wsum, s) \<Rightarrow> t \<Longrightarrow> t ''y'' = s ''y'' + sum (s ''x'')"
  apply(induction wsum s t rule: big_step_induct)
   apply(auto)
  done

lemma sum_via_bigstep:
  assumes "(''y''::= N 0;; wsum, s) \<Rightarrow> t"
  shows " t ''y'' = sum (s ''x'')"
proof -
  from assms have "(wsum, s(''y'' := 0)) \<Rightarrow> t" by auto
  then show ?thesis
    using while_sum by fastforce
qed

lemma "\<turnstile> {\<lambda>s. s ''x'' = n} ''y'' ::= N 0;; wsum {\<lambda>s. s ''y'' = sum n}"
  apply(rule Seq)
   prefer 2
   apply(rule While' [where P = "\<lambda>s. s ''y'' = sum n - sum(s ''x'')"])
    apply(rule Seq)
     prefer 2
     apply(rule Assign)
    apply(rule Assign')
    apply(simp)
   apply(simp)
  apply(rule Assign')
  apply(simp)
  done

end


theory ex3_7
imports BExp
begin

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a1 a2 = Not (less a2 a1)"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a1 a2 =And (Le a1 a2) (Le a2 a1) "

lemma "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
apply(auto)
done

lemma "bval (Le a1 a2) s = (aval a1 s <= aval a2 s)"
apply(auto)
done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

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)+)

end