(*
  File:    Linear_Recurrences_Solver.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Solver for linear recurrences\<close>
theory Linear_Recurrences_Solver
imports
  Complex_Main
  Linear_Recurrences.Linear_Homogenous_Recurrences
  Linear_Recurrences.Linear_Inhomogenous_Recurrences
  "Algebraic_Numbers.Complex_Algebraic_Numbers"
begin

lemma factorize_complex_main:
  assumes "factorize_complex_main p = Some fctrs"
  shows   "is_factorization_of fctrs p"
  unfolding is_factorization_of_def
proof safe
  from assms have "p = Polynomial.smult (fst fctrs) (\<Prod>(x, i)\<leftarrow>snd fctrs. [:- x, 1:] ^ Suc i)"
    by (intro factorize_complex_main) simp_all
  also have "\<dots> = interp_factorization fctrs"
    by (simp add: interp_factorization_def case_prod_unfold)
  finally show "interp_factorization fctrs = p" ..
qed (insert assms, simp_all add: distinct_factorize_complex_main)

definition solve_ratfps
    :: "complex ratfps \<Rightarrow> (complex poly \<times> (complex poly \<times> complex) list) option" where
  "solve_ratfps f =
     (case quot_of_ratfps f of (p, q) \<Rightarrow>
       map_option (solve_factored_ratfps' p) (factorize_complex_main (reflect_poly q)))"

lemma solve_ratfps:
  assumes "solve_ratfps f = Some sol"
  shows   "Abs_fps (interp_ratfps_solution sol) = fps_of_ratfps f"
proof -
  define p and q where "p = fst (quot_of_ratfps f)" and "q = snd (quot_of_ratfps f)"
  with assms obtain fctrs where fctrs: "factorize_complex_main (reflect_poly q) = Some fctrs"
    by (auto simp: solve_ratfps_def p_def q_def case_prod_unfold split: if_splits)
  have q: "coeff q 0 \<noteq> 0" by (simp add: q_def)
  hence [simp]: "q \<noteq> 0" by auto
  from fctrs have "is_factorization_of fctrs (reflect_poly q)"
    by (rule factorize_complex_main)
  with assms have "is_alt_factorization_of fctrs (reflect_poly (reflect_poly q))"
    by (intro reflect_factorization) simp_all
  hence "is_alt_factorization_of fctrs q" by (simp add: q)
  with fctrs q
    have "Abs_fps (interp_ratfps_solution (solve_factored_ratfps' p fctrs)) =
            fps_of_poly p / fps_of_poly q"
    by (intro solve_factored_ratfps') (simp_all)
  also from fctrs assms have "solve_factored_ratfps' p fctrs = sol"
    by (simp add: solve_ratfps_def p_def q_def case_prod_unfold split: if_splits)
  finally show ?thesis by (simp add: fps_of_ratfps_altdef case_prod_unfold p_def q_def)
qed

definition solve_lhr
    :: "complex list \<Rightarrow> complex list \<Rightarrow> (complex poly \<times> (complex poly \<times> complex) list) option" where
  "solve_lhr cs fs = (if cs = [] \<or> length fs < length cs - 1 then None else
     let m = length fs + 1 - length cs;
         p = lhr_fps_numerator m cs (\<lambda>n. fs ! n);
         q = lr_fps_denominator' cs
     in  map_option (solve_factored_ratfps' p) (factorize_complex_main q))"

lemma solve_lhr:
  assumes "linear_homogenous_recurrence f cs fs"
  assumes "Some sol = solve_lhr cs fs"
  shows   "f = interp_ratfps_solution sol"
proof -
  from assms(2) obtain fctrs where
      fctrs: "factorize_complex_main (lr_fps_denominator' cs) = Some fctrs"
    by (cases "factorize_complex_main (lr_fps_denominator' cs)")
       (simp_all add: solve_lhr_def Let_def split: if_splits)
  from factorize_complex_main[OF this]
    have factorization: "is_factorization_of fctrs (lr_fps_denominator' cs)" .

  have "f = interp_ratfps_solution (solve_factored_ratfps' (lhr_fps_numerator
              (length fs + 1 - length cs) cs ((!) fs)) fctrs)"
    (is "_ = interp_ratfps_solution ?sol") by (intro solve_lhr_aux) fact+
  also from assms(2) have "?sol = sol"
    by (auto simp: solve_lhr_def Let_def case_prod_unfold fctrs split: if_splits)
  finally show ?thesis .
qed

definition solve_lir
    :: "complex list \<Rightarrow> complex list \<Rightarrow> complex polyexp \<Rightarrow>
          (complex poly \<times> (complex poly \<times> complex) list) option" where
  "solve_lir cs fs g = Option.bind (lir_fps cs fs g) solve_ratfps"

lemma solve_lir:
  assumes "linear_inhomogenous_recurrence f (eval_polyexp g) cs fs"
  assumes "solve_lir cs fs g = Some sol"
  shows   "f = interp_ratfps_solution sol"
proof -
  from lir_fps_correct[OF assms(1)] obtain fps
    where fps: "lir_fps cs fs g = Some fps" "fps_of_ratfps fps = Abs_fps f" by blast
  from assms(2) have "solve_ratfps fps = Some sol"
    by (simp add: solve_lir_def fps case_prod_unfold)
  from solve_ratfps[OF this] have "Abs_fps (interp_ratfps_solution sol) = fps_of_ratfps fps"
    by (simp add: case_prod_unfold fps_of_ratfps_altdef)
  with fps have "Abs_fps f = Abs_fps (interp_ratfps_solution sol)" by simp
  thus ?thesis by (simp add: fun_eq_iff fps_eq_iff)
qed

end


theory Prob_Lemmas
imports
  Probability
  "../Girth_Chromatic/Girth_Chromatic"
  Ugraph_Misc
begin

section{* Lemmas about probabilities *}

text{* In this section, auxiliary lemmas for computing bounds on expectation and probabilites
of random variables are set up. *}

subsection{* Indicator variables and valid probability values *}

abbreviation rind :: "'a set \<Rightarrow> 'a \<Rightarrow> real" where
"rind \<equiv> indicator"

lemma product_indicator:
  "rind A x * rind B x = rind (A \<inter> B) x"
unfolding indicator_def
by auto

text{* We call a real number `valid' iff it is in the range 0 to 1, inclusively, and additionally
`nonzero' iff it is neither 0 nor 1. *}

abbreviation "valid_prob (p :: real) \<equiv> 0 \<le> p \<and> p \<le> 1"
abbreviation "nonzero_prob (p :: real) \<equiv> 0 < p \<and> p < 1"

text{* A function @{typ "'a \<Rightarrow> real"} is a `valid probability function' iff each value in the image
is valid, and similarly for `nonzero'. *}

abbreviation "valid_prob_fun f \<equiv> (\<forall>n. valid_prob (f n))"
abbreviation "nonzero_prob_fun f \<equiv> (\<forall>n. nonzero_prob (f n))"

lemma nonzero_fun_is_valid_fun: "nonzero_prob_fun f \<Longrightarrow> valid_prob_fun f"
by (simp add: less_imp_le)

subsection{* Expectation and variance *}

context prob_space
begin

text{* Note that there is already a notion of independent sets (see @{term indep_set}), but we use
the following -- simpler -- definition: *}

definition "indep A B \<longleftrightarrow> prob (A \<inter> B) = prob A * prob B"

text{* The probability of an indicator variable is equal to its expectation: *}

lemma expectation_indicator:
  "A \<in> events \<Longrightarrow> expectation (rind A) = prob A"
  by simp

text{* For a non-negative random variable @{term X}, the Markov inequality gives the following
upper bound: \[ \Pr[X \ge a] \le \frac{\Ex[X]}{a} \] *}

lemma markov_inequality:
  assumes "\<And>a. 0 \<le> X a" and "integrable M X" "0 < t"
  shows "prob {a \<in> space M. t \<le> X a} \<le> expectation X / t"
proof -
  --{* proof adapted from @{thm [source] edge_space.Markov_inequality}, but generalized to arbitrary
       @{term prob_space}s *}
  have "(\<integral>\<^sup>+ x. ereal (X x) \<partial>M) = (\<integral>x. X x \<partial>M)"
    using assms by (intro nn_integral_eq_integral) auto
  thus ?thesis
    using assms nn_integral_Markov_inequality[of X M "space M" "1 / t"]
    by (auto cong: nn_integral_cong simp: emeasure_eq_measure one_ereal_def)
qed

text{* $\Var[X] = \Ex[X^2] - \Ex[X]^2 $ *}

lemma variance_expectation:
  fixes X :: "'a \<Rightarrow> real"
  assumes "integrable M (\<lambda>x. (X x)^2)" and "X \<in> borel_measurable M"
  shows
    "integrable M (\<lambda>x. (X x - expectation X)^2)" (is ?integrable)
    "variance X = expectation (\<lambda>x. (X x)^2) - (expectation X)^2" (is ?variance)
proof -
  have int: "integrable M X"
    using integrable_squareD[OF assms] by simp

  have "(\<lambda>x. (X x - expectation X)^2) = (\<lambda>x. (X x)^2 + (expectation X)^2 - (2 * X x * expectation X))"
    by (simp only: power2_diff)
  hence
    "variance X = expectation (\<lambda>x. (X x)^2) + (expectation X)^2 + expectation (\<lambda>x. - (2 * X x * expectation X))"
    ?integrable
    using integral_add by (simp add: int assms prob_space)+

  thus ?variance ?integrable
    by (simp add: int power2_eq_square)+
qed

text{* A corollary from the Markov inequality is Chebyshev's inequality, which gives an upper
bound for the deviation of a random variable from its expectation:
\[ \Pr[\left| Y - \Ex[Y] \right| \ge s] \le \frac{\Var[X]}{a^2} \] *}

lemma chebyshev_inequality:
  fixes Y :: "'a \<Rightarrow> real"
  assumes Y_int: "integrable M (\<lambda>y. (Y y)^2)"
  assumes Y_borel: "Y \<in> borel_measurable M"
  fixes s :: "real"
  assumes s_pos: "0 < s"
  shows "prob {a \<in> space M. s \<le> \<bar>Y a - expectation Y\<bar>} \<le> variance Y / s^2"
proof -
  let ?X = "\<lambda>a. (Y a - expectation Y)^2"
  let ?t = "s^2"

  have "0 < ?t"
    using s_pos by simp
  hence "prob {a \<in> space M. ?t \<le> ?X a} \<le> variance Y / s^2"
    using markov_inequality variance_expectation[OF Y_int Y_borel] by (simp add: field_simps)
  moreover have "{a \<in> space M. ?t \<le> ?X a} = {a \<in> space M. s \<le> \<bar>Y a - expectation Y\<bar>}"
    using real_abs_le_square_iff s_pos by force
  ultimately show ?thesis
    by simp
qed

text{* Hence, we can derive an upper bound for the probability that a random variable is $0$. *}

corollary chebyshev_prob_zero:
  fixes Y :: "'a \<Rightarrow> real"
  assumes Y_int: "integrable M (\<lambda>y. (Y y)^2)"
  assumes Y_borel: "Y \<in> borel_measurable M"
  assumes \<mu>_pos: "expectation Y > 0"
  shows "prob {a \<in> space M. Y a = 0} \<le> expectation (\<lambda>y. (Y y)^2) / (expectation Y)^2 - 1"
proof -
  let ?s = "expectation Y"

  have "prob {a \<in> space M. Y a = 0} \<le> prob {a \<in> space M. ?s \<le> \<bar>Y a - ?s\<bar>}"
    using Y_borel by (auto intro!: finite_measure_mono borel_measurable_diff borel_measurable_abs borel_measurable_le)
  also have "\<dots> \<le> variance Y / ?s^2"
    using assms by (fact chebyshev_inequality)
  also have "\<dots> = (expectation (\<lambda>y. (Y y)^2) - ?s^2) / ?s^2"
    using Y_int Y_borel by (simp add: variance_expectation)
  also have "\<dots> = expectation (\<lambda>y. (Y y)^2) / ?s^2 - 1"
    using \<mu>_pos by (simp add: field_simps)
  finally show ?thesis .
qed

end

subsection{* Sets of indicator variables *}

text{* \label{sec:delta}
This section introduces some inequalities about expectation and other values related to the sum of
a set of random indicators. *}

locale prob_space_with_indicators = prob_space +
  fixes I :: "'i set"
  assumes finite_I: "finite I"

  fixes A :: "'i \<Rightarrow> 'a set"
  assumes A: "A ` I \<subseteq> events"

  assumes prob_non_zero: "\<exists>i \<in> I. 0 < prob (A i)"
begin

text{* We call the underlying sets @{term "A i"} for each @{term "i \<in> I"}, and the corresponding
indicator variables @{term "X i"}. The sum is denoted by @{term Y}, and its expectation by
@{term \<mu>}. *}

definition "X i = rind (A i)"
definition "Y x = (\<Sum>i \<in> I. X i x)"

definition "\<mu> = expectation Y"

text{* In the lecture notes, the following two relations are called $\sim$ and $\nsim$,
respectively. Note that they are not the opposite of each other. *}

abbreviation ineq_indep :: "'i \<Rightarrow> 'i \<Rightarrow> bool" where
"ineq_indep i j \<equiv> (i \<noteq> j \<and> indep (A i) (A j))"

abbreviation ineq_dep :: "'i \<Rightarrow> 'i \<Rightarrow> bool" where
"ineq_dep i j \<equiv> (i \<noteq> j \<and> \<not>indep (A i) (A j))"

definition "\<Delta>\<^sub>a = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> i \<noteq> j. prob (A i \<inter> A j))"
definition "\<Delta>\<^sub>d = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> ineq_dep i j. prob (A i \<inter> A j))"

lemma \<Delta>_zero:
  assumes "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> indep (A i) (A j)"
  shows "\<Delta>\<^sub>d = 0"
proof -
  {
    fix i
    assume "i \<in> I"
    hence "{j. j \<in> I \<and> ineq_dep i j} = {}"
      using assms by auto
    hence "(\<Sum>j | j \<in> I \<and> ineq_dep i j. prob (A i \<inter> A j)) = 0"
      using setsum.empty by metis
  }
  hence "\<Delta>\<^sub>d = (0 :: real) * card I"
    unfolding \<Delta>\<^sub>d_def by simp
  thus ?thesis
    by simp
qed

lemma A_events[measurable]: "i \<in> I \<Longrightarrow> A i \<in> events"
using A by auto

lemma expectation_X_Y: "\<mu> = (\<Sum>i\<in>I. expectation (X i))"
unfolding \<mu>_def Y_def[abs_def] X_def
by simp

lemma expectation_X_non_zero: "\<exists>i \<in> I. 0 < expectation (X i)"
unfolding X_def using prob_non_zero expectation_indicator by simp

corollary \<mu>_non_zero[simp]: "0 < \<mu>"
unfolding expectation_X_Y
using expectation_X_non_zero
by (auto intro!: setsum_lower finite_I
         simp add: expectation_indicator X_def measure_nonneg
         simp del: integral_indicator)

lemma \<Delta>\<^sub>d_nonneg: "0 \<le> \<Delta>\<^sub>d"
unfolding \<Delta>\<^sub>d_def
by (simp add: setsum_nonneg measure_nonneg)

corollary \<mu>_sq_non_zero[simp]: "0 < \<mu>^2"
by (rule zero_less_power) simp

lemma Y_square_unfold: "(\<lambda>x. (Y x)^2) = (\<lambda>x. \<Sum>i \<in> I. \<Sum>j \<in> I. rind (A i \<inter> A j) x)"
unfolding fun_eq_iff Y_def X_def
by (auto simp: setsum_square product_indicator)

lemma integrable_Y_sq[simp]: "integrable M (\<lambda>y. (Y y)^2)"
unfolding Y_square_unfold
by (simp add: sets.Int)

lemma measurable_Y[measurable]: "Y \<in> borel_measurable M"
unfolding Y_def[abs_def] X_def by simp

lemma expectation_Y_\<Delta>: "expectation (\<lambda>x. (Y x)^2) = \<mu> + \<Delta>\<^sub>a"
proof -
  let ?ei = "\<lambda>i j. expectation (rind (A i \<inter> A j))"

  have "expectation (\<lambda>x. (Y x)^2) = (\<Sum>i \<in> I. \<Sum>j \<in> I. ?ei i j)"
    unfolding Y_square_unfold by (simp add: sets.Int)
  also have "\<dots> = (\<Sum>i \<in> I. \<Sum>j \<in> I. if i = j then ?ei i j else ?ei i j)"
    by simp
  also have "\<dots> = (\<Sum>i \<in> I. (\<Sum>j | j \<in> I \<and> i = j. ?ei i j) + (\<Sum>j | j \<in> I \<and> i \<noteq> j. ?ei i j))"
    by (simp only: setsum_split[OF finite_I])
  also have "\<dots> = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> i = j. ?ei i j) + (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> i \<noteq> j. ?ei i j)" (is "_ = ?lhs + ?rhs")
    by (fact setsum.distrib)
  also have "\<dots> =  \<mu> + \<Delta>\<^sub>a"
    proof -
      have "?lhs = \<mu>"
        proof -
          {
            fix i
            assume i: "i \<in> I"
            have "(\<Sum>j | j \<in> I \<and> i = j. ?ei i j) = (\<Sum>j | j \<in> I \<and> i = j. ?ei i i)"
              by simp
            also have "\<dots> = (\<Sum>j | i = j. ?ei i i)"
              using i by metis
            also have "\<dots> = expectation (rind (A i))"
              by auto
            finally have "(\<Sum>j | j \<in> I \<and> i = j. ?ei i j) = \<dots>" .
          }
          hence "?lhs = (\<Sum>i\<in>I. expectation (rind (A i)))"
            by force
          also have "\<dots> = \<mu>"
            unfolding expectation_X_Y X_def ..
          finally show "?lhs = \<mu>" .
        qed
      moreover have "?rhs = \<Delta>\<^sub>a"
        proof -
          {
            fix i j
            assume "i \<in> I" "j \<in> I"
            with A have "A i \<inter> A j \<in> events" by blast
            hence "?ei i j = prob (A i \<inter> A j)"
              by (fact expectation_indicator)
          }
          thus ?thesis
            unfolding \<Delta>\<^sub>a_def by simp
        qed
      ultimately show "?lhs + ?rhs = \<mu> + \<Delta>\<^sub>a"
        by simp
    qed
  finally show ?thesis .
qed

lemma \<Delta>_expectation_X: "\<Delta>\<^sub>a \<le> \<mu>^2 + \<Delta>\<^sub>d"
proof -
  let ?p = "\<lambda>i j. prob (A i \<inter> A j)"
  let ?p' = "\<lambda>i j. prob (A i) * prob (A j)"
  let ?ie = "\<lambda>i j. indep (A i) (A j)"

  have "\<Delta>\<^sub>a = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> i \<noteq> j. if ?ie i j then ?p i j else ?p i j)"
    unfolding \<Delta>\<^sub>a_def by simp
  also have "\<dots> = (\<Sum>i \<in> I. (\<Sum>j | j \<in> I \<and> ineq_indep i j. ?p i j) + (\<Sum>j | j \<in> I \<and> ineq_dep i j. ?p i j))"
    by (simp only: setsum_split2[OF finite_I])
  also have "\<dots> = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> ineq_indep i j. ?p i j) + \<Delta>\<^sub>d" (is "_ = ?lhs + _")
    unfolding \<Delta>\<^sub>d_def by (fact setsum.distrib)
  also have "\<dots> \<le> \<mu>^2 + \<Delta>\<^sub>d"
    proof (rule add_right_mono)
      have "(\<Sum>i\<in>I. \<Sum>j | j \<in> I \<and> ineq_indep i j. ?p i j) = (\<Sum>i \<in> I. \<Sum>j | j \<in> I \<and> ineq_indep i j. ?p' i j)"
        unfolding indep_def by simp
      also have "\<dots> \<le> (\<Sum>i \<in> I. \<Sum>j \<in> I. ?p' i j)"
        proof (rule setsum_mono)
          fix i
          assume "i \<in> I"
          show "(\<Sum>j | j \<in> I \<and> ineq_indep i j. ?p' i j) \<le> (\<Sum>j\<in>I. ?p' i j)"
            by (rule setsum_upper[OF finite_I]) (simp add: measure_nonneg zero_le_mult_iff)
        qed
      also have "\<dots> = (\<Sum>i \<in> I. prob (A i))^2"
        by (fact setsum_square[symmetric])
      also have "\<dots> = (\<Sum>i \<in> I. expectation (X i))^2"
        unfolding X_def using expectation_indicator A by simp
      also have "\<dots> = \<mu>^2"
        using expectation_X_Y[symmetric] by simp
      finally show "?lhs \<le> \<mu>^2" .
    qed
  finally show ?thesis .
qed

lemma prob_\<mu>_\<Delta>\<^sub>a: "prob {a \<in> space M. Y a = 0} \<le> 1 / \<mu> + \<Delta>\<^sub>a / \<mu>^2 - 1"
proof -
  have "prob {a \<in> space M. Y a = 0} \<le> expectation (\<lambda>y. (Y y)^2) / \<mu>^2 - 1"
    unfolding \<mu>_def by (rule chebyshev_prob_zero) (simp add: \<mu>_def[symmetric])+
  also have "\<dots> = (\<mu> + \<Delta>\<^sub>a) / \<mu>^2 - 1"
    using expectation_Y_\<Delta> by simp
  also have "\<dots> = 1 / \<mu> + \<Delta>\<^sub>a / \<mu>^2 - 1"
    unfolding power2_eq_square by (simp add: field_simps add_divide_distrib)
  finally show ?thesis .
qed

lemma prob_\<mu>_\<Delta>\<^sub>d: "prob {a \<in> space M. Y a = 0} \<le> 1/\<mu> + \<Delta>\<^sub>d/\<mu>^2"
proof -
  have "prob {a \<in> space M. Y a = 0} \<le> 1/\<mu> + \<Delta>\<^sub>a/\<mu>^2 - 1"
    by (fact prob_\<mu>_\<Delta>\<^sub>a)
  also have "\<dots> = (1/\<mu> - 1) + \<Delta>\<^sub>a/\<mu>^2"
    by simp
  also have "\<dots> \<le> (1/\<mu> - 1) + (\<mu>^2 + \<Delta>\<^sub>d)/\<mu>^2"
    using divide_right_mono[OF \<Delta>_expectation_X] by simp
  also have "\<dots> = 1/\<mu> + \<Delta>\<^sub>d/\<mu>^2"
    using \<mu>_sq_non_zero by (simp add: field_simps)
  finally show ?thesis .
qed

end

end


theory Impl_Uv_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  "../../../Native_Word/Uint"
begin

  subsection {* Bit-Vectors as Lists of Words *}

  subsubsection {* Lookup *}

  primrec lookup :: "nat \<Rightarrow> ('a::len) word list \<Rightarrow> bool" where
    "lookup _ [] \<longleftrightarrow> False"
  | "lookup n (w#ws)
      \<longleftrightarrow> (if n<len_of TYPE('a) then test_bit w n else lookup (n-len_of TYPE('a)) ws)"

  lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
    \<longleftrightarrow> (
      if n < len_of TYPE('a) * length w1 then
        lookup n w1
      else lookup (n - len_of TYPE('a) * length w1) w2)"
    by (induction w1 arbitrary: n) auto

  lemma lookup_zeroes[simp]: "lookup i (replicate n (0::'a::len word)) = False"
    by (induction n arbitrary: i) auto

  subsubsection {* Empty *}

  definition empty :: "'a::len word list" where "empty = []"

  subsubsection {* Set and Reset Bit *}

  function single_bit :: "nat \<Rightarrow> ('a::len) word list"
    where "single_bit n = (
      if (n<len_of TYPE('a)) then
        [set_bit 0 n True]
      else 0#single_bit (n-len_of TYPE('a)))"
    by pat_completeness auto
  termination
    apply (relation "measure id")
    apply simp
    apply (simp add: not_less less_diff_conv2)
    done

  declare single_bit.simps[simp del]

  lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list) \<longleftrightarrow> i = n"
    apply (induction n arbitrary: i rule: single_bit.induct)
    apply (subst single_bit.simps)
    apply (auto simp: bin_nth_sc_gen)
    done

find_consts name: set_bit

  primrec set_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "set_bit i [] = single_bit i"
  | "set_bit i (w#ws) = (
      if i<len_of TYPE('a) then
        bits_class.set_bit w i True # ws
      else
        w # set_bit (i - len_of TYPE('a)) ws)"

  lemma set_bit_lookup[simp]: "lookup i (set_bit j ws) \<longleftrightarrow> (lookup i ws \<or> i=j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: test_bit_set_gen word_size)
    done

  primrec reset_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "reset_bit i [] = []"
  | "reset_bit i (w#ws) = (
      if i<len_of TYPE('a) then
        bits_class.set_bit w i False # ws
      else
        w # reset_bit (i - len_of TYPE('a)) ws)"

  lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws) \<longleftrightarrow> (lookup i ws \<and> i\<noteq>j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: test_bit_set_gen word_size)
    done

  subsubsection {* Binary Operations *}

  definition
    is_bin_op_impl
    :: "(bool\<Rightarrow>bool\<Rightarrow>bool) \<Rightarrow> ('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word) \<Rightarrow> bool"
    where "is_bin_op_impl f g \<equiv>
    (\<forall>w v.  \<forall>i<len_of TYPE('a). test_bit (g w v) i \<longleftrightarrow> f (test_bit w i) (test_bit v i))"

  definition "is_strict_bin_op_impl f g \<equiv> is_bin_op_impl f g \<and> f False False = False"

  fun binary :: "('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word)
    \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "binary f [] [] = []"
  | "binary f [] (w#ws) = f 0 w # binary f [] ws"
  | "binary f (v#vs) [] = f v 0 # binary f vs []"
  | "binary f (v#vs) (w#ws) = f v w # binary f vs ws"

  lemma binary_lookup:
    assumes "is_strict_bin_op_impl f g"
    shows "lookup i (binary g ws vs) \<longleftrightarrow> f (lookup i ws) (lookup i vs)"
    using assms
    apply (induction g ws vs arbitrary: i rule: binary.induct)
    apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
    done

  subsection {* Abstraction to Sets of Naturals *}

  definition "\<alpha> uv \<equiv> {n. lookup n uv}"

  lemma memb_correct: "lookup i ws \<longleftrightarrow> i\<in>\<alpha> ws"
    by (auto simp: \<alpha>_def)

  lemma empty_correct: "\<alpha> empty = {}"
    by (simp add: \<alpha>_def empty_def)

  lemma single_bit_correct: "\<alpha> (single_bit n) = {n}"
    by (simp add: \<alpha>_def)

  lemma insert_correct: "\<alpha> (set_bit i ws) = Set.insert i (\<alpha> ws)"
    by (auto simp add: \<alpha>_def)

  lemma delete_correct: "\<alpha> (reset_bit i ws) = (\<alpha> ws) - {i}"
    by (auto simp add: \<alpha>_def)

  lemma binary_correct:
    assumes "is_strict_bin_op_impl f g"
    shows "\<alpha> (binary g ws vs) = { i . f (i\<in>\<alpha> ws) (i\<in>\<alpha> vs) }"
    unfolding \<alpha>_def
    by (auto simp add: binary_lookup[OF assms])

  fun union :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "union [] ws = ws"
  | "union vs [] = vs"
  | "union (v#vs) (w#ws) = (v OR w) # union vs ws"

  lemma union_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (union vs ws) \<longleftrightarrow> lookup i vs \<or> lookup i ws"
    apply (induction vs ws arbitrary: i rule: union.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma union_correct: "\<alpha> (union ws vs) = \<alpha> ws \<union> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun inter :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "inter [] ws = []"
  | "inter vs [] = []"
  | "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"

  lemma inter_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (inter vs ws) \<longleftrightarrow> lookup i vs \<and> lookup i ws"
    apply (induction vs ws arbitrary: i rule: inter.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma inter_correct: "\<alpha> (inter ws vs) = \<alpha> ws \<inter> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun diff :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "diff [] ws = []"
  | "diff vs [] = vs"
  | "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"

  lemma diff_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (diff vs ws) \<longleftrightarrow> lookup i vs - lookup i ws"
    apply (induction vs ws arbitrary: i rule: diff.induct)
    apply (auto simp: word_ops_nth_size word_size)
    done

  lemma diff_correct: "\<alpha> (diff ws vs) = \<alpha> ws - \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun zeroes :: "'a::len word list \<Rightarrow> bool" where
    "zeroes [] \<longleftrightarrow> True"
  | "zeroes (w#ws) \<longleftrightarrow> w=0 \<and> zeroes ws"

  lemma zeroes_lookup: "zeroes ws \<longleftrightarrow> (\<forall>i. \<not>lookup i ws)"
    apply (induction ws)
    apply (auto simp: word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma isEmpty_correct: "zeroes ws \<longleftrightarrow> \<alpha> ws = {}"
    by (auto simp: zeroes_lookup \<alpha>_def)

  fun equal :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "equal [] [] \<longleftrightarrow> True"
  | "equal [] ws \<longleftrightarrow> zeroes ws"
  | "equal vs [] \<longleftrightarrow> zeroes vs"
  | "equal (v#vs) (w#ws) \<longleftrightarrow> v=w \<and> equal vs ws"

  lemma equal_lookup:
    fixes vs ws :: "'a::len word list"
    shows "equal vs ws \<longleftrightarrow> (\<forall>i. lookup i vs = lookup i ws)"
  proof (induction vs ws rule: equal.induct)
    fix v w and vs ws :: "'a::len word list"
    assume IH: "equal vs ws = (\<forall>i. lookup i vs = lookup i ws)"
    show "equal (v # vs) (w # ws) = (\<forall>i. lookup i (v # vs) = lookup i (w # ws))"
    proof (rule iffI, rule allI)
      fix i
      assume "equal (v#vs) (w#ws)"
      thus "lookup i (v # vs) = lookup i (w # ws)"
        by (auto simp: IH)
    next
      assume "\<forall>i. lookup i (v # vs) = lookup i (w # ws)"
      thus "equal (v # vs) (w # ws)"
        apply (auto simp: word_eq_iff IH)
        apply metis
        apply metis
        apply (drule_tac x="i + len_of TYPE('a)" in spec)
        apply auto []
        apply (drule_tac x="i + len_of TYPE('a)" in spec)
        apply auto []
        done
    qed
  qed (auto simp: zeroes_lookup)

  lemma equal_correct: "equal vs ws \<longleftrightarrow> \<alpha> vs = \<alpha> ws"
    by (auto simp: \<alpha>_def equal_lookup)

  fun subseteq :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subseteq [] ws \<longleftrightarrow> True"
  | "subseteq vs [] \<longleftrightarrow> zeroes vs"
  | "subseteq (v#vs) (w#ws) \<longleftrightarrow> (v AND NOT w = 0) \<and> subseteq vs ws"

  lemma subseteq_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subseteq vs ws \<longleftrightarrow> (\<forall>i. lookup i vs \<longrightarrow> lookup i ws)"
    apply (induction vs ws rule: subseteq.induct)
    apply simp
    apply (auto simp: zeroes_lookup) []
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma subseteq_correct: "subseteq vs ws \<longleftrightarrow> \<alpha> vs \<subseteq> \<alpha> ws"
    by (auto simp: \<alpha>_def subseteq_lookup)

  fun subset :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subset [] ws \<longleftrightarrow> \<not>zeroes ws"
  | "subset vs [] \<longleftrightarrow> False"
  | "subset (v#vs) (w#ws) \<longleftrightarrow> (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"

  lemma subset_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subset vs ws \<longleftrightarrow> ((\<forall>i. lookup i vs \<longrightarrow> lookup i ws)
      \<and> (\<exists>i. \<not>lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: subset.induct)
    apply (simp add: zeroes_lookup)
    apply (simp add: zeroes_lookup) []
    apply (simp del: subseteq_correct add: subseteq_lookup)
    apply safe
    apply simp_all
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    done

  lemma subset_correct: "subset vs ws \<longleftrightarrow> \<alpha> vs \<subset> \<alpha> ws"
    by (auto simp: \<alpha>_def subset_lookup)

  fun disjoint :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "disjoint [] ws \<longleftrightarrow> True"
  | "disjoint vs [] \<longleftrightarrow> True"
  | "disjoint (v#vs) (w#ws) \<longleftrightarrow> (v AND w = 0) \<and> disjoint vs ws"

  lemma disjoint_lookup:
    fixes vs ws :: "'a::len word list"
    shows "disjoint vs ws \<longleftrightarrow> (\<forall>i. \<not>(lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: disjoint.induct)
    apply simp
    apply simp
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma disjoint_correct: "disjoint vs ws \<longleftrightarrow> \<alpha> vs \<inter> \<alpha> ws = {}"
    by (auto simp: \<alpha>_def disjoint_lookup)

subsection {* Lifting to Uint *}
  type_synonym uint_vector = "uint list"

  lift_definition uv_\<alpha> :: "uint_vector \<Rightarrow> nat set" is \<alpha> .
  lift_definition uv_lookup :: "nat \<Rightarrow> uint_vector \<Rightarrow> bool" is lookup .
  lift_definition uv_empty :: "uint_vector" is empty .
  lift_definition uv_single_bit :: "nat \<Rightarrow> uint_vector" is single_bit .
  lift_definition uv_set_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is set_bit .
  lift_definition uv_reset_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is reset_bit .
  lift_definition uv_union :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is union .
  lift_definition uv_inter :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is inter .
  lift_definition uv_diff :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is diff .
  lift_definition uv_zeroes :: "uint_vector \<Rightarrow> bool" is zeroes .
  lift_definition uv_equal :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is equal .
  lift_definition uv_subseteq :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subseteq .
  lift_definition uv_subset :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subset .
  lift_definition uv_disjoint :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is disjoint .

  lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]

  lemmas [where 'a=dflt_size, Transfer.transferred, code] =
    lookup.simps
    empty_def
    single_bit.simps
    set_bit.simps
    reset_bit.simps
    union.simps
    inter.simps
    diff.simps
    zeroes.simps
    equal.simps
    subseteq.simps
    subset.simps
    disjoint.simps

  hide_const (open) \<alpha> lookup empty single_bit set_bit reset_bit union inter diff zeroes
    equal subseteq subset disjoint

subsection {* Autoref Setup *}

  definition uv_set_rel_def_internal:
    "uv_set_rel Rk \<equiv>
      if Rk=nat_rel then br uv_\<alpha> (\<lambda>_. True) else {}"
  lemma uv_set_rel_def:
    "\<langle>nat_rel\<rangle>uv_set_rel \<equiv> br uv_\<alpha> (\<lambda>_. True)"
    unfolding uv_set_rel_def_internal relAPP_def by simp

  lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]

  lemma uv_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>uv_set_rel)"
    unfolding uv_set_rel_def by auto

  lemma uv_autoref[autoref_rules,param]:
    "(uv_lookup,op \<in>) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_empty,{}) \<in> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_set_bit,insert) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_reset_bit,op_set_delete) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_union,op \<union>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_inter,op \<inter>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_diff,op -) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_zeroes,op_set_isEmpty) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_equal,op =) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subseteq,op \<subseteq>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subset,op \<subset>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_disjoint,op_set_disjoint) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    by (auto
      simp: uv_set_rel_def br_def
      simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
      simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
      simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)

  export_code
    uv_lookup
    uv_empty
    uv_single_bit
    uv_set_bit
    uv_reset_bit
    uv_union
    uv_inter
    uv_diff
    uv_zeroes
    uv_equal
    uv_subseteq
    uv_subset
    uv_disjoint
  checking SML Scala Haskell? OCaml?

end


(*  Title:      HOL/SPARK/SPARK_Setup.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Setup for SPARK/Ada verification environment.
*)

theory SPARK_Setup
imports "~~/src/HOL/Word/Word" "~~/src/HOL/Word/Bit_Comparison"
keywords
  "spark_open_vcg" :: thy_load ("vcg", "fdl", "rls") and
  "spark_open" :: thy_load ("siv", "fdl", "rls") and
  "spark_proof_functions" "spark_types" "spark_end" :: thy_decl and
  "spark_vc" :: thy_goal and "spark_status" :: diag
begin

ML_file "Tools/fdl_lexer.ML"
ML_file "Tools/fdl_parser.ML"

text {*
SPARK version of div, see section 4.4.1.1 of SPARK Proof Manual
*}

definition sdiv :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "sdiv" 70) where
  "a sdiv b = sgn a * sgn b * (\<bar>a\<bar> div \<bar>b\<bar>)"

lemma sdiv_minus_dividend: "- a sdiv b = - (a sdiv b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_minus_divisor: "a sdiv - b = - (a sdiv b)"
  by (simp add: sdiv_def sgn_if)

text {*
Correspondence between HOL's and SPARK's version of div
*}

lemma sdiv_pos_pos: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a sdiv b = a div b"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_pos_neg: "0 \<le> a \<Longrightarrow> b < 0 \<Longrightarrow> a sdiv b = - (a div - b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_neg_pos: "a < 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> a sdiv b = - (- a div b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a sdiv b = - a div - b"
  by (simp add: sdiv_def sgn_if)

text {*
Updating a function at a set of points. Useful for building arrays.
*}

definition fun_upds :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b" where
  "fun_upds f xs y z = (if z \<in> xs then y else f z)"

syntax
  "_updsbind" :: "['a, 'a] => updbind"             ("(2_ [:=]/ _)")

translations
  "f(xs[:=]y)" == "CONST fun_upds f xs y"

lemma fun_upds_in [simp]: "z \<in> xs \<Longrightarrow> (f(xs [:=] y)) z = y"
  by (simp add: fun_upds_def)

lemma fun_upds_notin [simp]: "z \<notin> xs \<Longrightarrow> (f(xs [:=] y)) z = f z"
  by (simp add: fun_upds_def)

lemma upds_singleton [simp]: "f({x} [:=] y) = f(x := y)"
  by (simp add: fun_eq_iff)

text {* Enumeration types *}

class spark_enum = ord + finite +
  fixes pos :: "'a \<Rightarrow> int"
  assumes range_pos: "range pos = {0..<int (card (UNIV::'a set))}"
  and less_pos: "(x < y) = (pos x < pos y)"
  and less_eq_pos: "(x \<le> y) = (pos x \<le> pos y)"
begin

definition "val = inv pos"

definition "succ x = val (pos x + 1)"

definition "pred x = val (pos x - 1)"

lemma inj_pos: "inj pos"
  using finite_UNIV
  by (rule eq_card_imp_inj_on) (simp add: range_pos)

lemma val_pos: "val (pos x) = x"
  unfolding val_def using inj_pos
  by (rule inv_f_f)

lemma pos_val: "z \<in> range pos \<Longrightarrow> pos (val z) = z"
  unfolding val_def
  by (rule f_inv_into_f)

subclass linorder
proof
  fix x::'a and y show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (simp add: less_pos less_eq_pos less_le_not_le)
next
  fix x::'a show "x \<le> x" by (simp add: less_eq_pos)
next
  fix x::'a and y z assume "x \<le> y" and "y \<le> z"
  then show "x \<le> z" by (simp add: less_eq_pos)
next
  fix x::'a and y assume "x \<le> y" and "y \<le> x"
  with inj_pos show "x = y"
    by (auto dest: injD simp add: less_eq_pos)
next
  fix x::'a and y show "x \<le> y \<or> y \<le> x"
    by (simp add: less_eq_pos linear)
qed

definition "first_el = val 0"

definition "last_el = val (int (card (UNIV::'a set)) - 1)"

lemma first_el_smallest: "first_el \<le> x"
proof -
  have "pos x \<in> range pos" by (rule rangeI)
  then have "pos (val 0) \<le> pos x"
    by (simp add: range_pos pos_val)
  then show ?thesis by (simp add: first_el_def less_eq_pos)
qed

lemma last_el_greatest: "x \<le> last_el"
proof -
  have "pos x \<in> range pos" by (rule rangeI)
  then have "pos x \<le> pos (val (int (card (UNIV::'a set)) - 1))"
    by (simp add: range_pos pos_val)
  then show ?thesis by (simp add: last_el_def less_eq_pos)
qed

lemma pos_succ:
  assumes "x \<noteq> last_el"
  shows "pos (succ x) = pos x + 1"
proof -
  have "x \<le> last_el" by (rule last_el_greatest)
  with assms have "x < last_el" by simp
  then have "pos x < pos last_el"
    by (simp add: less_pos)
  with rangeI [of pos x]
  have "pos x + 1 \<in> range pos"
    by (simp add: range_pos last_el_def pos_val)
  then show ?thesis
    by (simp add: succ_def pos_val)
qed

lemma pos_pred:
  assumes "x \<noteq> first_el"
  shows "pos (pred x) = pos x - 1"
proof -
  have "first_el \<le> x" by (rule first_el_smallest)
  with assms have "first_el < x" by simp
  then have "pos first_el < pos x"
    by (simp add: less_pos)
  with rangeI [of pos x]
  have "pos x - 1 \<in> range pos"
    by (simp add: range_pos first_el_def pos_val)
  then show ?thesis
    by (simp add: pred_def pos_val)
qed

lemma succ_val: "x \<in> range pos \<Longrightarrow> succ (val x) = val (x + 1)"
  by (simp add: succ_def pos_val)

lemma pred_val: "x \<in> range pos \<Longrightarrow> pred (val x) = val (x - 1)"
  by (simp add: pred_def pos_val)

end

lemma interval_expand:
  "x < y \<Longrightarrow> (z::int) \<in> {x..<y} = (z = x \<or> z \<in> {x+1..<y})"
  by auto

text {* Load the package *}

ML_file "Tools/spark_vcs.ML"
ML_file "Tools/spark_commands.ML"

end


(*<*)theory Pairs imports Main begin(*>*)

section{*Pairs and Tuples*}

text{*\label{sec:products}
Ordered pairs were already introduced in \S\ref{sec:pairs}, but only with a minimal
repertoire of operations: pairing and the two projections @{term fst} and
@{term snd}. In any non-trivial application of pairs you will find that this
quickly leads to unreadable nests of projections. This
section introduces syntactic sugar to overcome this
problem: pattern matching with tuples.
*}

subsection{*Pattern Matching with Tuples*}

text{*
Tuples may be used as patterns in $\lambda$-abstractions,
for example @{text"\<lambda>(x,y,z).x+y+z"} and @{text"\<lambda>((x,y),z).x+y+z"}. In fact,
tuple patterns can be used in most variable binding constructs,
and they can be nested. Here are
some typical examples:
\begin{quote}
@{term"let (x,y) = f z in (y,x)"}\\
@{term"case xs of [] => (0::nat) | (x,y)#zs => x+y"}\\
@{text"\<forall>(x,y)\<in>A. x=y"}\\
@{text"{(x,y,z). x=z}"}\\
@{term"\<Union>(x,y)\<in>A. {x+y}"}
\end{quote}
The intuitive meanings of these expressions should be obvious.
Unfortunately, we need to know in more detail what the notation really stands
for once we have to reason about it.  Abstraction
over pairs and tuples is merely a convenient shorthand for a more complex
internal representation.  Thus the internal and external form of a term may
differ, which can affect proofs. If you want to avoid this complication,
stick to @{term fst} and @{term snd} and write @{term"%p. fst p + snd p"}
instead of @{text"\<lambda>(x,y). x+y"}.  These terms are distinct even though they
denote the same function.

Internally, @{term"%(x,y). t"} becomes @{text"case_prod (\<lambda>x y. t)"}, where
\cdx{split} is the uncurrying function of type @{text"('a \<Rightarrow> 'b
\<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c"} defined as
\begin{center}
@{thm split_def}
\hfill(@{thm[source]split_def})
\end{center}
Pattern matching in
other variable binding constructs is translated similarly. Thus we need to
understand how to reason about such constructs.
*}

subsection{*Theorem Proving*}

text{*
The most obvious approach is the brute force expansion of @{term split}:
*}

lemma "(\<lambda>(x,y).x) p = fst p"
by(simp add: split_def)

text{* \noindent
This works well if rewriting with @{thm[source]split_def} finishes the
proof, as it does above.  But if it does not, you end up with exactly what
we are trying to avoid: nests of @{term fst} and @{term snd}. Thus this
approach is neither elegant nor very practical in large examples, although it
can be effective in small ones.

If we consider why this lemma presents a problem,
we realize that we need to replace variable~@{term
p} by some pair @{term"(a,b)"}.  Then both sides of the
equation would simplify to @{term a} by the simplification rules
@{thm split_conv[no_vars]} and @{thm fst_conv[no_vars]}.
To reason about tuple patterns requires some way of
converting a variable of product type into a pair.
In case of a subterm of the form @{term"case_prod f p"} this is easy: the split
rule @{thm[source]prod.split} replaces @{term p} by a pair:%
\index{*split (method)}
*}

lemma "(\<lambda>(x,y).y) p = snd p"
apply(split prod.split)

txt{*
@{subgoals[display,indent=0]}
This subgoal is easily proved by simplification. Thus we could have combined
simplification and splitting in one command that proves the goal outright:
*}
(*<*)
by simp
lemma "(\<lambda>(x,y).y) p = snd p"(*>*)
by(simp split: prod.split)

text{*
Let us look at a second example:
*}

lemma "let (x,y) = p in fst p = x"
apply(simp only: Let_def)

txt{*
@{subgoals[display,indent=0]}
A paired @{text let} reduces to a paired $\lambda$-abstraction, which
can be split as above. The same is true for paired set comprehension:
*}

(*<*)by(simp split: prod.split)(*>*)
lemma "p \<in> {(x,y). x=y} \<longrightarrow> fst p = snd p"
apply simp

txt{*
@{subgoals[display,indent=0]}
Again, simplification produces a term suitable for @{thm[source]prod.split}
as above. If you are worried about the strange form of the premise:
@{text"case_prod (op =)"} is short for @{term"\<lambda>(x,y). x=y"}.
The same proof procedure works for
*}

(*<*)by(simp split: prod.split)(*>*)
lemma "p \<in> {(x,y). x=y} \<Longrightarrow> fst p = snd p"

txt{*\noindent
except that we now have to use @{thm[source]prod.split_asm}, because
@{term split} occurs in the assumptions.

However, splitting @{term split} is not always a solution, as no @{term split}
may be present in the goal. Consider the following function:
*}

(*<*)by(simp split: prod.split_asm)(*>*)
primrec swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a" where "swap (x,y) = (y,x)"

text{*\noindent
Note that the above \isacommand{primrec} definition is admissible
because @{text"\<times>"} is a datatype. When we now try to prove
*}

lemma "swap(swap p) = p"

txt{*\noindent
simplification will do nothing, because the defining equation for
@{const[source] swap} expects a pair. Again, we need to turn @{term p}
into a pair first, but this time there is no @{term split} in sight.
The only thing we can do is to split the term by hand:
*}
apply(case_tac p)

txt{*\noindent
@{subgoals[display,indent=0]}
Again, \methdx{case_tac} is applicable because @{text"\<times>"} is a datatype.
The subgoal is easily proved by @{text simp}.

Splitting by @{text case_tac} also solves the previous examples and may thus
appear preferable to the more arcane methods introduced first. However, see
the warning about @{text case_tac} in \S\ref{sec:struct-ind-case}.

Alternatively, you can split \emph{all} @{text"\<And>"}-quantified variables
in a goal with the rewrite rule @{thm[source]split_paired_all}:
*}

(*<*)by simp(*>*)
lemma "\<And>p q. swap(swap p) = q \<longrightarrow> p = q"
apply(simp only: split_paired_all)

txt{*\noindent
@{subgoals[display,indent=0,margin=70]}
*}

apply simp
done

text{*\noindent
Note that we have intentionally included only @{thm[source]split_paired_all}
in the first simplification step, and then we simplify again.
This time the reason was not merely
pedagogical:
@{thm[source]split_paired_all} may interfere with other functions
of the simplifier.
The following command could fail (here it does not)
where two separate \isa{simp} applications succeed.
*}

(*<*)
lemma "\<And>p q. swap(swap p) = q \<longrightarrow> p = q"
(*>*)
apply(simp add: split_paired_all)
(*<*)done(*>*)
text{*\noindent
Finally, the simplifier automatically splits all @{text"\<forall>"} and
@{text"\<exists>"}-quantified variables:
*}

lemma "\<forall>p. \<exists>q. swap p = swap q"
by simp

text{*\noindent
To turn off this automatic splitting, disable the
responsible simplification rules:
\begin{center}
@{thm split_paired_All[no_vars]}
\hfill
(@{thm[source]split_paired_All})\\
@{thm split_paired_Ex[no_vars]}
\hfill
(@{thm[source]split_paired_Ex})
\end{center}
*}
(*<*)
end
(*>*)


(*
Title:        BL_LocalDeduction.thy
Description:  Formalization of the local deduction theorem from Basic Logic.
Author:       Petr Revay, Department of Logic, Faculty of Arts, Charles University in Prague
*)

theory BL_LocalDeduction
imports BasicLogic BL_theorems
begin

thm CnBL.induct --"nahled schematu indukce vygenerovaneho z definice CnBL"

lemma MultiConjDistribution [simp]:
  "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longleftrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) \<in> CnBL {}"
proof (unfold Equivalence_BL_def, induct n, simp)
  have
  1: "((Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m &\<^sub>B\<^sub>L Const_1) \<longrightarrow>\<^sub>B\<^sub>L
      ((\<phi> ^\<^sup>B\<^sup>L m &\<^sub>B\<^sub>L Const_1 \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m))) \<in> CnBL {}"
    by (metis CnBL.BL1)
  have
  2: "(Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m &\<^sub>B\<^sub>L Const_1) \<in> CnBL {}"
    by (metis TBL7)
  have
  3: "(\<phi> ^\<^sup>B\<^sup>L m &\<^sub>B\<^sub>L Const_1 \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
    by (metis TBL32a)
  from 2 and 1 have
  4: "((\<phi> ^\<^sup>B\<^sup>L m &\<^sub>B\<^sub>L Const_1 \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
    by (metis (full_types) CnBL.MP)
  from 3 and 4 have
  5: "(Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
    by (metis CnBL.MP)
  have
  6: "(\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
    by (metis Hajek_20)
  have
  7: "((Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
       ((\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
        ((Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)))) \<in> CnBL {}"
    by (metis TBL10)
  from 5 and 7 have
  8: "((\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
      ((Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m))) \<in> CnBL {}"
    by (metis (full_types) CnBL.MP)
  from 6 and 8 show
  9: "((Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L
       (\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L Const_1 &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
    by (metis CnBL.MP)
next
  fix n
  assume
  1: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
  have
  2: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
       (\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m)) \<in> CnBL {}"
    by (metis TBL6)
  from 1 and 2 have
  3: "(\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) \<in> CnBL {}"
    by (metis (full_types) CnBL.MP) --"prvni cast konjunkce"
  have
  4: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L
       (((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L \<phi>) \<longrightarrow>\<^sub>B\<^sub>L
        (\<phi> ^\<^sup>B\<^sup>L n + m &\<^sub>B\<^sub>L \<phi>))) \<in> CnBL {}" by simp --"(6)"
  from 3 and 4 have
  5: "(((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L \<phi>) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n + m &\<^sub>B\<^sub>L \<phi>)) \<in> CnBL {}"
    by (metis (full_types) CnBL.MP)
        --"now it is necessary to swap conjunctions"
  then have
  6: "((\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m)) \<in> CnBL {}"
    by (metis (full_types) CnBL.MP VL1)
  then have
  7: "(((\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n) &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
       (\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m)) \<in> CnBL {}"
    by (metis (full_types) BL_transitivity_of_implication TBL9a)
  have
  8: "(\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n) = (\<phi> ^\<^sup>B\<^sup>L Suc n)"
    by simp
  have
  9: "(\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) = (\<phi> ^\<^sup>B\<^sup>L Suc n + m)"
    by simp
  from 7 and 8 and 9 have
  10: "((\<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m)) \<in> CnBL {}"
        by metis --"1st part of conj. done!"

  have
  11: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
        (\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
    by (metis Chvalovsky_4_4_c)
  from 1 and 11 have
  12: "(\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
    by (metis CnBL.MP)
  have
  13: "((\<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
        ((\<phi> ^\<^sup>B\<^sup>L n + m &\<^sub>B\<^sub>L \<phi>) \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L \<phi>))) \<in> CnBL {}"
    by (metis TBL8)
  from 12 and 13 have
  14: "((\<phi> ^\<^sup>B\<^sup>L n + m &\<^sub>B\<^sub>L \<phi>) \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) &\<^sub>B\<^sub>L \<phi>)) \<in> CnBL {}"
    by (metis CnBL.MP)
  then have
  15: "(\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
      by (metis BL_transitivity_of_implication TBL7)
  then have
  16: "(\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m \<longrightarrow>\<^sub>B\<^sub>L (\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n) &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
      by (metis BL_transitivity_of_implication TBL9b)
  from 16 and 8 and 9 have
  17: "(\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<in> CnBL {}"
    by metis
      --"2nd part done! now just make the final conj."
  have
  18: "(((\<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m)) \<longrightarrow>\<^sub>B\<^sub>L
        ((\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
         ((\<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m)) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m))) \<in> CnBL {}"
    by (metis TBL10)
  from 10 and 18 have
  19: "((\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
       ((\<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m)) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
          by (metis (full_types) CnBL.MP TBL10)
  from 17 and 19 show
  20: "(((\<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m)) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n + m \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L Suc n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL {}"
    by (metis CnBL.MP)
qed

theorem LocalDeductionBL1 [simp]:
"\<psi> \<in> CnBL (\<Gamma> \<union> {\<phi>}) \<Longrightarrow> (\<exists>n. ((\<phi> ^\<^sup>B\<^sup>L n) \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<in> CnBL \<Gamma>)"
proof (rule CnBL.induct)
  fix \<phi>' \<psi> \<chi>

--"the case of BL1"
  have
  1: "(\<phi> ^\<^sup>B\<^sup>L 0 \<longrightarrow>\<^sub>B\<^sub>L ((\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<longrightarrow>\<^sub>B\<^sub>L ((\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>) \<longrightarrow>\<^sub>B\<^sub>L (\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<chi>)))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.BL1 CnBL.MP TBL2 emptyAsm)
  then show
  2: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L ((\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<longrightarrow>\<^sub>B\<^sub>L ((\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>) \<longrightarrow>\<^sub>B\<^sub>L (\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<chi>)))) \<in> CnBL \<Gamma>"
    by metis

--"the case of BL4"
  show
  3: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (\<phi>' &\<^sub>B\<^sub>L (\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<longrightarrow>\<^sub>B\<^sub>L \<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.BL4 CnBL.MP TBL2 emptyAsm)
--"the case of BL5a"
  show
  4: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L ((\<phi>' &\<^sub>B\<^sub>L \<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>) \<longrightarrow>\<^sub>B\<^sub>L (\<phi>' \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>)))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.BL5a CnBL.MP TBL2 emptyAsm)
--"the case of BL5b"
  show
  5: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L ((\<phi>' \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>)) \<longrightarrow>\<^sub>B\<^sub>L (\<phi>' &\<^sub>B\<^sub>L \<psi> \<longrightarrow>\<^sub>B\<^sub>L \<chi>))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.BL5b CnBL.MP TBL2 emptyAsm)

--"the case of BL6"
  show
  6: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (((\<phi>' \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<longrightarrow>\<^sub>B\<^sub>L \<chi>) \<longrightarrow>\<^sub>B\<^sub>L (((\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<longrightarrow>\<^sub>B\<^sub>L \<chi>) \<longrightarrow>\<^sub>B\<^sub>L \<chi>))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.BL6 CnBL.MP TBL2 emptyAsm)
--"case of BL7"
  show
  7: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (Const_0 \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<in> CnBL \<Gamma>"
    by (metis Chvalovsky_4_4_c_28 emptyAsm)
next
--"The case of an assumption"
  fix \<phi>'
  assume "\<phi>' \<in> (\<Gamma> \<union> {\<phi>})"
  then show
  9: "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
    proof
      assume "\<phi>' \<in> \<Gamma>"
      then show "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
        by (metis (full_types) CnBL.Assumption CnBL.MP TBL2 emptyAsm)
    next
      assume "\<phi>' \<in> {\<phi>}"
      then have "\<phi>' = \<phi>"
        by simp
      hence "(\<phi> ^\<^sup>B\<^sup>L 1 \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
        by simp
      then show "\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
        by (rule exI)
    qed
next
--"inductive step"
  fix \<phi>' \<psi>
  assume
  1: "(\<psi> \<in> CnBL (\<Gamma> \<union> {\<phi>}) \<and> (\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<in> CnBL \<Gamma>)) \<and>
      (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL (\<Gamma> \<union> {\<phi>}) \<and> (\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<in> CnBL \<Gamma>)"
  from 1 obtain n where
  2: "(\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<in> CnBL \<Gamma>"
    by metis
  from 1 obtain m where
  3: "(\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<in> CnBL \<Gamma>"
    by metis
  from 2 have
  4: "((\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')))) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.MP TBL10 emptyAsm)
  from 3 and 4 have
  5: "((\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L m \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<in> CnBL \<Gamma>"
    by (metis CnBL.MP)
  have
  6: "((((\<phi> ^\<^sup>B\<^sup>L n) \<longrightarrow>\<^sub>B\<^sub>L \<psi>) &\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<longrightarrow>\<^sub>B\<^sub>L
             (((\<phi> ^\<^sup>B\<^sup>L n) &\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L m)) \<longrightarrow>\<^sub>B\<^sub>L (\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')))) \<in> CnBL \<Gamma>"
    by (metis (full_types) Hajek_7 emptyAsm)
  from 5 and 6 have
  7: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<in> CnBL \<Gamma>"
    by (metis CnBL.MP)
  have
  8: "((\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
    by (metis (full_types) Hajek_4 emptyAsm)
  have
  9: "(((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L (\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<longrightarrow>\<^sub>B\<^sub>L
             (((\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<in> CnBL \<Gamma>"
    by (metis CnBL.BL1)
  from 7 and 9 have
  10: "(((\<psi> &\<^sub>B\<^sub>L (\<psi> \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.MP)
  from 8 and 10 have
  11: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
    by (metis CnBL.MP)
  have
  12: "((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longleftrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) \<in> CnBL \<Gamma>"
    by (metis MultiConjDistribution emptyAsm)
  have
  13: "(((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longleftrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L
       ((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m))) \<in> CnBL \<Gamma>"
    by (metis (full_types) Chvalovsky_4_4_c Equivalence_BL_def emptyAsm)
  from 12 and 13 have
  14: "((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m)) \<in> CnBL \<Gamma>"
    by (metis CnBL.MP)
  have
  15: "(((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L
             (((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>'))) \<in> CnBL \<Gamma>"
    by (metis CnBL.BL1)
  from 14 and 15 have
  16: "(((\<phi> ^\<^sup>B\<^sup>L n &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<longrightarrow>\<^sub>B\<^sub>L ((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>')) \<in> CnBL \<Gamma>"
    by (metis (full_types) CnBL.MP)
  from 11 and 16 have
  17: "((\<phi> ^\<^sup>B\<^sup>L n + m) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
    by (metis CnBL.MP)
  from 17 show
  18: "\<exists>n. ((\<phi> ^\<^sup>B\<^sup>L n) \<longrightarrow>\<^sub>B\<^sub>L \<phi>') \<in> CnBL \<Gamma>"
    by metis
qed

lemma DerivabilityOfStrongConj [simp]:
  "(\<phi> ^\<^sup>B\<^sup>L n) \<in> CnBL (\<Gamma> \<union> {\<phi>})"
proof (induct n)
  case 0
  show ?case by simp
next
  have
    "\<forall>n. (\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n) = (\<phi> ^\<^sup>B\<^sup>L Suc n)"
      by simp
  then have
  1: "\<forall>n. ((\<phi> &\<^sub>B\<^sub>L \<phi> ^\<^sup>B\<^sup>L n) \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n)) \<in> CnBL (\<Gamma> \<union> {\<phi>})"
    by simp
  from 1 have
  2: "\<forall>n. (\<phi> \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n))) \<in> CnBL (\<Gamma> \<union> {\<phi>})"
    by simp
  from 2 have
  3: "\<forall>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L (\<phi> ^\<^sup>B\<^sup>L Suc n)) \<in> CnBL (\<Gamma> \<union> {\<phi>})"
    by blast
  case (Suc n)
  then show ?case using 3
    by blast
qed

thm CnBL.induct
lemma CnBLMonotonicity [simp]:
  "\<phi> \<in> CnBL \<Gamma> \<Longrightarrow> \<phi> \<in> CnBL (\<Gamma> \<union> \<Delta>)"
apply (rule CnBL.induct)
print_state
by blast+

theorem LocalDeductionBL2 [simp]:
  "(\<exists>n. (\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<in> CnBL \<Gamma>) \<Longrightarrow> \<psi> \<in> CnBL (\<Gamma> \<union> {\<phi>})"
apply (erule exE)
 apply (subgoal_tac "(\<phi> ^\<^sup>B\<^sup>L n \<longrightarrow>\<^sub>B\<^sub>L \<psi>) \<in> CnBL (\<Gamma> \<union> {\<phi>})")
 --"adds assumption"
 prefer 2 --"move subgoal 2 to 1st place"
 apply (rule CnBLMonotonicity)
apply metis
 apply (subgoal_tac "(\<phi> ^\<^sup>B\<^sup>L n) \<in> CnBL (\<Gamma> \<union> {\<phi>})")
 --"adds assumption"
 prefer 2
apply (rule DerivabilityOfStrongConj)
by blast

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_tree_Flatten1
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function flatten1 :: "('a Tree) list => 'a list" where
  "flatten1 (nil2) = nil2"
| "flatten1 (cons2 (Node (Node x3 x4 x5) x2 q) ps) =
     flatten1 (cons2 (Node x3 x4 x5) (cons2 (Node (Nil) x2 q) ps))"
| "flatten1 (cons2 (Node (Nil) x2 q) ps) =
     cons2 x2 (flatten1 (cons2 q ps))"
| "flatten1 (cons2 (Nil) ps) = flatten1 ps"
  by pat_completeness auto

fun flatten0 :: "'a Tree => 'a list" where
  "flatten0 (Node p z q) =
   x (flatten0 p) (x (cons2 z (nil2)) (flatten0 q))"
| "flatten0 (Nil) = nil2"

theorem property0 :
  "((flatten1 (cons2 p (nil2))) = (flatten0 p))"
  oops

end


theory Simplificacion3
imports Main
begin

section {* Reescritura con definiciones *}

text {* Ejemplo de definición: (cuadrado x) es el cuadrado de x. Por
  ejemplo,
     cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))
*}
definition cuadrado :: "nat \<Rightarrow> nat" where
  "cuadrado n = n*n"

value "cuadrado (Suc (Suc 0))"

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))"
apply (simp add: cuadrado_def)
done

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado(n*n) = cuadrado(n)*cuadrado(n)"
apply (simp add: cuadrado_def)
done

end


(* Authors: F. Maric, M. Spasic *)
theory Rel_Chain
  imports
    Simplex_Auxiliary
begin

definition
  rel_chain :: "'a list \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
  where
    "rel_chain l r = (\<forall> k < length l - 1. (l ! k, l ! (k + 1)) \<in> r)"

lemma
  rel_chain_Nil: "rel_chain [] r" and
  rel_chain_Cons: "rel_chain (x # xs) r = (if xs = [] then True else ((x, hd xs) \<in> r) \<and> rel_chain xs r)"
  by (auto simp add: rel_chain_def hd_conv_nth nth_Cons split: nat.split_asm nat.split)

lemma rel_chain_drop:
  "rel_chain l R ==> rel_chain (drop n l) R"
  unfolding rel_chain_def
  by simp

lemma rel_chain_take:
  "rel_chain l R ==> rel_chain (take n l) R"
  unfolding rel_chain_def
  by simp

lemma rel_chain_butlast:
  "rel_chain l R ==> rel_chain (butlast l) R"
  unfolding rel_chain_def
  by (auto simp add: butlast_nth)

lemma rel_chain_tl:
  "rel_chain l R ==> rel_chain (tl l) R"
  unfolding rel_chain_def
  by (cases "l = []") (auto simp add: tl_nth)

lemma rel_chain_append:
  assumes "rel_chain l R" "rel_chain l' R" "(last l, hd l') \<in> R"
  shows "rel_chain (l @ l') R"
  using assms
  by (induct l) (auto simp add: rel_chain_Cons split: if_splits)

lemma rel_chain_appendD:
  assumes "rel_chain (l @ l') R"
  shows "rel_chain l R" "rel_chain l' R" "l \<noteq> [] \<and> l' \<noteq> [] \<longrightarrow> (last l, hd l') \<in> R"
  using assms
  by (induct l) (auto simp add: rel_chain_Cons rel_chain_Nil split: if_splits)

lemma rtrancl_rel_chain:
  "(x, y) \<in> R\<^sup>* \<longleftrightarrow> (\<exists> l. l \<noteq> [] \<and> hd l = x \<and> last l = y \<and> rel_chain l R)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (induct rule: converse_rtrancl_induct) (auto simp add: rel_chain_Cons)
next
  assume ?rhs
  then obtain l where "l \<noteq> []" "hd l = x" "last l = y" "rel_chain l R"
    by auto
  then show ?lhs
    by (induct l arbitrary: x) (auto simp add: rel_chain_Cons, force)
qed

lemma trancl_rel_chain:
  "(x, y) \<in> R\<^sup>+ \<longleftrightarrow> (\<exists> l. l \<noteq> [] \<and> length l > 1 \<and> hd l = x \<and> last l = y \<and> rel_chain l R)" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain z where "(x, z) \<in> R" "(z, y) \<in> R\<^sup>*"
    by (auto dest: tranclD)
  then obtain l where  "l \<noteq> [] \<and> hd l = z \<and> last l = y \<and> rel_chain l R"
    by (auto simp add: rtrancl_rel_chain)
  then show ?rhs
    using \<open>(x, z) \<in> R\<close>
    by (rule_tac x="x # l" in exI) (auto simp add: rel_chain_Cons)
next
  assume ?rhs
  then obtain l where "1 < length l" "l \<noteq> []" "hd l = x" "last l = y" "rel_chain l R"
    by auto
  then obtain l' where
    "l' \<noteq> []" "l = x # l'" "(x, hd l') \<in> R" "rel_chain l' R"
    using \<open>1 < length l\<close>
    by (cases l) (auto simp add: rel_chain_Cons)
  then have "(x, hd l') \<in> R" "(hd l', y) \<in> R\<^sup>*"
    using \<open>last l = y\<close>
    by (auto simp add: rtrancl_rel_chain)
  then show ?lhs
    by auto
qed

lemma rel_chain_elems_rtrancl:
  assumes "rel_chain l R" "i \<le> j" "j < length l"
  shows "(l ! i, l ! j) \<in> R\<^sup>*"
proof (cases "i = j")
  case True
  then show ?thesis
    by simp
next
  case False
  then have "i < j"
    using \<open>i \<le> j\<close>
    by simp
  then have "l \<noteq> []"
    using \<open>j < length l\<close>
    by auto

  let ?l = "drop i (take (j + 1) l)"

  have "?l \<noteq> []"
    using \<open>i < j\<close> \<open>j < length l\<close>
    by simp
  moreover
  have "hd ?l = l ! i"
    using \<open>?l \<noteq> []\<close> \<open>i < j\<close>
    by (auto simp add: hd_conv_nth)
  moreover
  have "last ?l = l ! j"
    using \<open>?l \<noteq> []\<close> \<open>l \<noteq> []\<close> \<open>i < j\<close> \<open>j < length l\<close>
    by (cases "length l = j + 1") (auto simp add: last_conv_nth min_def)
  moreover
  have "rel_chain ?l R"
    using \<open>rel_chain l R\<close>
    by (auto intro: rel_chain_drop rel_chain_take)
  ultimately
  show ?thesis
    by (subst rtrancl_rel_chain) blast
qed

lemma reorder_cyclic_list:
  assumes  "hd l = s" "last l = s" "length l > 2" "sl + 1 < length l"
    "rel_chain l r"
  obtains l' :: "'a list"
  where "hd l' = l ! (sl + 1)" "last l' = l ! sl" "rel_chain l' r" "length l' = length l - 1"
    "\<forall> i. i + 1 < length l' \<longrightarrow>
     (\<exists> j. j + 1 < length l \<and> l' ! i = l ! j \<and> l' ! (i + 1) = l ! (j + 1))"
proof-
  have "l \<noteq> []"
    using \<open>length l > 2\<close>
    by auto

  have  "length (tl l) > 1" "tl l \<noteq> []"
    using \<open>length l > 2\<close>
    by (auto simp add: length_0_conv[THEN sym])

  let ?l' = "if sl = 0 then
                 tl l
             else
                 drop (sl + 1) l @ tl (take (sl + 1) l)"

  have "hd ?l' = l ! (sl + 1)"
  proof (cases "sl > 0", simp_all)
    show "hd (tl l) = l ! (Suc 0)"
      using \<open>tl l \<noteq> []\<close> \<open>l \<noteq> []\<close>
      by (simp add: hd_conv_nth tl_nth)
  next
    assume "0 < sl"
    show "hd (drop (Suc sl) l @ tl (take (Suc sl) l)) = l ! (Suc sl)"
      using \<open>sl + 1 < length l\<close> \<open>l \<noteq> []\<close>
      by (auto simp add: hd_append hd_drop_conv_nth)
  qed

  moreover

  have "last ?l' = l ! sl"
  proof (cases "sl > 0", simp_all)
    show "last (tl l) = l ! 0"
      using \<open>l \<noteq> []\<close> \<open>last l = s\<close> \<open>hd l = s\<close> \<open>length l > 2\<close>
      by (simp add: hd_conv_nth last_tl)
  next
    assume "sl > 0"
    then show "last (drop (Suc sl) l @ tl (take (Suc sl) l)) = l ! sl"
      using \<open>l \<noteq> []\<close> \<open>tl l \<noteq> []\<close> \<open>sl + 1 < length l\<close>
      by (auto simp add: last_append drop_Suc tl_take last_take_conv_nth tl_nth)
  qed

  moreover

  have "rel_chain ?l' r"
  proof (cases "sl = 0", simp_all)
    case True
    show "rel_chain (tl l) r"
      using \<open>rel_chain l r\<close>
      by (auto intro: rel_chain_tl)
  next
    assume "sl > 0"
    show  "rel_chain (drop (Suc sl) l @ tl (take (Suc sl) l)) r"
    proof (rule rel_chain_append)
      show "rel_chain (drop (Suc sl) l) r"
        using \<open>rel_chain l r\<close>
        by (auto intro: rel_chain_drop)
    next
      show "rel_chain (tl (take (Suc sl) l)) r"
        using \<open>rel_chain l r\<close>
        by (auto intro: rel_chain_tl rel_chain_take)
    next
      have "last (drop (sl + 1) l) = l ! 0"
        using \<open>sl + 1 < length l\<close> \<open>last l = s\<close> \<open>hd l = s\<close> \<open>l \<noteq> []\<close>
        by (auto simp add: hd_conv_nth)
      moreover
      have "sl > 0 \<longrightarrow> tl (take (sl + 1) l) \<noteq> []"
        using \<open>sl + 1 < length l\<close> \<open>l \<noteq> []\<close> \<open>tl l \<noteq> []\<close>
        by (auto simp add: take_Suc)
      then have "sl > 0 \<longrightarrow> hd (tl (take (sl + 1) l)) = l ! 1"
        using \<open>l \<noteq> []\<close>
        by (auto simp add: hd_conv_nth take_Suc tl_nth)
      ultimately
      show "(last (drop (Suc sl) l), hd (tl (take (Suc sl) l))) \<in> r"
        using \<open>rel_chain l r\<close> \<open>length l > 2\<close> \<open>sl > 0\<close>
        unfolding rel_chain_def
        by simp
    qed
  qed

  moreover

  have "length ?l' = length l - 1"
    by auto

  ultimately

  obtain l' where *: "l' = ?l'" "hd l' = l ! (sl + 1)" "last l' = l ! sl" "rel_chain l' r" "length l' = length l - 1"
    by auto

  have l'_l: "\<forall> i. i + 1 < length l' \<longrightarrow>
    (\<exists> j. j + 1 < length l \<and> l' ! i = l ! j \<and> l' ! (i + 1) = l ! (j + 1))"
  proof (safe)
    fix i
    assume "i + 1 < length l'"
    show "\<exists> j. j + 1 < length l \<and> l' ! i = l ! j \<and> l' ! (i + 1) = l ! (j + 1)"
    proof (cases "sl = 0")
      case True
      then show ?thesis
        using \<open>i + 1 < length l'\<close>
        using \<open>l' = ?l'\<close> \<open>l \<noteq> []\<close>
        by (force simp add: tl_nth)
    next
      case False
      then have "length l' = length l - 1"
        using \<open>l' = ?l'\<close> \<open>sl + 1 < length l\<close>
        by (simp add: min_def)
      then have "i + 2 < length l"
        using \<open>i + 1 < length l'\<close>
        by simp

      show ?thesis
      proof (cases "i + 1 < length (drop (sl + 1) l)")
        case True
        then show ?thesis
          using \<open>sl \<noteq> 0\<close> \<open>l' = ?l'\<close>
          by (force simp add: nth_append)
      next
        case False
        show ?thesis
        proof (cases "i + 1 > length (drop (sl + 1) l)")
          case True
          then have "i + 1 > length l - (sl + 1)"
            by auto
          have
            "l' ! i = l ! Suc (i - (length l - Suc sl))"
            "l' ! (i + 1) = l ! Suc (Suc i - (length l - Suc sl))"
            using \<open>i + 2 < length l\<close> \<open>sl + 1 < length l\<close>
            using \<open>i + 1 > length l - (sl + 1)\<close>
            using \<open>sl \<noteq> 0\<close> \<open>l' = ?l'\<close> \<open>l \<noteq> []\<close>
            using tl_nth[of "take (sl + 1) l" "i - (length l - Suc sl)"]
            using tl_nth[of "take (sl + 1) l" "Suc i - (length l - Suc sl)"]
            by (auto simp add: nth_append)

          have "Suc (i - (length l - Suc sl)) = i + sl + 1 - length l + 1"
            "Suc (Suc i - (length l - Suc sl)) = (i + sl + 1 - length l + 1) + 1"
            "i + sl + 1 - length l + 1 + 1 < length l"
            using \<open>sl + 1 < length l\<close>
            using \<open>i + 1 > length l - (sl + 1)\<close>
            using \<open>i + 2 < length l\<close>
            by auto

          have "l' ! i = l ! (i + sl + 1 - length l + 1)"
            using \<open>l' ! i = l ! Suc (i - (length l - Suc sl))\<close>
            by (subst \<open>Suc (i - (length l - Suc sl)) = i + sl + 1 - length l + 1\<close>[THEN sym])
          moreover
          have "l' ! (i + 1) = l ! ((i + sl + 1 - length l + 1) + 1)"
            using \<open>l' ! (i + 1) = l ! Suc (Suc i - (length l - Suc sl))\<close>
            by (subst \<open>Suc (Suc i - (length l - Suc sl)) = (i + sl + 1 - length l + 1) + 1\<close>[THEN sym])
          ultimately
          show ?thesis
            using \<open>i + sl + 1 - length l + 1 + 1 < length l\<close>
            by force
        next
          case False
          then have "i + 1 = length l - sl - 1"
            using \<open>\<not> i + 1 < length (drop (sl + 1) l)\<close>
            by simp
          then have "length l - 1 = sl + i + 1"
            by auto
          then have "l ! Suc (sl + i) = last l"
            using last_conv_nth[of l, THEN sym] \<open>l \<noteq> []\<close>
            by simp
          then show ?thesis
            using \<open>i + 1 = length l - sl - 1\<close>
            using \<open>l' = ?l'\<close> \<open>sl \<noteq> 0\<close> \<open>l \<noteq> []\<close>
            using tl_nth[of "take (sl + 1) l" 0]
            using \<open>hd l = s\<close> \<open>last l = s\<close>
            by (force simp add: nth_append hd_conv_nth)
        qed
      qed
    qed
  qed

  then show thesis
    using * l'_l
    apply -
    ..
qed

end