section \<open>Lifting solutions of Pell's Equation\<close>
theory Pell_Lifting
  imports Pell.Pell Pell.Pell_Algorithm
begin

subsection \<open>Auxiliary material\<close>

(* TODO Move *)
lemma (in pell) snth_pell_solutions: "snth (pell_solutions D) n = nth_solution n"
  by (simp add: pell_solutions_def Let_def find_fund_sol_correct nonsquare_D nth_solution_def
                pell_power_def pell_mul_commutes[of _ fund_sol])

definition square_squarefree_part_nat :: "nat \<Rightarrow> nat \<times> nat" where
  "square_squarefree_part_nat n = (square_part n, squarefree_part n)"

lemma prime_factorization_squarefree_part:
  assumes "x \<noteq> 0"
  shows   "prime_factorization (squarefree_part x) =
             mset_set {p \<in> prime_factors x. odd (multiplicity p x)}" (is "?lhs = ?rhs")
proof (rule multiset_eqI)
  fix p show "count ?lhs p = count ?rhs p"
  proof (cases "prime p")
    case False
    thus ?thesis by (auto simp: count_prime_factorization)
  next
    case True
    have "finite (prime_factors x)" by simp
    hence "finite {p. p dvd x \<and> prime p}" using assms
      by (subst (asm) prime_factors_dvd) (auto simp: conj_commute)
    hence "finite {p. p dvd x \<and> prime p \<and> odd (multiplicity p x)}"
      by (rule finite_subset [rotated]) auto
    moreover have "odd (n :: nat) \<longleftrightarrow> n mod 2 = Suc 0" for n by presburger
    ultimately show ?thesis using assms
      by (cases "p dvd x"; cases "even (multiplicity p x)")
         (auto simp: count_prime_factorization prime_multiplicity_squarefree_part
                     in_prime_factors_iff not_dvd_imp_multiplicity_0)
  qed
qed

lemma squarefree_part_nat:
  "squarefree_part (n :: nat) = (\<Prod>{p \<in> prime_factors n. odd (multiplicity p n)})"
proof (cases "n = 0")
  case False
  hence "(\<Prod>{p \<in> prime_factors n. odd (multiplicity p n)}) =
          prod_mset (prime_factorization (squarefree_part n))"
    by (subst prime_factorization_squarefree_part) (auto simp: prod_unfold_prod_mset)
  also have "\<dots> = squarefree_part n"
    by (intro prod_mset_prime_factorization_nat Nat.gr0I) auto
  finally show ?thesis ..
qed auto

lemma prime_factorization_square_part:
  assumes "x \<noteq> 0"
  shows   "prime_factorization (square_part x) =
             (\<Sum>p \<in> prime_factors x. replicate_mset (multiplicity p x div 2) p)" (is "?lhs = ?rhs")
proof (rule multiset_eqI)
  fix p show "count ?lhs p = count ?rhs p"
  proof (cases "prime p \<and> p dvd x")
    case False
    thus ?thesis by (auto simp: count_prime_factorization count_sum
                                prime_multiplicity_square_part not_dvd_imp_multiplicity_0)
  next
    case True
    thus ?thesis using assms
      by (cases "p dvd x")
         (auto simp: count_prime_factorization prime_multiplicity_squarefree_part
                     in_prime_factors_iff count_sum prime_multiplicity_square_part)
  qed
qed

lemma prod_mset_sum: "prod_mset (sum f A) = (\<Prod>x\<in>A. prod_mset (f x))"
  by (induction A rule: infinite_finite_induct) auto

lemma square_part_nat:
  assumes "n > 0"
  shows   "square_part (n :: nat) = (\<Prod>p \<in> prime_factors n. p ^ (multiplicity p n div 2))"
proof -
  have "(\<Prod>p \<in> prime_factors n. p ^ (multiplicity p n div 2)) =
          prod_mset (prime_factorization (square_part n))" using assms
    by (subst prime_factorization_square_part) (auto simp: prod_unfold_prod_mset prod_mset_sum)
  also have "\<dots> = square_part n" using assms
    by (intro prod_mset_prime_factorization_nat Nat.gr0I) auto
  finally show ?thesis ..
qed

lemma square_squarefree_part_nat_code [code]:
  "square_squarefree_part_nat n = (if n = 0 then (0, 1)
     else let ps = prime_factorization n
          in  ((\<Prod>p\<in>set_mset ps. p ^ (count ps p div 2)),
                \<Prod>(Set.filter (\<lambda>p. odd (count ps p)) (set_mset ps))))"
  by (cases "n = 0")
     (auto simp: Let_def square_squarefree_part_nat_def squarefree_part_nat Set.filter_def
                 count_prime_factorization square_part_nat intro!: prod.cong)

lemma square_part_nat_code [code_unfold]:
  "square_part (n :: nat) = (if n = 0 then 0
     else let ps = prime_factorization n in  (\<Prod>p\<in>set_mset ps. p ^ (count ps p div 2)))"
  using square_squarefree_part_nat_code[of n]
  by (simp add: square_squarefree_part_nat_def Let_def split: if_splits)

lemma squarefree_part_nat_code [code_unfold]:
  "squarefree_part (n :: nat) = (if n = 0 then 1
     else let ps = prime_factorization n in (\<Prod>(Set.filter (\<lambda>p. odd (count ps p)) (set_mset ps))))"
  using square_squarefree_part_nat_code[of n]
  by (simp add: square_squarefree_part_nat_def Let_def split: if_splits)

lemma is_nth_power_mult_nth_powerD:
  assumes "is_nth_power n (a * b ^ n)" "b > 0" "n > 0"
  shows   "is_nth_power n (a::nat)"
proof -
  from assms obtain k where k: "k ^ n = a * b ^ n"
    by (auto elim: is_nth_powerE)
  with assms(2,3) have "b dvd k"
    by (metis dvd_triv_right pow_divides_pow_iff)
  then obtain l where "k = b * l"
    by auto
  with k have "a = l ^ n" using assms(2)
    by (simp add: power_mult_distrib)
  thus ?thesis by auto
qed

lemma (in pell) fund_sol_eq_fstI:
  assumes "nontriv_solution (x, y)"
  assumes "\<And>x' y'. nontriv_solution (x', y') \<Longrightarrow> x \<le> x'"
  shows   "fund_sol = (x, y)"
proof -
  have "x = fst fund_sol"
    using fund_sol_is_nontriv_solution assms(1) fund_sol_minimal''[of "(x, y)"]
    by (auto intro!: antisym assms(2)[of "fst fund_sol" "snd fund_sol"])
  moreover from this have "y = snd fund_sol"
    using assms(1) solutions_linorder_strict[of x y "fst fund_sol" "snd fund_sol"]
          fund_sol_is_nontriv_solution
    by (auto simp: nontriv_solution_imp_solution prod_eq_iff)
  ultimately show ?thesis by simp
qed

lemma (in pell) fund_sol_eqI_fst':
  assumes "nontriv_solution xy"
  assumes "\<And>x' y'. nontriv_solution (x', y') \<Longrightarrow> fst xy \<le> x'"
  shows   "fund_sol = xy"
  using fund_sol_eq_fstI[of "fst xy" "snd xy"] assms by simp

lemma (in pell) fund_sol_eq_sndI:
  assumes "nontriv_solution (x, y)"
  assumes "\<And>x' y'. nontriv_solution (x', y') \<Longrightarrow> y \<le> y'"
  shows   "fund_sol = (x, y)"
proof -
  have "y = snd fund_sol"
    using fund_sol_is_nontriv_solution assms(1) fund_sol_minimal''[of "(x, y)"]
    by (auto intro!: antisym assms(2)[of "fst fund_sol" "snd fund_sol"])
  moreover from this have "x = fst fund_sol"
    using assms(1) solutions_linorder_strict[of x y "fst fund_sol" "snd fund_sol"]
          fund_sol_is_nontriv_solution
    by (auto simp: nontriv_solution_imp_solution prod_eq_iff)
  ultimately show ?thesis by simp
qed

lemma (in pell) fund_sol_eqI_snd':
  assumes "nontriv_solution xy"
  assumes "\<And>x' y'. nontriv_solution (x', y') \<Longrightarrow> snd xy \<le> y'"
  shows   "fund_sol = xy"
  using fund_sol_eq_sndI[of "fst xy" "snd xy"] assms by simp

subsection \<open>The lifting mechanism\<close>

text \<open>
  The solutions of Pell's equations for parameters \<open>D\<close> and \<open>a\<^sup>2 D\<close> stand in correspondence to
  one another: every solution \<open>(x, y)\<close> for parameter \<open>D\<close> can be lowered to a solution \<open>(x, ay)\<close>
  for \<open>a\<^sup>2 D\<close>, and every solution of the form \<open>(x, ay)\<close> for parameter \<open>a\<^sup>2 D\<close> can be lifted to a
  solution \<open>(x, y)\<close> for parameter \<open>D\<close>.
\<close>

locale pell_lift = pell +
  fixes a D' :: nat
  assumes nz: "a > 0"
  defines "D' \<equiv> D * a\<^sup>2"
begin

lemma nonsquare_D': "\<not>is_square D'"
  using nonsquare_D is_nth_power_mult_nth_powerD[of 2 D a] nz by (auto simp: D'_def)

definition lift_solution :: "nat \<times> nat \<Rightarrow> nat \<times> nat" where
  "lift_solution = (\<lambda>(x, y). (x, y div a))"

definition lower_solution :: "nat \<times> nat \<Rightarrow> nat \<times> nat" where
  "lower_solution = (\<lambda>(x, y). (x, y * a))"

definition liftable_solution :: "nat \<times> nat \<Rightarrow> bool" where
  "liftable_solution = (\<lambda>(x, y). a dvd y)"

sublocale lift: pell D'
  by unfold_locales (fact nonsquare_D')

lemma lift_solution_iff: "lift.solution xy \<longleftrightarrow> solution (lower_solution xy)"
  unfolding solution_def lift.solution_def
  by (auto simp: lower_solution_def D'_def case_prod_unfold power_mult_distrib)

lemma lift_solution:
  assumes "solution xy" "liftable_solution xy"
  shows   "lift.solution (lift_solution xy)"
  using assms unfolding solution_def lift.solution_def
  by (auto simp: liftable_solution_def lift_solution_def D'_def case_prod_unfold power_mult_distrib
           elim!: dvdE)

text \<open>
  In particular, the fundamental solution for \<open>a\<^sup>2 D\<close> is the smallest liftable solution for \<open>D\<close>:
\<close>
lemma lift_fund_sol:
  assumes "\<And>n. 0 < n \<Longrightarrow> n < m \<Longrightarrow> \<not>liftable_solution (nth_solution n)"
  assumes "liftable_solution (nth_solution m)" "m > 0"
  shows   "lift.fund_sol = lift_solution (nth_solution m)"
proof (rule lift.fund_sol_eqI_fst')
  from assms have "nontriv_solution (nth_solution m)"
    by (intro nth_solution_sound')
  hence "lift_solution (nth_solution m) \<noteq> (1, 0)" using nz assms(2)
    by (auto simp: lift_solution_def case_prod_unfold nontriv_solution_def liftable_solution_def)
  with assms show "lift.nontriv_solution (lift_solution (nth_solution m))"
    by (auto simp: lift.nontriv_solution_altdef intro: lift_solution)
next
  fix x' y' :: nat
  assume *: "lift.nontriv_solution (x', y')"
  hence nz': "x' \<noteq> 1" using nonsquare_D'
    by (auto simp: lift.nontriv_solution_altdef lift.solution_def)
  from * have "solution (lower_solution (x', y'))"
    by (simp add: lift_solution_iff lift.nontriv_solution_altdef)
  hence "lower_solution (x', y') \<in> range nth_solution" by (rule nth_solution_complete)
  then obtain n where n: "nth_solution n = lower_solution (x', y')" by auto
  with nz' have "n > 0" by (auto intro!: Nat.gr0I simp: nth_solution_def lower_solution_def)
  with n have "liftable_solution (nth_solution n)"
    by (auto simp: liftable_solution_def lower_solution_def)
  with \<open>n > 0\<close> and assms(1)[of n] have "n \<ge> m" by (cases "n \<ge> m") auto
  hence "fst (nth_solution m) \<le> fst (nth_solution n)"
    using strict_mono_less_eq[OF strict_mono_nth_solution(1)] by simp
  thus "fst (lift_solution (nth_solution m)) \<le> x'"
    by (simp add: lift_solution_def lower_solution_def n case_prod_unfold)
qed

end

subsection \<open>Accelerated computation of the fundamental solution for non-squarefree inputs\<close>

text \<open>
  Solving Pell's equation for some \<open>D\<close> of the form \<open>a\<^sup>2 D'\<close> can be done by solving
  it for \<open>D'\<close> and then lifting the solution. Thus, if \<open>D\<close> is not squarefree, we can compute
  its squarefree decomposition \<open>a\<^sup>2 D'\<close> with \<open>D'\<close> squarefree and thus speed up the computation
  (since \<open>D'\<close> is smaller than \<open>D\<close>).

  The squarefree decomposition can only be computed (according to current knowledge in mathematics)
  through the prime decomposition. However, when given how big the solutions are for even
  moderate values of \<open>D\<close>, it is usually worth doing it if \<open>D\<close> is not squarefree.
\<close>

lemma squarefree_part_of_square [simp]:
  assumes "is_square (x :: 'a :: {factorial_semiring, normalization_semidom_multiplicative})"
  assumes "x \<noteq> 0"
  shows   "squarefree_part x = unit_factor x"
proof -
  from assms obtain y where [simp]: "x = y ^ 2"
    by (auto simp: is_nth_power_def)
  have "unit_factor x * normalize x = squarefree_part x * square_part x ^ 2"
    by (subst squarefree_decompose [symmetric]) auto
  also have "\<dots> = squarefree_part x * normalize x"
    by (simp add: square_part_even_power normalize_power)
  finally show ?thesis using assms
    by (subst (asm) mult_cancel_right) auto
qed

lemma squarefree_part_1_imp_square:
  assumes "squarefree_part x = 1"
  shows   "is_square x"
proof -
  have "is_square (square_part x ^ 2)"
    by auto
  also have "square_part x ^ 2 = squarefree_part x * square_part x ^ 2"
    using assms by simp
  also have "\<dots> = x"
    by (rule squarefree_decompose [symmetric])
  finally show ?thesis .
qed

definition find_fund_sol_fast where
  "find_fund_sol_fast D =
     (let (a, D') = square_squarefree_part_nat D
      in
        if D' = 0 \<or> D' = 1 then (0, 0)
        else if a = 1 then pell.fund_sol D
        else map_prod id (\<lambda>y. y div a)
               (shd (sdrop_while (\<lambda>(_, y). y = 0 \<or> \<not>a dvd y) (pell_solutions D'))))"

lemma find_fund_sol_fast: "find_fund_sol D = find_fund_sol_fast D"
proof (cases "is_square D \<or> square_part D = 1")
  case True
  thus ?thesis
    using squarefree_part_1_imp_square[of D]
    by (cases "D = 0")
       (auto simp: find_fund_sol_correct find_fund_sol_fast_def
                    square_squarefree_part_nat_def square_test_correct unit_factor_nat_def)
next
  case False
  define D' a where "D' = squarefree_part D" and "a = square_part D"
  have "D > 0"
    using False by (intro Nat.gr0I) auto
  have "a > 0"
    using \<open>D > 0\<close> by (intro Nat.gr0I) (auto simp: a_def)
  moreover have "\<not>is_square D'"
    unfolding D'_def
    by (metis False is_nth_power_mult is_nth_power_nth_power squarefree_decompose)
  ultimately interpret lift: pell_lift D' a D
    using False \<open>D > 0\<close>
    by unfold_locales (auto simp: D'_def a_def squarefree_decompose [symmetric])

  define i where "i = (LEAST i. case lift.nth_solution i of (_, y) \<Rightarrow> y > 0 \<and> a dvd y)"
  have ex: "\<exists>i. case lift.nth_solution i of (_, y) \<Rightarrow> y > 0 \<and> a dvd y"
  proof -
    define sol where "sol = lift.lift.fund_sol"
    have is_sol: "lift.solution (lift.lower_solution sol)"
      unfolding sol_def using lift.lift.fund_sol_is_nontriv_solution lift.lift_solution_iff by blast
    then obtain j where j: "lift.lower_solution sol = lift.nth_solution j"
      using lift.solution_iff_nth_solution by blast
    have "snd (lift.lower_solution sol) > 0"
    proof (rule Nat.gr0I)
      assume *: "snd (lift.lower_solution sol) = 0"
      have "lift.solution (fst (lift.lower_solution sol), snd (lift.lower_solution sol))"
        using is_sol by simp
      hence "fst (lift.lower_solution sol) = 1"
        by (subst (asm) *) simp
      with * have "lift.lower_solution sol = (1, 0)"
        by (cases "lift.lower_solution sol") auto
      hence "fst sol = 1"
        unfolding lift.lower_solution_def by (auto simp: lift.lower_solution_def case_prod_unfold)
      thus False
        unfolding sol_def
        using lift.lift.fund_sol_is_nontriv_solution \<open>D > 0\<close>
        by (auto simp: lift.lift.nontriv_solution_def)
    qed
    moreover have "a dvd snd (lift.lower_solution sol)"
      by (auto simp: lift.lower_solution_def case_prod_unfold)
    ultimately show ?thesis
      using j by (auto simp: case_prod_unfold)
  qed

  define sol where "sol = lift.nth_solution i"
  have sol: "snd sol > 0" "a dvd snd sol"
    using LeastI_ex[OF ex] by (simp_all add: sol_def i_def case_prod_unfold)
  have "i > 0"
    using sol by (intro Nat.gr0I) (auto simp: sol_def lift.nth_solution_def)

  have "find_fund_sol_fast D = map_prod id (\<lambda>y. y div a)
          (shd (sdrop_while (\<lambda>(_, y). y = 0 \<or> \<not>a dvd y) (pell_solutions D')))"
    unfolding D'_def a_def find_fund_sol_fast_def using False squarefree_part_1_imp_square[of D]
    by (auto simp: square_squarefree_part_nat_def)
  also have "sdrop_while (\<lambda>(_, y). y = 0 \<or> \<not>a dvd y) (pell_solutions D') =
             sdrop_while (Not \<circ> (\<lambda>(_, y). y > 0 \<and> a dvd y)) (pell_solutions D')"
    by (simp add: o_def case_prod_unfold)
  also have "\<dots> = sdrop i (pell_solutions D')"
    using ex by (subst sdrop_while_sdrop_LEAST) (simp_all add: lift.snth_pell_solutions i_def)
  also have "shd \<dots> = sol"
    by (simp add: lift.snth_pell_solutions sol_def)
  finally have eq: "find_fund_sol_fast D = map_prod id (\<lambda>y. y div a) sol" .

  have "lift.lift.fund_sol = lift.lift_solution sol"
    unfolding sol_def
  proof (rule lift.lift_fund_sol)
    show "i > 0" by fact
    show "lift.liftable_solution (lift.nth_solution i)"
      using sol by (simp add: sol_def lift.liftable_solution_def case_prod_unfold)
  next
    fix j :: nat assume j: "j > 0" "j < i"
    show "\<not>lift.liftable_solution (lift.nth_solution j)"
    proof
      assume liftable: "lift.liftable_solution (lift.nth_solution j)"
      have "snd (lift.nth_solution j) > 0"
        using \<open>j > 0\<close> by (metis gr0I lift.nontriv_solution_altdef lift.nth_solution_sound'
                                lift.solution_0_snd_nat_iff prod.collapse)
      hence "case lift.nth_solution j of (_, y) \<Rightarrow> y > 0 \<and> a dvd y"
        using \<open>j > 0\<close> liftable by (auto simp: lift.liftable_solution_def)
      hence "i \<le> j"
        unfolding i_def by (rule Least_le)
      thus False using \<open>j < i\<close> by simp
    qed
  qed
  also have "\<dots> = find_fund_sol_fast D"
    by (simp add: eq lift.lift_solution_def case_prod_unfold map_prod_def)
  finally show ?thesis
    using \<open>D > 0\<close> False by (simp add: find_fund_sol_correct)
qed

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
License: LGPL
*)

theory Simple_Algorithm
  imports
    Linear_Diophantine_Equations
    Minimize_Wrt
begin

(*TODO: move?*)

subsection \<open>Reverse-Lexicographic Enumeration of Potential Minimal Solutions\<close>

fun rlex2 :: "(nat list \<times> nat list) \<Rightarrow> (nat list \<times> nat list) \<Rightarrow> bool"  (infix "<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2" 50)
  where
    "(xs, ys) <\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2 (us, vs) \<longleftrightarrow> xs @ ys <\<^sub>r\<^sub>l\<^sub>e\<^sub>x us @ vs"

lemma rlex2_irrefl:
  "\<not> x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2 x"
  by (cases x) (auto simp: rlex_irrefl)

text \<open>Generate all lists (of natural numbers) of length \<open>n\<close> with elements bounded by \<open>B\<close>.\<close>
fun gen :: "nat \<Rightarrow> nat \<Rightarrow> nat list list"
  where
    "gen B 0 = [[]]"
  | "gen B (Suc n) = [x#xs . xs \<leftarrow> gen B n, x \<leftarrow> [0 ..< B + 1]]"

definition "generate A B m n = tl [(x, y) . y \<leftarrow> gen B n, x \<leftarrow> gen A m]"

definition "check a b = filter (\<lambda>(x, y). a \<bullet> x = b \<bullet> y)"

definition "minimize = minimize_wrt (\<lambda>(x, y) (u, v). \<not> x @ y <\<^sub>v u @ v)"

definition "solutions a b =
  (let A = Max (set b); B = Max (set a); m = length a; n = length b
  in minimize (check a b (generate A B m n)))"

lemma set_gen: "set (gen B n) = {xs. length xs = n \<and> (\<forall>i<n. xs ! i \<le> B)}" (is "_ = ?A n")
proof (induct n)
  case [simp]: (Suc n)
  { fix xs assume "xs \<in> ?A (Suc n)"
    then have "xs \<in> set (gen B (Suc n))"
      by (cases xs) (force simp: All_less_Suc2)+ }
  then show ?case by (auto simp: less_Suc_eq_0_disj)
qed simp

abbreviation "gen2 A B m n \<equiv> [(x, y) . y \<leftarrow> gen B n, x \<leftarrow> gen A m]"

lemma sorted_wrt_gen:
  "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x) (gen B n)"
by (induction n)
   (auto simp: rlex_Cons sorted_wrt_append sorted_wrt_map rlex_irrefl
    intro!: sorted_wrt_concat_map [where h = id, simplified])

lemma sorted_wrt_gen2: "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (gen2 A B m n)"
  by (intro sorted_wrt_concat_map_map [where Q = "(<\<^sub>r\<^sub>l\<^sub>e\<^sub>x)"] sorted_wrt_gen)
    (auto simp: set_gen rlex_def intro:  lex_append_leftI lex_append_rightI)

lemma gen_ne [simp]: "gen B n \<noteq> []" by (induct n) auto

lemma gen2_ne: "gen2 A B m n \<noteq> []" by auto

lemma sorted_wrt_generate: "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (generate A B m n)"
  by (auto simp: generate_def intro: sorted_wrt_tl sorted_wrt_gen2)

abbreviation "check_generate a b \<equiv> check a b (generate (Max (set b)) (Max (set a)) (length a) (length b))"

lemma sorted_wrt_check_generate: "sorted_wrt (<\<^sub>r\<^sub>l\<^sub>e\<^sub>x\<^sub>2) (check_generate a b)"
  by (auto simp: check_def intro: sorted_wrt_filter sorted_wrt_generate)

lemma in_tl_gen2: "x \<in> set (tl (gen2 A B m n)) \<Longrightarrow> x \<in> set (gen2 A B m n)"
  by (rule list.set_sel) simp

lemma gen_nth0 [simp]: "gen B n ! 0 = zeroes n"
  by (induct n) (auto simp: nth_append concat_map_nth0)

lemma gen2_nth0 [simp]:
  "gen2 A B m n ! 0 = (zeroes m, zeroes n)"
  by (auto simp: concat_map_nth0)

lemma set_gen2:
  "set (gen2 A B m n) = {(x, y). length x = m \<and> length y = n \<and> (\<forall>i<m. x ! i \<le> A) \<and> (\<forall>j<n. y ! j \<le> B)}"
  by (auto simp: set_gen)

lemma gen2_unique:
  assumes "i < j"
    and "j < length (gen2 A B m n)"
  shows "gen2 A B m n ! i \<noteq> gen2 A B m n ! j"
  using sorted_wrt_nth_less [OF sorted_wrt_gen2 assms]
  by (auto simp: rlex2_irrefl)

lemma zeroes_ni_tl_gen2:
  "(zeroes m, zeroes n) \<notin> set (tl (gen2 A B m n))"
proof -
  have "gen2 A B m n ! 0 = (zeroes m, zeroes n)" by (auto simp: generate_def)
  with gen2_unique[of 0 _ A m B n] show ?thesis
    by (metis (no_types, lifting) Suc_eq_plus1 in_set_conv_nth length_tl less_diff_conv nth_tl zero_less_Suc)
qed

lemma set_generate:
  "set (generate A B m n) = {(x, y). (x, y) \<noteq> (zeroes m, zeroes n) \<and> (x, y) \<in> set (gen2 A B m n)}"
proof
  show "set (generate A B m n)
    \<subseteq> {(x, y).(x, y) \<noteq> (zeroes m, zeroes n) \<and> (x, y) \<in> set (gen2 A B m n)}"
    using in_tl_gen2 and mem_Collect_eq and zeroes_ni_tl_gen2 by (auto simp: generate_def)
next
  have "(zeroes m, zeroes n) = hd (gen2 A B m n)"
    by (simp add: hd_conv_nth)
  moreover have "set (gen2 A B m n) = set (generate A B m n) \<union> {(zeroes m, zeroes n)}"
    by (metis Un_empty_right generate_def Un_insert_right gen2_ne calculation list.exhaust_sel list.simps(15))
  ultimately show " {(x, y). (x, y) \<noteq> (zeroes m, zeroes n) \<and> (x, y) \<in> set (gen2 A B m n)}
    \<subseteq> set (generate A B m n)"
    by blast
qed

lemma set_check_generate:
  "set (check_generate a b) = {(x, y).
    (x, y) \<noteq> (zeroes (length a), zeroes (length b)) \<and>
    length x = length a \<and> length y = length b \<and> a \<bullet> x = b \<bullet> y \<and>
    (\<forall>i<length a. x ! i \<le> Max (set b)) \<and> (\<forall>j<length b. y ! j \<le> Max (set a))}"
  unfolding check_def and set_filter and set_generate and set_gen2 by auto

lemma set_minimize_check_generate:
  "set (minimize (check_generate a b)) =
    {(x, y)\<in>set (check_generate a b). \<not> (\<exists>(u, v)\<in>set (check_generate a b). u @ v <\<^sub>v x @ y)}"
  unfolding minimize_def
  by (subst set_minimize_wrt [OF _ sorted_wrt_check_generate]) (auto dest: rlex_not_sym less_imp_rlex)

lemma set_solutions_iff:
  "set (solutions a b) =
    {(x, y) \<in> set (check_generate a b). \<not> (\<exists>(u, v)\<in>set (check_generate a b). u @ v <\<^sub>v x @ y)}"
  by (auto simp: solutions_def set_minimize_check_generate)

subsubsection \<open>Completeness: every minimal solution is generated by \<open>solutions\<close>\<close>

lemma (in hlde) solutions_complete:
  "Minimal_Solutions \<subseteq> set (solutions a b)"
proof (rule subrelI)
  let ?A = "Max (set b)" and ?B = "Max (set a)"
  fix x y assume min: "(x, y) \<in> Minimal_Solutions"
  then have "(x, y) \<in> set (check a b (generate ?A ?B m n))"
    by (auto simp: Minimal_Solutions_alt_def set_check_generate less_eq_def in_Solutions_iff)
  moreover have "\<forall>(u, v) \<in> set (check a b (generate ?A ?B m n)). \<not> u @ v <\<^sub>v x @ y"
    using min and no0
    by (auto simp: check_def set_generate neq_0_iff' set_gen nonzero_iff dest!: Minimal_Solutions_min)
  ultimately show "(x, y) \<in> set (solutions a b)" by (auto simp: set_solutions_iff)
qed

subsubsection \<open>Correctness: \<open>solutions\<close> generates only minimal solutions.\<close>

lemma (in hlde) solutions_sound:
  "set (solutions a b) \<subseteq> Minimal_Solutions"
proof (rule subrelI)
  fix x y assume sol: "(x, y) \<in> set (solutions a b)"
  show "(x, y) \<in> Minimal_Solutions"
  proof (rule Minimal_SolutionsI')
    show *: "(x, y) \<in> Solutions"
      using sol by (auto simp: set_solutions_iff in_Solutions_iff check_def set_generate set_gen)
    show "nonzero x"
      using sol and nonzero_iff and replicate_eqI and nonzero_Solutions_iff [OF *]
      by (fastforce simp: solutions_def minimize_def check_def set_generate set_gen dest!: minimize_wrtD)
    show "\<not> (\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y)"
    proof
      have min_cg: "(x, y) \<in> set (minimize (check_generate a b))"
        using sol by (auto simp: solutions_def)
      note * = in_minimize_wrt_False [OF _ sorted_wrt_check_generate min_cg [unfolded minimize_def]]

      assume "\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y"
      then obtain u and v where "(u, v) \<in> Minimal_Solutions" and less: "u @ v <\<^sub>v x @ y" by blast
      then have "(u, v) \<in> set (solutions a b)" by (auto intro: solutions_complete [THEN subsetD])
      then have "(u, v) \<in> set (check_generate a b)"
        by (auto simp: solutions_def minimize_def dest: minimize_wrtD)
      from * [OF _ _ _ this] and less show False
        using less_imp_rlex and rlex_not_sym by force
    qed
  qed
qed

lemma (in hlde) set_solutions [simp]: "set (solutions a b) = Minimal_Solutions"
  using solutions_sound and solutions_complete by blast

end


theory List_Auxiliaries
  imports Main Graph_Theory.Stuff "HOL-Library.Sublist"
begin

section\<open>Auxiliaries for Lists\<close>

subsection\<open>General Proofs\<close>

lemma in_set_implies_is_nth:
  assumes "x \<in> set L"
  shows "\<exists>i. x = L!i \<and> i<length L"
  using assms by (metis in_set_conv_nth)

lemma indices_length_set_ls2:
  assumes "l = (ls1@ls2)!i" "i\<ge> length ls1" "i < length (ls1@ls2)"
  shows "l \<in> set ls2"
  using assms
  by (induction "ls1@ls2"; simp)
     (metis add_less_imp_less_left le_iff_add nth_append_length_plus nth_mem)

lemma indices_length_set_ls2_only_append:
  assumes "l = (l1#ls2)!i" "i \<ge> 1" "i< length (l1#ls2)"
  shows "l \<in> set ls2"
  using assms indices_length_set_ls2 by auto

lemma distinct_same_indices:
  assumes "distinct L" "L!i = L!j" "i<length L" "j<length L"
  shows "i = j"
  using assms by(induction L)  (auto simp add: nth_eq_iff_index_eq)

lemma length_1_set_L:
  assumes "length L = 1" "l \<in> set L"
  shows "L = [l]"
  using assms
  by (metis append_butlast_last_id butlast.simps(2) diff_is_0_eq'
      in_set_conv_nth last.simps last_conv_nth le_numeral_extra(4) length_0_conv
      length_butlast less_one list.distinct(1) zero_neq_one)

lemma last_in_set_tl:
  assumes "l = last L" "length L \<ge> 2"
  shows "l \<in> set (tl L)"
  using assms by(induction L)(auto)

lemma card_list_subset:
  assumes "s \<subseteq> set L"
  shows "card s \<le> card (set L)"
  using assms finite_subset card_mono by blast

lemma length_2_hd_last:
  assumes "length L = 2"
  shows "L = [hd L, last L]"
  using assms
  apply(induction L)
   apply(auto)
  by (metis append_butlast_last_id append_eq_append_conv append_self_conv2 length_Cons list.size(3))

lemma length_2_exits:
  assumes "length L = 2"
  shows "\<exists>l1 l2. L = [l1, l2]"
  using assms by(induction L; simp) (metis Suc_length_conv length_0_conv)

lemma length_geq_2_tt_not_empty:
  assumes "length C \<ge> 2"
  shows "tl C \<noteq> []"
  using assms  by(induction C) (auto)

lemma hd_last_eq_in_tl:
  assumes "hd xs = last xs" "x \<in> set xs" "length xs > 1"
  shows "x \<in> set (tl xs)"
  using assms by(induction xs)(auto split: if_split_asm)

subsection\<open>Sublist\<close>

lemma sublist_implies_in_set:
  assumes "sublist [v1, v2] C"
  shows "v1 \<in> set C" "v2 \<in> set C"
  using assms by(auto simp add: sublist_def)

lemma sublist_implies_in_set_a:
  assumes "sublist [v1, v2] C" "distinct C"
  shows "v1 \<noteq> v2"
  using assms by (auto simp add: sublist_def)

lemma sublist3_hd_lists:
  assumes "distinct L" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v1 = l1"
  shows "v2 = hd (ls1 @ ls2)"
  using assms unfolding sublist_def
  by(induction L; simp)
    (metis assms(1, 2) distinct_append hd_append hd_in_set list.sel(1, 3)
      not_distinct_conv_prefix self_append_conv2)

lemma sublist_set_ls2_1:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls2"
  shows "v2 \<in> set ls2"
  using assms
proof(induction L arbitrary: ls2 ls1)
  case Nil
  then show ?case by auto
next
  case (Cons a L)
  then show ?case proof(cases "v1 = a")
    case True
    then have "ls1 = []"
      using assms Cons
      by (metis (no_types, hide_lams) Nil_is_append_conv append.assoc append_Cons_eq_iff
          append_self_conv2 distinct.simps(2) in_set_conv_decomp list.distinct(1) split_list)
    then have "a#L = ls2"
      using Cons
      by auto
    then have "v2 \<in> set ls2"
      using Cons sublist_implies_in_set(2)
      by metis
    then show ?thesis .
  next
    case False
    then obtain p1 p2 where p_def: "p1@ [v1, v2] @ p2 =a#L"
      using Cons unfolding sublist_def by auto
    then have L_def_2: "L = tl( p1@ [v1, v2] @ p2)"
      by auto
    have "p1 \<noteq> []"
      using False Cons p_def
      by (metis append_self_conv2 hd_append2 list.sel(1) list.sel(2) list.sel(3) not_Cons_self2)
    then have "L = (tl p1) @ [v1, v2] @ p2"
      using L_def_2
      by simp
    then show ?thesis
      using Cons sublist_def
      by (metis L_def_2 append_self_conv2 sublist_implies_in_set(2) distinct_tl p_def tl_append2)
  qed
qed

lemma sublist_set_ls2_2:
  assumes "distinct L" "L = l1 # ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls2"
  shows "v2 \<in> set ls2"
  using assms sublist_set_ls2_1 by (metis Cons_eq_appendI)

lemma sublist_set_ls2_3:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls2"
  shows "sublist [v1, v2] ls2"
  using assms
proof(induction L arbitrary: ls2 ls1)
  case Nil
  then show ?case by auto
next
  case (Cons a L)
  then show ?case
  proof(cases "v1 = a")
    case True
    then have "ls1 = []"
      using assms Cons
      by (metis (no_types, hide_lams) Nil_is_append_conv append.assoc
          append_Cons_eq_iff append_self_conv2 distinct.simps(2) in_set_conv_decomp
          list.distinct(1) split_list)
    then have "a#L = ls2"
      using Cons
      by auto
    then show ?thesis
      using Cons
      by blast
  next
    case False
    then obtain p1 p2 where p_def: "p1@ [v1, v2] @ p2 =a#L"
      using Cons unfolding sublist_def by auto
    then have L_def_2: "L = tl( p1@ [v1, v2] @ p2)"
      by auto
    have "p1 \<noteq> []"
      using False Cons p_def
      by (metis append_self_conv2 hd_append2 list.sel(1) list.sel(2) list.sel(3) not_Cons_self2)
    then have "L = (tl p1) @[v1, v2] @ p2"
      using L_def_2
      by simp
    then show ?thesis
      using Cons sublist_def
      by (metis L_def_2 append_self_conv2 distinct_tl p_def tl_append2)
  qed
qed

lemma sublist_set_ls2_4:
  assumes "distinct L" "L = l1 # ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls2" "ls3 = l1 # ls1"
  shows "sublist [v1, v2] ls2"
proof -
  have 1: "L = ls3 @ ls2"
    using assms
    by simp
  then have 1: "sublist [v1, v2] ls2"
    using sublist_set_ls2_3 assms 1 by metis
  then show ?thesis
    by (auto simp add: sublist_def)
qed

lemma sublist_set_ls2:
  assumes "distinct L" "L = l1 # ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls2"
  shows  "sublist [v1, v2] ls2"
  using assms sublist_set_ls2_4 by metis

lemma sublist_set_ls1_1:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls1" "v1 \<noteq> last ls1"
  shows "v2 \<in> set ls1"
  using assms
proof(induction L arbitrary: ls1 ls2 )
  case Nil
  then show ?case
    by auto
next
  case (Cons a L)
  then show ?case
  proof(cases "v1 = a")
    case True
    then have "v1 = hd ls1"
      using Cons
      by (metis distinct.simps(2) distinct_singleton hd_append2 list.sel(1))
    with Cons have "v1 \<noteq> last ls1"
      by auto
    then have "tl ls1 \<noteq> []"
      using \<open>v1 = hd ls1\<close>
      by (metis Cons.prems(4) distinct.simps(2) distinct_singleton last_ConsL list.collapse)
    obtain p1 p2 where "p1@ [v1, v2] @ p2 = (a#L)"
      using Cons assms sublist_def by metis
    then have "p1 = []"
      using Cons \<open>v1 = a\<close> sublist_def
      by (metis sublist_implies_in_set(1) distinct.simps(2) list.sel(3) tl_append2)
    then have "v2 = hd L"
      using Cons \<open>p1 @ [v1, v2] @ p2 = a # L\<close>
      by (metis Cons_eq_appendI True eq_Nil_appendI list.sel(1) list.sel(3))
    then have "v2 = hd (tl ls1)"
      using Cons \<open>tl ls1 \<noteq> []\<close>  \<open>p1 = []\<close> by (metis Nil_tl hd_append2 list.sel(3) tl_append2)
    then show ?thesis
      by (simp add: \<open>tl ls1 \<noteq> []\<close> list_set_tl)
  next
    case False
    then obtain p1 p2 where p_def: "p1@ [v1, v2] @ p2 =a#L"
      using Cons
      by (auto simp add: sublist_def)
    then have L_def_2: "L = tl( p1@ [v1, v2] @ p2)"
      by auto
    have "p1 \<noteq> []"
      using False Cons p_def
      by (metis hd_append2 list.sel(1) list.sel(2) list.sel(3) not_Cons_self2 self_append_conv2)
    then have "L = (tl p1) @[v1, v2] @ p2"
      using L_def_2
      by simp
    then have 1: "\<exists>p1 p2. p1@ [v1, v2] @ p2 = L"
      by auto
    have 2: "distinct L"
      using Cons
      by (meson distinct.simps(2))
    have 3: "L = tl ls1 @ ls2"
      using Cons
      by (metis distinct.simps(2) distinct_singleton list.sel(3) tl_append2)
    have 4: "v1 \<in> set (tl ls1)"
      using Cons False
      by (metis hd_Cons_tl hd_append2 list.sel(1) set_ConsD tl_Nil)
    have 5: "v1 \<noteq> last (tl ls1)"
      using Cons
      by (metis "4" last_tl list.set_cases neq_Nil_conv)
    then show ?thesis
      using Cons 1 2 3 4 5 list_set_tl sublist_def
      by metis
  qed
qed

lemma sublist_cons_impl_sublist_list:
  assumes "sublist (a#as) (c#cs)" "a \<noteq> c"
  shows "sublist (a#as) cs"
  by (meson Cons_prefix_Cons assms sublist_Cons_right)

lemma sublist_cons_impl_sublist:
  assumes "sublist [a, b] (c#cs)" "a \<noteq> c"
  shows "sublist [a, b] cs"
  using assms sublist_cons_impl_sublist_list by metis

lemma sublist_second_not_hd:
  assumes "distinct L" "sublist [v1, v2] L"
  shows "v2 \<noteq> hd L"
  using assms
proof(induction L)
  case Nil
  then show ?case
    by (auto simp add: sublist_def)
next
  case (Cons a L)
  then have 1: "v1 \<noteq> v2"
    by (meson sublist_implies_in_set_a)
  then show ?case
  proof(cases "v1 = hd (a#L)")
    case True
    then show ?thesis
      using 1 by auto
  next
    case False
    then have "sublist [v1, v2] L"
      using Cons sublist_cons_impl_sublist by (metis list.sel(1))
    then show ?thesis
      using Cons sublist_implies_in_set(2) by force
  qed
qed

lemma sublist_set_ls1_2:
  assumes "distinct L" "L = l1 # ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls1"
    "v1 \<noteq> last ls1" "ls3 = l1 # ls1"
  shows "v2 \<in> set ls1"
  using assms
  by (metis distinct.simps(2) hd_append2 length_greater_0_conv length_pos_if_in_set
      list.set_sel(1) sublist3_hd_lists sublist_cons_impl_sublist sublist_set_ls1_1)

lemma sublist_set_ls1_3:
  assumes "distinct L" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls1" "v1 \<noteq> last ls1"
  shows "v2 \<in> set ls1"
  using assms sublist_set_ls1_2 sublist_def by fast

lemma sublist_set_ls1_4:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls1" "v1 \<noteq> last ls1"
  shows "sublist [v1, v2] ls1"
  using assms
  apply (simp add: sublist_append)
  apply safe
  subgoal sublist_ls2
    by (metis disjoint_iff_not_equal sublist_implies_in_set(1))
  subgoal for xs1 xs2
    by (auto 4 3 simp add: Cons_eq_append_conv suffix_def intro: sublist_ls2)
  done

lemma sublist_set_ls1:
  assumes "distinct L" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v1 \<in> set ls1" "v1 \<noteq> last ls1"
  shows "sublist [v1, v2] ls1"
  by (metis Un_iff assms distinct.simps(2) set_append sublist_cons_impl_sublist sublist_set_ls1_4)

lemma sublist_set_last_ls1_2:
  assumes "x = hd L" "x = last ls1" "L = ls1 @ ls2" "x \<in> set ls1" "distinct L"
  shows "ls1 = [x]"
  using assms
  by (induction L arbitrary: ls1 ls2; simp)
     (metis distinct.simps(2) hd_append2 hd_in_set in_set_conv_decomp_first
       last_in_set last_tl list.sel(3) self_append_conv2)

lemma sublist_set_last_ls1_1:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 = last ls1" "v1 \<in> set ls1"
  shows "v2 = hd ls2"
  using assms
proof(induction L arbitrary: ls1 ls2)
  case Nil
  then show ?case
    by auto
next
  case (Cons a L)
  then show ?case
  proof(cases "v1 = a")
    case True
    then have "v1 = hd (a#L)"
      by simp
    then have "ls1 = [a]"
      using assms Cons sublist_set_last_ls1_2 True
      by fast
    then have "L = ls2"
      using Cons
      by auto
    then show ?thesis
      using Cons \<open>ls1 = [a]\<close>
      by (metis (mono_tags, lifting) Cons_eq_appendI True sublist3_hd_lists  list.sel(3))
  next
    case False
    then obtain p1 p2 where p_def: "p1@ [v1, v2] @ p2 =a#L"
      using Cons
      by (auto simp add: sublist_def)
    then have L_def_2: "L = tl( p1@ [v1, v2] @ p2)"
      by auto
    have "p1 \<noteq> []"
      using False Cons p_def
      by (metis append_self_conv2 hd_append2 list.sel(1) list.sel(2) list.sel(3) not_Cons_self2)
    then have L_exists: "L = (tl p1) @[v1, v2] @ p2"
      using L_def_2
      by simp
    have "ls1 \<noteq> []"
      using False Cons
      by auto
    then have "L = tl ls1 @ ls2"
      using Cons
      by (metis list.sel(3) tl_append2)
    then show ?thesis
      using Cons L_exists sublist_def False
      by (metis distinct.simps(2) distinct_singleton hd_append2
          last_tl list.collapse list.sel(1) set_ConsD)
  qed
qed

lemma sublist_set_last_ls1_1_1:
  assumes "distinct L" "L = ls1 @ ls2" "sublist [v1, v2] L" "v1 = last ls1" "v1 \<in> set ls1"
  shows "v2 \<in> set ls2"
  using assms
  by (metis append_Nil2 append_butlast_last_id list.set_intros(1) list.set_sel(1) set_ConsD
        sublist_implies_in_set_a sublist_set_last_ls1_1 sublist_set_ls2_1)

lemma sublist_set_last_ls1_3:
  assumes "distinct L" "L = l1#ls1 @ ls2" "sublist [v1, v2] L"
    "v1 = last ls1" "v1 \<in> set ls1" "ls3 = l1 # ls1"
  shows "v2 = hd ls2"
  using assms
  by (metis Cons_eq_appendI distinct.simps(2) last.simps list.set_intros(1)
      sublist_cons_impl_sublist_list sublist_set_last_ls1_1)

lemma sublist_set_last_ls1:
  assumes "distinct L" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v1 = last ls1" "v1 \<in> set ls1"
  shows "v2 = hd ls2"
  using assms sublist_set_last_ls1_3 by fast

lemma sublist_set_noteq_l1:
  assumes "distinct (tl L)" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v1 \<noteq> l1"
  shows "sublist [v1, v2] (ls1@ls2)"
  using assms unfolding sublist_def
  by (induction L; simp) (metis append_self_conv2 assms(2,4) list.inject list.sel(3) tl_append2)

lemma sublist_set_v2_noteq_hd_lists:
  assumes "distinct (tl L)" "L = l1#ls1 @ ls2" "sublist [v1, v2] L" "v2 \<noteq> hd (ls1@ls2)"
  shows "sublist [v1, v2] (ls1@ls2)"
  using assms unfolding sublist_def
  by(induction L; simp) (metis append_self_conv2 list.sel(1) list.sel(3) tl_append2)

lemma sublist_v1_in_subsets:
  assumes "sublist [v1, v2] L" "L = l1@l2"
  shows "v1 \<in> set l1 \<or> v1 \<in> set l2"
  using assms
  by(induction L arbitrary: l1 l2; simp add: sublist_def)
    (metis hd_append2 in_set_conv_decomp list.sel(1) list.sel(3)
      list.set_sel(1) list_set_tl self_append_conv2 tl_append2)

lemma sublist_v1_hd_v2_hd_tl:
  assumes "sublist [v1, v2] L" "distinct L" "v1 = hd L"
  shows "v2 = hd(tl L)"
  using assms
  by (induction L arbitrary: v1; simp add: sublist_def)
     (metis in_set_conv_decomp list.sel(1) list.sel(3) self_append_conv2 tl_append2)

lemma sublist_v1_hd_v2_hd_tl_lists:
  assumes "p1@ (v#vs) @ p2 = L" "distinct L" "v = hd L"
  shows "vs @ p2 = tl L"
  using assms
  by (induction L arbitrary: v vs; simp)
     (metis append_self_conv2 in_set_conv_decomp list.sel(3) tl_append2)

lemma sublist_append:
  assumes "sublist l1 l2"
  shows "sublist l1 (l3@l2)"
  using assms append_eq_append_conv2 unfolding sublist_def by blast

lemma sublist_cons:
  assumes "sublist l1 l2"
  shows "sublist l1 (l#l2)"
  using assms by (metis Cons_eq_appendI sublist_def)

lemma two_sublist_distinct_same_first:
  assumes "sublist [x, a] L" "sublist [y, a] L" "distinct (tl L)"
  shows "x = y"
  using assms
proof(induction L)
  case Nil
  then show ?case
    by (simp add: sublist_def)
next
  case (Cons l L)
  then have distinct: "distinct L"
    by simp
  then have 1: "distinct (tl L)"
    by (simp add: distinct_tl)
  then show ?case
  proof(cases "sublist [x, a] L")
    case True
    then have a1: "sublist [x, a] L"
      by simp
    then show ?thesis
    proof(cases "sublist [y, a] L")
      case True
      then show ?thesis
        using a1 1 Cons
        by simp
    next
      case False
      then have 2: "\<exists>p1 p2. p1@[y, a] @ p2 = (l#L)" "\<not> (\<exists>p1 p2. p1@[y, a] @ p2 = (L))"
        using sublist_def Cons by metis+
      then have "y = l"
        using Cons False by (meson sublist_cons_impl_sublist)
      then have hd: "a = hd L"
        by (metis 2 append_self_conv2 hd_append2 list.distinct(1) list.sel(1) list.sel(3) tl_append2)
      have tl: "a \<in> set (tl L)"
        using a1 distinct hd sublist_second_not_hd by fastforce
      then have False
        using hd tl distinct
        by (metis distinct.simps(2) distinct_singleton list.collapse list_set_tl)
      then show ?thesis
        by simp
    qed
  next
    case False
    then have 2: "\<exists>p1 p2. p1@[x, a] @ p2 = (l#L)" "\<not> (\<exists>p1 p2. p1@[x, a] @ p2 = (L))"
      using sublist_def Cons by metis+
    then have 3: "x = l"
      using Cons False by (meson sublist_cons_impl_sublist)
    then show ?thesis
    proof(cases "sublist [y, a] L")
      case True
      then have hd: "a = hd L"
        by (metis 2 append_self_conv2 hd_append2 list.distinct(1) list.sel(1) list.sel(3) tl_append2)
      have tl: "a \<in> set (tl L)"
        using 3 True sublist_def False
        by (smt append_Cons list.sel(3) list.set_intros(1) self_append_conv2
            sublist_implies_in_set(2) tl_append2)
      then have False
        using hd tl distinct
        by (metis distinct.simps(2) distinct_singleton list.collapse list_set_tl)
      then show ?thesis
        by simp
    next
      case False
      then have 2: "\<exists>p1 p2. p1@[y, a] @ p2 = (l#L)" "\<not> (\<exists>p1 p2. p1@[y, a] @ p2 = (L))"
        using sublist_def Cons by metis+
      then have "y = l"
        using Cons False by (meson sublist_cons_impl_sublist)
      then show ?thesis using 3
        by simp
    qed
  qed
qed

lemma sublist_not_cyclic_for_distinct:
  assumes "sublist [a, b] Cy" "sublist [b, a] Cy" "distinct Cy"
  shows False
  using assms unfolding sublist_def
  by simp
     (metis assms distinct_append list.sel(1) list.set_intros(1)
       sublist_second_not_hd sublist_set_ls2_1 sublist_set_ls2_3)

lemma distinct_sublist_last_first_of_sublist_false:
  assumes "distinct cs" "sublist [a, b] cs" "a = last cs"
  shows False
  using assms unfolding sublist_def
  by simp
     (metis append.right_neutral assms(2) distinct.simps(2) distinct_singleton
       sublist_implies_in_set(1) sublist_set_last_ls1_1_1)

lemma distinct_sublist_last_first_of_sublist_false_2:
  assumes "distinct cs" "sublist [a, b, b2] cs" "a = last cs"
  shows False
  by (smt append_Cons append_Cons_eq_iff append_butlast_last_id assms distinct.simps(2)
        distinct_append list.distinct(1) not_distinct_conv_prefix sublist_code(2) sublist_def)

lemma sublist_hd_tl_equal_b_hd_tl:
  assumes "sublist [a, b] cs" "distinct (tl cs)" "a = last cs"
  shows "b = hd (tl cs)"
  by (metis append_Nil2 assms distinct_sublist_last_first_of_sublist_false hd_Cons_tl last_tl
        sublist_code(2) sublist_set_v2_noteq_hd_lists)

lemma sublist_hd_tl_equal_b_hd_tl_2:
  assumes "sublist [a, b, c] cs" "distinct (tl cs)" "a = last cs"
  shows "b = hd (tl cs) \<and> c = hd(tl (tl cs))"
  by (smt append_is_Nil_conv assms distinct_sublist_last_first_of_sublist_false_2 hd_append2
       last_appendR list.distinct(1) list.sel(1) list.sel(3) self_append_conv2 sublist_def
       tl_append2)

lemma sublist_hd_last_only_2_elems:
  assumes "sublist [a,b] cs" "a = hd cs" "b = last cs" "distinct cs"
  shows "cs = [a, b]"
  by (smt assms distinct1_rotate hd_append last.simps list.exhaust_sel list.set_intros(1)
        rotate1_hd_tl sublist_cons sublist_order.eq_iff
        sublist_set_last_ls1_2 sublist_v1_hd_v2_hd_tl)

lemma two_sublist_distinct_same_last:
  assumes "sublist [x, a] L" "sublist [x, b] L" "distinct (L)"
  shows "a = b"
  using assms unfolding sublist_def
  by (induction L; simp)
     (metis append_self_conv2 in_set_conv_decomp list.sel(1) list.sel(3) tl_append2)

lemma sublist_append_not_in_first:
  assumes "sublist [v1, v2] (l1 @ l2)" "v1 \<notin> set l1"
  shows "sublist [v1, v2] l2"
  using assms by(induction l1)(auto simp add: sublist_cons_impl_sublist)

lemma sublist_append_using_or:
  assumes "sublist [a, b] (l1@l2)" "distinct (l1@l2)" "l1 \<noteq> []"
  shows "sublist [a, b] l1 \<or> sublist [a, b] l2 \<or> (a = last l1 \<and> b = hd l2)"
  using assms by (metis sublist_append_not_in_first sublist_set_last_ls1_1 sublist_set_ls1_4)

lemma distinct_tl_rev_C:
  assumes "distinct (tl C)" "hd C = last C \<or> distinct C"
  shows "distinct (tl (rev C))"
  by (smt List.butlast_rev append_butlast_last_id append_is_Nil_conv assms distinct_append
        distinct_rev hd_append2 last_rev rev_is_Nil_conv set_rev tl_append2 tl_rev)

lemma b_in_set_cy_exists_sublist:
  assumes "b \<in> set Cy" "b \<in> set (tl Cy)" "length Cy \<ge> 2"
  shows "\<exists>a. sublist [a, b] Cy"
  using assms
proof(induction Cy)
  case Nil
  then show ?case
    by auto
next
  case (Cons c Cy)
  then have 1: "b \<in> set Cy"
    by simp
  then show ?case
  proof(cases "b = hd Cy")
    case True
    then have "(c#Cy) = c#b#tl Cy"
      by (metis 1 hd_Cons_tl list.distinct(1) list.set_cases)
    then have "[]@[c,b]@tl Cy = c#Cy"
      by simp
    then have "sublist [c, b] (c#Cy)"
      using Cons sublist_def by metis
    then show ?thesis
      by auto
  next
    case False
    have 2: "length Cy \<ge> 2"
    proof (rule ccontr)
      assume "\<not> 2 \<le> length Cy"
      then have "2 > length Cy"
        by auto
      then have "length Cy = 0 \<or> length Cy = 1"
        by linarith
      then show False
      proof
        assume "length Cy = 0"
        then have "Cy = []"
          by simp
        then show False
          using 1
          by simp
      next
        assume "length Cy = 1"
        then have "Cy = [b]"
          using 1 length_1_set_L
          by metis
        then have "hd Cy = b"
          by simp
        then show False
          using False
          by simp
      qed
    qed
    then have 3: "b \<in> set (tl Cy)"
      using False
      by (metis "1" list.sel(1) list.sel(3) list.set_cases)
    then have "\<exists>a. sublist [a, b] Cy"
      using Cons 1 2 3 False
      by blast
    then show ?thesis
      using 2 sublist_cons
      by fast
  qed
qed

lemma a_in_set_cy_exists_sublist:
  assumes "a \<in> set Cy" "a\<noteq> last Cy"
  shows "\<exists>b. sublist [a, b] Cy"
  by (metis append_Cons append_Nil assms hd_Cons_tl in_set_conv_decomp last_snoc sublist_appendI
        sublist_order.eq_iff sublist_order.order.trans)

lemma b_in_Cycle_exists_sublist:
  assumes "b \<in> set Cycle" "length Cycle \<ge> 2" "hd Cycle = last Cycle"
  shows "\<exists>a. sublist [a, b] Cycle"
  using assms by (metis b_in_set_cy_exists_sublist hd_Cons_tl last_in_set_tl list.sel(2) set_ConsD)

lemma a_in_Cycle_exists_sublist:
  assumes "a \<in> set Cycle" "length Cycle \<ge> 2" "hd Cycle = last Cycle"
  shows "\<exists>b. sublist [a, b] Cycle"
  using assms
proof(cases "a = last Cycle")
  case True
  then have 1: "a = hd Cycle"
    using assms
    by simp
  then obtain b where "b = hd (tl Cycle)"
    by simp
  then have 2: "a # tl Cycle = Cycle"
    using 1 by (metis assms(1) hd_Cons_tl list.discI list.set_cases)
  have "tl Cycle \<noteq> []"
    using last_in_set_tl assms
    by fastforce
  then have "[]@[a, b] @ (tl (tl Cycle)) = Cycle"
    using 2
    by (simp add: \<open>b = hd (tl Cycle)\<close>)
  then have "sublist [a, b] Cycle"
    using sublist_def by metis
  then show ?thesis
    by auto
next
  case False
  then show ?thesis
    using a_in_set_cy_exists_sublist assms
    by metis
qed

lemma two_sublist_same_first_distinct_tl:
  assumes "distinct (tl cs)" "sublist [x, a] cs" "sublist [x, b] cs" "hd cs = last cs"
  shows "b = a"
  using assms
  by (metis distinct.simps(1) list.collapse sublist_cons_impl_sublist_list
      sublist_hd_tl_equal_b_hd_tl two_sublist_distinct_same_last)

lemma distinct_tl_cyclic_sublist_cs_explisit:
  assumes "distinct (tl cs)" "sublist [a, b] cs" "sublist [b, a] cs" "hd cs = last cs" "b \<noteq> a"
  shows "cs = [a, b, a] \<or> cs = [b, a, b]"
  using assms
proof(cases "a = hd cs")
  case True
  then have 1: "b = hd (tl cs)"
    using assms sublist_hd_tl_equal_b_hd_tl
    by fastforce
  then have 2: "a = hd (tl (tl cs))"
    by (metis True assms distinct.simps(1) distinct_singleton hd_Cons_tl
        last_tl list.sel(1) list.sel(3) sublist_cons_impl_sublist sublist_hd_last_only_2_elems
        sublist_not_cyclic_for_distinct)
  then have "cs = [a, b, a]@ (tl (tl (tl cs)))"
    using 1 2 True
    by (metis append_Nil2 assms(1) assms(3) assms(4) assms(5) last_tl list.collapse list.sel(2)
        list.sel(3) sublist_cons_impl_sublist sublist_hd_last_only_2_elems)
  have "a = last cs"
    using assms True
    by simp
  then show ?thesis
    using assms 1 \<open>cs = [a, b, a] @ tl (tl (tl cs))\<close>
    by (metis last_tl list.collapse self_append_conv sublist_cons_impl_sublist
        sublist_hd_last_only_2_elems tl_Nil)
next
  case False
  then have 1: "sublist [a, b] (tl cs)"
    using assms
    by (metis distinct.simps(1) hd_Cons_tl sublist_cons_impl_sublist sublist_not_cyclic_for_distinct)
  then show ?thesis proof(cases "b = hd cs")
    case True
    then have 1: "a = hd (tl cs)"
      using assms sublist_hd_tl_equal_b_hd_tl
      by fastforce
    then have 2: "b = hd (tl (tl cs))"
      by (metis True assms distinct.simps(1) distinct_singleton hd_Cons_tl last_tl list.sel(1, 3)
          sublist_cons_impl_sublist sublist_hd_last_only_2_elems sublist_not_cyclic_for_distinct)
    then have "cs = [b, a, b]@ (tl (tl (tl cs)))"
      using 1 2 True
      by (metis append_Nil2 assms(1, 2, 4, 5) last_tl list.collapse list.sel(2, 3)
          sublist_cons_impl_sublist sublist_hd_last_only_2_elems)
    have "b = last cs"
      using assms True
      by simp
    then show ?thesis
      using assms 1 \<open>cs = [b, a, b] @ tl (tl (tl cs))\<close>
      by (metis last_tl list.collapse self_append_conv sublist_cons_impl_sublist
          sublist_hd_last_only_2_elems tl_Nil)
  next
    case False
    then have 2: "sublist [b, a] (tl cs)"
      using assms
      by (metis distinct.simps(1) hd_Cons_tl sublist_cons_impl_sublist
          sublist_not_cyclic_for_distinct)
    then show ?thesis
      using 1 2 assms
      by (meson sublist_not_cyclic_for_distinct)
  qed
qed

lemma sublist_rev:
  assumes "sublist as bs"
  shows "sublist (rev as) (rev bs)"
  using assms sublist_def by (metis append.assoc rev_append)

lemma sublist_ab_bc_b_not_head:
  assumes "sublist [a, b] ds" "sublist [b, c] ds" "b \<noteq> hd ds""distinct (tl ds)"
  shows "sublist [a, b, c] ds"
  using assms
proof(induction ds)
  case Nil
  then have "[] \<noteq> []"
    by (simp add: sublist_def)
  then show ?case
    by simp
next
  case (Cons d ds)
  then show ?case
  proof(cases "b = hd ds")
    case True
    have "distinct ds" using Cons by auto
    then have 1: "c = hd (tl ds)"
      using True Cons
      by (metis list.sel(1) list.sel(3) sublist_cons_impl_sublist sublist_v1_hd_v2_hd_tl)
    have 2: "a = d"
      using True Cons
      by (metis (no_types, lifting) Cons_eq_appendI \<open>distinct ds\<close> append_self_conv2
          distinct_rev distinct_sublist_last_first_of_sublist_false last_rev rev.simps(1, 2)
          sublist_cons_impl_sublist sublist_not_cyclic_for_distinct sublist_rev)
    then have "ds = b # c # tl(tl ds)"
      using 1 2 True
      by (metis Cons.prems(1, 2, 3) True distinct_length_2_or_more distinct_singleton
          distinct_sublist_last_first_of_sublist_false last_ConsL last_ConsR list.collapse list.sel(1))
    then have "d#ds = a # b #c #(tl (tl ds))"
      using 2
      by simp
    then have "d#ds = [] @ [a, b, c] @ (tl (tl ds))"
      by simp
    then show ?thesis
      using sublist_def
      by metis
  next
    case False
    then have 1: "sublist [a, b] ds"
      using Cons
      by (metis append_self_conv2 hd_append2 list.distinct(1) list.sel(1, 3) sublist_def tl_append2)
    then have 2: "sublist [b, c] ds"
      using Cons list.sel(1) sublist_cons_impl_sublist
      by metis
    then show ?thesis
      using 1 2 Cons
      by (simp add: False distinct_tl sublist_cons)
  qed
qed

lemma sublist_ab_bcs_b_not_head:
  assumes "sublist [a, b] ds" "sublist (b#cs) ds" "b \<noteq> hd ds""distinct (tl ds)"
  shows "sublist (a#b#cs) ds"
  using assms
proof(induction ds)
  case Nil
  then have "[] \<noteq> []"
    by (simp add: sublist_def)
  then show ?case
    by simp
next
  case (Cons d ds)
  then obtain p1 p2 where p_def: "p1 @ (b#cs) @ p2 = d#ds"
    using sublist_def by metis
  then show ?case
  proof(cases "b = hd ds")
    case True
    have "distinct ds"
      using Cons
      by auto
    then have 1: "cs@p2 = tl ds"
      using True Cons p_def sublist_v1_hd_v2_hd_tl_lists
      by (metis hd_append list.sel(1, 2, 3) not_Cons_self2 tl_append2)
    have 2: "a = d"
      using True Cons \<open>distinct ds\<close>
      by (metis (no_types, lifting) Cons_eq_appendI append_self_conv2 distinct_rev
          distinct_sublist_last_first_of_sublist_false last_rev rev.simps(1, 2)
          sublist_cons_impl_sublist sublist_not_cyclic_for_distinct sublist_rev)
    then have "ds = b # cs @ p2"
      using 1 2 True
      by (metis Cons.prems(1) True distinct_singleton distinct_sublist_last_first_of_sublist_false
          last_ConsL list.collapse)
    then have "d#ds = a # b #cs @p2"
      using 2
      by simp
    then have "d#ds = [] @ (a# b#cs) @ p2"
      by simp
    then show ?thesis
      using sublist_def
      by metis
  next
    case False
    then have 1: "sublist [a, b] ds"
      using Cons
      by (metis append_self_conv2 hd_append2 list.distinct(1) list.sel(1, 3) sublist_def tl_append2)
    then have 2: "sublist (b#cs) ds"
      using Cons list.sel(1) sublist_cons_impl_sublist_list
      by metis
    then show ?thesis
      using 1 2 Cons
      by (simp add: False distinct_tl sublist_cons)
  qed
qed

lemma sublist_indixes:
  assumes "Suc i < length cs"
  shows "sublist [cs!i, cs!Suc i] cs"
  using assms
proof(induction cs arbitrary: i)
  case Nil
  then show ?case
    by simp
next
  case (Cons a cs)
  then show ?case proof(cases "Suc i = 1")
    case True
    then have "i = 0"
      by simp
    then have "(a#cs)!i = a"
      using Cons.prems hd_conv_nth
      by fastforce
    then have "(a#cs)!Suc i = hd (cs)"
      using Cons
      by (simp add: \<open>i = 0\<close> hd_conv_nth)
    then have "(a#cs) = [(a#cs)!i, (a#cs)!Suc i] @ tl cs"
      using Cons.prems \<open>i = 0\<close>
      by auto
    then have "(a#cs) = [] @ [(a#cs)!i, (a#cs)!Suc i] @ tl cs"
      using Cons.prems \<open>i = 0\<close>
      by auto
    then show ?thesis
      using sublist_def
      by metis
  next
    case False
    then have "Suc i > 1"
      by simp
    then have "Suc i -1 < length cs"
      using Cons
      by fastforce
    then have "sublist [cs!(i-1), cs!i] cs"
      using Cons \<open>1 < Suc i\<close> gr0_conv_Suc by auto
    then show ?thesis
      by (metis One_nat_def Suc_less_SucD \<open>1 < Suc i\<close> nth_Cons_Suc nth_Cons_pos sublist_cons)
  qed
qed

lemma sublist_sublist_hd:
  assumes "sublist (x#b) C"  "b \<noteq> []"
  shows "sublist [x, hd b] (C)"
  by (metis Cons_eq_appendI assms list.collapse self_append_conv2 sublist_append_rightI
        sublist_order.order.trans)

lemma sublist_cons_cons:
  assumes "sublist (a#b) (c#C)"
  shows "sublist b C"
  by (meson assms Cons_prefix_Cons prefix_imp_sublist sublist_Cons_right sublist_order.order.trans
        sublist_order.order_refl)

lemma hd_C_sublist_hd:
  assumes "distinct (tl C) \<and> hd C = last C  \<or> distinct C" "hd C = x" "sublist (x#b) C"
  shows "\<exists>p. C = (x#b) @ p"
  using assms
proof(induction C arbitrary: x b)
  case Nil
  then show ?case
    by (auto simp add: sublist_def)
next
  case (Cons a C)
  then show ?case
  proof(cases "b = []")
    case True
    then show ?thesis
      using Cons
      by auto
  next
    case False
    then have 1: "sublist b C"
      using Cons sublist_cons_cons
      by metis
    then have "hd C = hd b"
    proof -
      have "sublist [x, hd b] (a#C)"
        using Cons sublist_sublist_hd False
        by metis
      then have "hd b = hd C"
        using Cons
        by (metis list.sel(3) sublist_hd_tl_equal_b_hd_tl sublist_v1_hd_v2_hd_tl)
      then show ?thesis by auto
    qed
    then have "\<exists>p. C = b @ p"
      using Cons 1
      by (metis False distinct_tl list.collapse list.sel(3))
    then show ?thesis
      using Cons.prems(2)
      by auto
  qed
qed

end


theory MPF
imports
  test_utils
  "$AFP/IEEE_Floating_Point/Code_Float"
  "$AFP/IEEE_Floating_Point/FloatProperty"
  "$AFP/IEEE_Floating_Point/RoundError"
  "~~/src/HOL/Library/Monad_Syntax"
begin

lemma "Val One = 1"
  unfolding Val_def One_def
  apply (simp add: Abs_float_inverse is_valid_def float_format_def bias_def)
  done

lemma "Val Plus_zero = 0"
  unfolding Val_def Plus_zero_def
  apply (simp add: Abs_float_inverse is_valid_def)
  done

--\<open>Define the "Multiple Precision Float"\<close>
type_synonym mpf = "float \<times> float list"

fun approx :: "mpf \<Rightarrow> float" where
  "approx (a, es) = a"

fun errors :: "mpf \<Rightarrow> float list" where
  "errors (a, es) = es"

lemma "approx = fst" and "errors = snd"
  by auto

definition Plus_zero_mpf :: mpf where
  "Plus_zero_mpf = (Plus_zero, [])"

definition Minus_zero_mpf :: mpf where
  "Minus_zero_mpf = (Minus_zero, [])"

definition One_mpf :: mpf where
  "One_mpf = (One, [])"

--\<open>Use another notation for the possibly inexact IEEE-operations\<close>
abbreviation round_affected_plus :: "float \<Rightarrow> float \<Rightarrow> float" (infixl "\<oplus>" 65) where
  "round_affected_plus a b \<equiv> a + b"

abbreviation round_affected_minus :: "float \<Rightarrow> float \<Rightarrow> float" (infixl "\<ominus>" 65) where
  "round_affected_minus a b \<equiv> a - b"

abbreviation round_affected_times :: "float \<Rightarrow> float \<Rightarrow> float" (infixl "\<otimes>" 65) where
  "round_affected_times a b \<equiv> a * b"

context
  fixes a b :: float
  assumes ge: "float_abs a \<ge> float_abs b"
begin

  definition FastTwoSum :: "float \<times> float" where
    "FastTwoSum = (let
      x = a \<oplus> b;
      b\<^sub>v = x \<ominus> a;
      y = b \<ominus> b\<^sub>v
      in (x, y))"

  lemma FastTwoSum_correct1: "FastTwoSum = (x, y) \<Longrightarrow> x = a \<oplus> b"
    by (auto simp: FastTwoSum_def Let_def)

  lemma FastTwoSum_correct2:
    fixes x y :: float
    assumes "Finite a"
    assumes "Finite b"
    assumes "Finite (a \<oplus> b)"
    assumes out: "(x, y) = FastTwoSum"
    shows "Val a + Val b = Val x + Val y"
    sorry

end
thm FastTwoSum_def FastTwoSum_correct1 FastTwoSum_correct2

definition TwoSum :: "float \<Rightarrow> float \<Rightarrow> float \<times> float" where
  "TwoSum a b = (let
    x = a \<oplus> b;
    b\<^sub>v = x \<ominus> a;
    a\<^sub>v = x \<ominus> b\<^sub>v;
    b\<^sub>r = b \<ominus> b\<^sub>v;
    a\<^sub>r = a \<ominus> a\<^sub>v;
    y = a\<^sub>r \<oplus> b\<^sub>r
    in (x, y))"

lemma TwoSum_correct1: "TwoSum a b = (x, y) \<Longrightarrow> x = a \<oplus> b"
  by (auto simp: TwoSum_def Let_def)

lemma TwoSum_correct2:
  fixes a b x y :: float
  assumes "Finite a"
  assumes "Finite b"
  assumes "Finite (a \<oplus> b)"
  assumes out: "(x, y) = TwoSum a b"
  shows "Val a + Val b = Val x + Val y"
  sorry

lemma swap: "TwoSum a b = TwoSum b a"
  sorry

text\<open>We embed @{const TwoSum} to make sure overflow will be noticed:\<close>
definition "safe_TwoSum a b =
  (let r = TwoSum a b in
    if Finite (fst r) \<and> Finite (snd r)
    then Some r
    else None)"

lemma safe_TwoSum_finite:
  assumes "safe_TwoSum a b = Some (s, e)"
  shows safe_TwoSum_finite1: "Finite s"
  and safe_TwoSum_finite2: "Finite e"
using assms
  by (auto simp: safe_TwoSum_def Let_def split: split_if_asm)

lemma safe_TwoSum_correct1:
  "safe_TwoSum a b = Some (x, y) \<Longrightarrow> x = a \<oplus> b"
  by (auto simp: safe_TwoSum_def Let_def TwoSum_correct1 split: split_if_asm)

lemma safe_TwoSum_correct2:
  fixes a b x y :: float
  assumes "Finite a" "Finite b" "Finite (a \<oplus> b)"
  assumes out: "safe_TwoSum a b = Some (x, y)"
  shows "Val a + Val b = Val x + Val y"
using assms
  by (auto intro!: TwoSum_correct2 simp: safe_TwoSum_def Let_def split: split_if_asm)

definition "IsZero_mpf mpf \<longleftrightarrow> Iszero (approx mpf) \<and> errors mpf = []"
fun Val_mpf :: "mpf \<Rightarrow> real" where
  "Val_mpf (a, es) = Val a + listsum (map Val es)"
--\<open>sophisticated methods using Float.float might be faster\<close>
fun Finite_mpf :: "mpf \<Rightarrow> bool" where
  "Finite_mpf (a, es) \<longleftrightarrow> Finite a \<and> list_all Finite es"

fun valid :: "mpf \<Rightarrow> bool" where
  "valid (a, es) = (case Iszero a of
    True \<Rightarrow> es = [] |
    False \<Rightarrow> Finite a \<and> list_all (\<lambda>f. Isdenormal f \<or> Isnormal f) es)"

lemma float_distinct_10: "\<not> (Isnormal f \<and> Iszero f)"
  by (auto simp add: float_defs is_normal_def is_zero_def)

lemma valid_no_zero_components: "valid (a, es) \<Longrightarrow> list_all (\<lambda>f. \<not>Iszero f) es"
  apply (simp split: bool.splits)
  apply (induction es)
  using float_distinct(9) float_distinct_10
  apply auto
  done

lemma valid_finite: "valid (a, es) \<Longrightarrow> Finite_mpf (a, es)"
  apply (simp split: bool.splits)
  using float_cases_finite float_distinct apply fastforce
  by (metis (no_types, lifting) Ball_set Finite_def)

--\<open>Recursive versions for induction proofs:\<close>
lemma rec_val: "Val_mpf (a, e # es) = Val a + Val_mpf (e, es)"
  by simp
lemma rec_finite: "Finite_mpf (a, e # es) \<longleftrightarrow> Finite a \<and> Finite_mpf (e, es)"
  by simp

subsection \<open>MPF operations\<close>

fun safe_grow_mpf_rec :: "mpf \<Rightarrow> float \<Rightarrow> mpf option" where
  "safe_grow_mpf_rec (a, []) f =
    do {
      (x, y) \<leftarrow> safe_TwoSum f a;
      Some (x, [y])
    }" |
  "safe_grow_mpf_rec (a, e # es) f =
    do {
      (a', es') \<leftarrow> safe_grow_mpf_rec (e, es) f;
      (x, y) \<leftarrow> safe_TwoSum a' a;
      Some (x, y # es')
    }"

lemmas safe_grow_mpf_induct = safe_grow_mpf_rec.induct[case_names no_error in_between]

lemma preserve_finite:
  assumes "safe_grow_mpf_rec mpf x = Some r"
  assumes "Finite x" "Finite_mpf mpf"
  shows "Finite_mpf r"
using assms
proof (induction mpf x arbitrary: r rule: safe_grow_mpf_induct)
--\<open>The base case is the case where the mpf is a single float with an empty error-list:\<close>
case (no_error a f)
--\<open>We apply the definition of @{const safe_grow_mpf_rec}:\<close>
from no_error.prems(1) have "do {(x, y) \<leftarrow> safe_TwoSum f a; Some (x, [y])} = Some r"
    unfolding safe_grow_mpf_rec.simps(1) .
--\<open>Since we required the result to be some value, we can give it a name:\<close>
  then obtain x y where xy: "safe_TwoSum f a = Some (x, y)" and r: "r = (x, [y])"
    by (auto simp: bind_eq_Some_conv)
--\<open>and then delegate to the corresponding property of @{const safe_TwoSum}:\<close>
  moreover from safe_TwoSum_finite[OF xy]
    have "Finite x" "Finite y".
  ultimately show ?case
    by simp
next
case (in_between a e es f r_full)
--\<open>This case is similar except that we need to prove more floats to be finite\<close>
  note "in_between.prems"(1)[simplified, unfolded bind_eq_Some_conv, simplified]
  then obtain l r where goal1: "safe_grow_mpf_rec (e, es) f = Some (l, r)"
    and r1: "do {(x, y) \<leftarrow> safe_TwoSum l a; Some (x, y # r)} = Some r_full"
      by blast
  then obtain l2 r2 where l2: "safe_TwoSum l a = Some (l2, r2)" and
     r2: "(l2, r2 # r) = r_full"
     using r1[unfolded bind_eq_Some_conv, simplified] by auto
  from r2 have "?case = Finite_mpf (l2, r2 # r)" by simp
  moreover have "Finite l2"
    using safe_TwoSum_finite1[OF l2].
  moreover have "Finite r2"
    using safe_TwoSum_finite2[OF l2].
  moreover from "in_between.IH"[OF goal1 "in_between.prems"(2)] have "list_all Finite r"
    using "in_between.prems"(3)
      by simp
  ultimately
    show ?case
    by simp
qed

theorem preserve_val:
  assumes "safe_grow_mpf_rec mpf x = Some r"
  assumes "Finite x" "Finite_mpf mpf"
  shows "Val_mpf r = Val_mpf mpf + Val x"
using assms
proof (induction mpf x arbitrary: r rule: safe_grow_mpf_induct)
case (no_error a f)
  from no_error.prems(1) have "safe_TwoSum f a \<bind> (\<lambda>(x, y). Some (x, [y])) = Some r"
    unfolding safe_grow_mpf_rec.simps(1) .
  then obtain x y where xy: "safe_TwoSum f a = Some (x, y)" and r: "r = (x, [y])"
    by (auto simp: bind_eq_Some_conv)
  from safe_TwoSum_finite1[OF xy]
  have "Finite x".
  from no_error have an: "Finite a" by simp
  show ?case
    using safe_TwoSum_correct2[OF \<open>Finite f\<close> an _ xy] \<open>Finite x\<close>
      safe_TwoSum_correct1[OF xy]
    by (auto simp: r split: prod.split)
next
case (in_between a e es f r_full)
  note "in_between.prems"(1)[simplified, unfolded bind_eq_Some_conv, simplified]
  then obtain l r where goal1: "safe_grow_mpf_rec (e, es) f = Some (l, r)"
    and r1: "safe_TwoSum l a \<bind> (\<lambda>(x, y). Some (x, y # r)) = Some r_full"
      by blast
  then obtain l2 r2 where l2: "safe_TwoSum l a = Some (l2, r2)" and
     r2: "(l2, r2 # r) = r_full"
     using r1[unfolded bind_eq_Some_conv, simplified] by auto
  then have "Val_mpf r_full = Val_mpf (l2, r2 # r)" by simp
  also have "\<dots> = Val l2 + Val_mpf (r2, r)"
    by (simp add: rec_val)
  also have "\<dots> = Val l2 + Val r2 + listsum(map Val r)"
    by simp
  also have "\<dots> = Val l + Val a + listsum(map Val r)"
    proof -
      from "in_between.prems" have "Finite l"
        using goal1 preserve_finite by auto
      moreover have "Finite a"
        using "in_between.prems"(3) by simp
      moreover have "Finite (l + a)"
        using l2 safe_TwoSum_correct1 safe_TwoSum_finite1 by auto
      moreover have "Val l + Val a = Val l2 + Val r2"
        using safe_TwoSum_correct2[OF calculation l2].
      ultimately show ?thesis
        by simp
    qed
  finally show ?case
    using in_between goal1 rec_finite by auto
qed

lemmas safe_grow_mpf_correct =
  preserve_finite
  preserve_val

fun mpf_neg :: "mpf \<Rightarrow> mpf" where
  "mpf_neg (a, es) = (float_neg a, map float_neg es)"

subsection \<open>Testing\<close>

definition "sehrgross = undefined"
definition "gross = undefined"
definition "mittel = undefined"
definition "klein = undefined"
definition "sehrklein = undefined"
definition "test_mpf = (sehrgross, [gross, mittel, klein, sehrklein])"

(* generate unfolded view in "output" *)
definition "output = safe_grow_mpf_rec test_mpf (float_of 1)"
lemma "P output" unfolding output_def test_mpf_def safe_grow_mpf_rec.simps
  apply (clarsimp split: prod.splits) oops

fun build_mpf :: "float list \<Rightarrow> mpf option" where
  "build_mpf [] = undefined" |
  "build_mpf [f] = Some (f, [])" |
  "build_mpf (f # fs) = do {
    a \<leftarrow> build_mpf fs;
    safe_grow_mpf_rec a f
  }"

fun plus_mpf :: "mpf \<Rightarrow> mpf \<Rightarrow> mpf option" where
  "plus_mpf (a1, []) mpf2 = safe_grow_mpf_rec mpf2 a1" |
  "plus_mpf (a1, e1 # es1) mpf2 = do {
    a \<leftarrow> plus_mpf (e1, es1) mpf2;
    safe_grow_mpf_rec a a1
  }"

fun minus_mpf where
  "minus_mpf mpf1 mpf2 = plus_mpf mpf1 (mpf_neg mpf2)"

ML \<open>val grow_mpf_ml = @{code safe_grow_mpf_rec}\<close>
ML \<open>val test1 =  (2341.0, [~12.324, 0.0003])\<close> (* \<approx>2328.6763 *)
ML \<open>val test2 =  (2351.0, [~12.325, 0.00003])\<close> (* \<approx>2338.67503 *)
ML \<open>grow_mpf_ml test1 5000.00\<close>
ML \<open>grow_mpf_ml test1 0.001\<close>
ML \<open>val test1_list = fst test1 :: snd test1\<close>
ML \<open>val test2_list = fst test2 :: snd test2\<close>
ML \<open>val test_list = test1_list @ test2_list\<close>
ML \<open>@{code build_mpf} test_list\<close>
ML \<open>@{code plus_mpf} test1 test2\<close>
ML \<open>@{code minus_mpf} test1 test2\<close>

end


(* Title: HOL/Library/Uprod.thy
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Unordered pairs\<close>

theory Uprod imports Main begin

typedef ('a, 'b) commute = "{f :: 'a \<Rightarrow> 'a \<Rightarrow> 'b. \<forall>x y. f x y = f y x}"
  morphisms apply_commute Abs_commute
  by auto

setup_lifting type_definition_commute

lemma apply_commute_commute: "apply_commute f x y = apply_commute f y x"
by(transfer) simp

context includes lifting_syntax begin

lift_definition rel_commute :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'c) commute \<Rightarrow> ('b, 'd) commute \<Rightarrow> bool"
is "\<lambda>A B. A ===> A ===> B" .

end

definition eq_upair :: "('a \<times> 'a) \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool"
where "eq_upair = (\<lambda>(a, b) (c, d). a = c \<and> b = d \<or> a = d \<and> b = c)"

lemma eq_upair_simps [simp]:
  "eq_upair (a, b) (c, d) \<longleftrightarrow> a = c \<and> b = d \<or> a = d \<and> b = c"
by(simp add: eq_upair_def)

lemma equivp_eq_upair: "equivp eq_upair"
by(auto simp add: equivp_def fun_eq_iff)

quotient_type 'a uprod = "'a \<times> 'a" / eq_upair by(rule equivp_eq_upair)

lift_definition Upair :: "'a \<Rightarrow> 'a \<Rightarrow> 'a uprod" is Pair parametric Pair_transfer[of "A" "A" for A] .

lemma uprod_exhaust [case_names Upair, cases type: uprod]:
  obtains a b where "x = Upair a b"
by transfer fastforce

lemma Upair_inject [simp]: "Upair a b = Upair c d \<longleftrightarrow> a = c \<and> b = d \<or> a = d \<and> b = c"
by transfer auto

code_datatype Upair

lift_definition case_uprod :: "('a, 'b) commute \<Rightarrow> 'a uprod \<Rightarrow> 'b" is case_prod
  parametric case_prod_transfer[of A A for A] by auto

lemma case_uprod_simps [simp, code]: "case_uprod f (Upair x y) = apply_commute f x y"
by transfer auto

lemma uprod_split: "P (case_uprod f x) \<longleftrightarrow> (\<forall>a b. x = Upair a b \<longrightarrow> P (apply_commute f a b))"
by transfer auto

lemma uprod_split_asm: "P (case_uprod f x) \<longleftrightarrow> \<not> (\<exists>a b. x = Upair a b \<and> \<not> P (apply_commute f a b))"
by transfer auto

lift_definition not_equal :: "('a, bool) commute" is "(\<noteq>)" by auto

lemma apply_not_equal [simp]: "apply_commute not_equal x y \<longleftrightarrow> x \<noteq> y"
by transfer simp

definition proper_uprod :: "'a uprod \<Rightarrow> bool"
where "proper_uprod = case_uprod not_equal"

lemma proper_uprod_simps [simp, code]: "proper_uprod (Upair x y) \<longleftrightarrow> x \<noteq> y"
by(simp add: proper_uprod_def)

context includes lifting_syntax begin

private lemma set_uprod_parametric':
  "(rel_prod A A ===> rel_set A) (\<lambda>(a, b). {a, b}) (\<lambda>(a, b). {a, b})"
by transfer_prover

lift_definition set_uprod :: "'a uprod \<Rightarrow> 'a set" is "\<lambda>(a, b). {a, b}"
  parametric set_uprod_parametric' by auto

lemma set_uprod_simps [simp, code]: "set_uprod (Upair x y) = {x, y}"
by transfer simp

lemma finite_set_uprod [simp]: "finite (set_uprod x)"
by(cases x) simp

private lemma map_uprod_parametric':
  "((A ===> B) ===> rel_prod A A ===> rel_prod B B) (\<lambda>f. map_prod f f) (\<lambda>f. map_prod f f)"
by transfer_prover

lift_definition map_uprod :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a uprod \<Rightarrow> 'b uprod" is "\<lambda>f. map_prod f f"
  parametric map_uprod_parametric' by auto

lemma map_uprod_simps [simp, code]: "map_uprod f (Upair x y) = Upair (f x) (f y)"
by transfer simp

private lemma rel_uprod_transfer':
  "((A ===> B ===> (=)) ===> rel_prod A A ===> rel_prod B B ===> (=))
   (\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c) (\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c)"
by transfer_prover

lift_definition rel_uprod :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a uprod \<Rightarrow> 'b uprod \<Rightarrow> bool"
  is "\<lambda>R (a, b) (c, d). R a c \<and> R b d \<or> R a d \<and> R b c" parametric rel_uprod_transfer'
by auto

lemma rel_uprod_simps [simp, code]:
  "rel_uprod R (Upair a b) (Upair c d) \<longleftrightarrow> R a c \<and> R b d \<or> R a d \<and> R b c"
by transfer auto

lemma Upair_parametric [transfer_rule]: "(A ===> A ===> rel_uprod A) Upair Upair"
unfolding rel_fun_def by transfer auto

lemma case_uprod_parametric [transfer_rule]:
  "(rel_commute A B ===> rel_uprod A ===> B) case_uprod case_uprod"
unfolding rel_fun_def by transfer(force dest: rel_funD)

end

bnf uprod: "'a uprod"
  map: map_uprod
  sets: set_uprod
  bd: natLeq
  rel: rel_uprod
proof -
  show "map_uprod id = id" unfolding fun_eq_iff by transfer auto
  show "map_uprod (g \<circ> f) = map_uprod g \<circ> map_uprod f" for f :: "'a \<Rightarrow> 'b" and g :: "'b \<Rightarrow> 'c"
    unfolding fun_eq_iff by transfer auto
  show "map_uprod f x = map_uprod g x" if "\<And>z. z \<in> set_uprod x \<Longrightarrow> f z = g z"
    for f :: "'a \<Rightarrow> 'b" and g x using that by transfer auto
  show "set_uprod \<circ> map_uprod f = (`) f \<circ> set_uprod" for f :: "'a \<Rightarrow> 'b" by transfer auto
  show "card_order natLeq" by(rule natLeq_card_order)
  show "BNF_Cardinal_Arithmetic.cinfinite natLeq" by(rule natLeq_cinfinite)
  show "regularCard natLeq" by(rule regularCard_natLeq)
  show "ordLess2 (card_of (set_uprod x)) natLeq" for x :: "'a uprod"
    by (auto simp flip: finite_iff_ordLess_natLeq)
  show "rel_uprod R OO rel_uprod S \<le> rel_uprod (R OO S)"
    for R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and S :: "'b \<Rightarrow> 'c \<Rightarrow> bool" by(rule predicate2I)(transfer; auto)
  show "rel_uprod R = (\<lambda>x y. \<exists>z. set_uprod z \<subseteq> {(x, y). R x y} \<and> map_uprod fst z = x \<and> map_uprod snd z = y)"
    for R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" by transfer(auto simp add: fun_eq_iff)
qed

lemma pred_uprod_code [simp, code]: "pred_uprod P (Upair x y) \<longleftrightarrow> P x \<and> P y"
by(simp add: pred_uprod_def)

instantiation uprod :: (equal) equal begin

definition equal_uprod :: "'a uprod \<Rightarrow> 'a uprod \<Rightarrow> bool"
where "equal_uprod = (=)"

lemma equal_uprod_code [code]:
  "HOL.equal (Upair x y) (Upair z u) \<longleftrightarrow> x = z \<and> y = u \<or> x = u \<and> y = z"
unfolding equal_uprod_def by simp

instance by standard(simp add: equal_uprod_def)
end

quickcheck_generator uprod constructors: Upair

lemma UNIV_uprod: "UNIV = (\<lambda>x. Upair x x) ` UNIV \<union> (\<lambda>(x, y). Upair x y) ` Sigma UNIV (\<lambda>x. UNIV - {x})"
apply(rule set_eqI)
subgoal for x by(cases x) auto
done

context begin
private lift_definition upair_inv :: "'a uprod \<Rightarrow> 'a"
is "\<lambda>(x, y). if x = y then x else undefined" by auto

lemma finite_UNIV_prod [simp]:
  "finite (UNIV :: 'a uprod set) \<longleftrightarrow> finite (UNIV :: 'a set)" (is "?lhs = ?rhs")
proof
  assume ?lhs
  hence "finite (range (\<lambda>x :: 'a. Upair x x))" by(rule finite_subset[rotated]) simp
  hence "finite (upair_inv ` range (\<lambda>x :: 'a. Upair x x))" by(rule finite_imageI)
  also have "upair_inv (Upair x x) = x" for x :: 'a by transfer simp
  then have "upair_inv ` range (\<lambda>x :: 'a. Upair x x) = UNIV" by(auto simp add: image_image)
  finally show ?rhs .
qed(simp add: UNIV_uprod)

end

lemma card_UNIV_uprod:
  "card (UNIV :: 'a uprod set) = card (UNIV :: 'a set) * (card (UNIV :: 'a set) + 1) div 2"
  (is "?UPROD = ?A * _ div _")
proof(cases "finite (UNIV :: 'a set)")
  case True
  from True obtain f :: "nat \<Rightarrow> 'a" where bij: "bij_betw f {0..<?A} UNIV"
    by (blast dest: ex_bij_betw_nat_finite)
  hence [simp]: "f ` {0..<?A} = UNIV" by(rule bij_betw_imp_surj_on)
  have "UNIV = (\<lambda>(x, y). Upair (f x) (f y)) ` (SIGMA x:{0..<?A}. {..x})"
    apply(rule set_eqI)
    subgoal for x
      apply(cases x)
      apply(clarsimp)
      subgoal for a b
        apply(cases "inv_into {0..<?A} f a \<le> inv_into {0..<?A} f b")
        subgoal by(rule rev_image_eqI[where x="(inv_into {0..<?A} f _, inv_into {0..<?A} f _)"])
                  (auto simp add: inv_into_into[where A="{0..<?A}" and f=f, simplified] intro: f_inv_into_f[where f=f, symmetric])
        subgoal
          apply(simp only: not_le)
          apply(drule less_imp_le)
          apply(rule rev_image_eqI[where x="(inv_into {0..<?A} f _, inv_into {0..<?A} f _)"])
          apply(auto simp add: inv_into_into[where A="{0..<?A}" and f=f, simplified] intro: f_inv_into_f[where f=f, symmetric])
          done
        done
      done
    done
  hence "?UPROD = card \<dots>" by simp
  also have "\<dots> = card (SIGMA x:{0..<?A}. {..x})"
    apply(rule card_image)
    using bij[THEN bij_betw_imp_inj_on]
    by(simp add: inj_on_def Ball_def)(metis leD le_eq_less_or_eq le_less_trans)
  also have "\<dots> = sum Suc {0..<?A}"
    by (subst card_SigmaI) simp_all
  also have "\<dots> = sum of_nat {Suc 0..?A}"
    using sum.atLeastLessThan_reindex [symmetric, of Suc 0 ?A id]
    by (simp del: sum.op_ivl_Suc add: atLeastLessThanSuc_atLeastAtMost)
  also have "\<dots> = ?A * (?A + 1) div 2"
    using gauss_sum_from_Suc_0 [of ?A, where ?'a = nat] by simp
  finally show ?thesis .
qed simp

end


theory SetComprehension
  imports GZF_Base
begin

context GZF begin

text \<open>Mapping a \<lambda>-function over a set\<close>
definition RepFun :: "['a, 'a \<Rightarrow> 'a] \<Rightarrow> 'a" where
  "RepFun x F \<equiv> Repl x (\<lambda>a b. b = F a)"

text \<open>Filtering a set using a predicate\<close>
definition Collect :: "'a \<Rightarrow> ['a \<Rightarrow> bool] \<Rightarrow> 'a" where
  "Collect x P \<equiv> Repl x (\<lambda>a b. a = b \<and> P a)"

end

syntax
  "_RepFun" :: "['a, pttrn, 'a] => 'a"  (\<open>(1{_ |/ _ \<in> _})\<close> [51,0,51])
  "_Collect" :: "[pttrn, 'a, bool ] \<Rightarrow> 'a"  (\<open>(1{_ \<in> _ |/ _})\<close>)
translations
  "{c | b\<in>x}" \<rightleftharpoons> "CONST RepFun x (\<lambda>b. c)"
  "{b\<in>x | P}" \<rightleftharpoons> "CONST Collect x (\<lambda>b. P)"

context GZF begin
(*We should only have to know that F returns a SetMem when it's applied to a member of a given set,
  but this would require making ReplFun take an extra parameter for the set.*)
(*Instead, it might be better to have a version of RepFun that restricts F to the domain of the set,
  which adds the proof obligation \<forall>a \<in> x. F a : SetMem to lemmas*)

lemma any_replpred :
 "x : Set \<Longrightarrow> (\<lambda>a b. b = F a) : ReplPred x"
 by (rule replpredI, unfold tuniq_def Uniq_def, auto)

lemma RepFun_typ_set : "RepFun : (\<Pi> x : Set. Any \<rightarrow> Set)"
  unfolding RepFun_def
  by (rule depfunI, rule funI, use any_replpred repl_set in auto)

definition mem_fun_ty :: \<open>'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'a) \<Rightarrow> bool)\<close>
  (infixr \<open>\<leadsto>\<close> 50) where [typdef] : \<open>x \<leadsto> P \<equiv> MemOf x \<rightarrow> P\<close>

lemma mem_funI :
  assumes "\<And>b. b \<in> x \<Longrightarrow> F b : P"
    shows "F : x \<leadsto> P"
  using assms
  unfolding mem_fun_ty_def MemOf_def fun_ty_def has_ty_def
  by auto

lemma mem_funE :
  assumes "F : x \<leadsto> P" "b \<in> x"
    shows "F b : P"
  using assms
  unfolding mem_fun_ty_def MemOf_def fun_ty_def has_ty_def
  by auto

lemma replfun_funpred :
  assumes x : "x : Set" and F : "F : x \<leadsto> \<beta>"
    shows "(\<lambda>a b. b = F a) : ReplFunPred x \<beta>"
  unfolding ReplFunPred_def
  by (rule intI, rule any_replpred[OF x], rule bpredI,
      use memofD mem_funE[OF F] in auto)
(*
lemma replfunI :
  assumes x : "x : Set" and setfun:"\<And>a. a \<in> x \<Longrightarrow> F a : SetMem"
      and funty:"\<And>a. a \<in> x \<Longrightarrow>  a : \<alpha> \<Longrightarrow> F a : \<beta>"
    shows "F : ReplFun x \<alpha> \<beta>"
  unfolding ReplFun_def
  by (rule intI, rule mem_funI[OF setfun], auto, rule funI, drule intE,
      insert funty, unfold MemOf_def has_ty_def, auto)
   *)

(* corollary setmap_replpred : "x : Set \<Longrightarrow> F : ReplFun x \<alpha> \<beta> \<Longrightarrow> (\<lambda>a b. b = F a) : ReplPred x"
  by (rule subtypE[OF funpred_replpred replfun_funpred])
corollary setmap_binpred : "x : Set \<Longrightarrow> F : ReplFun x \<alpha> \<beta> \<Longrightarrow> (\<lambda>a b. b = F a) : BinPred (\<alpha> \<bar> MemOf x) \<beta>"
  by (rule subtypE[OF funpred_binpred replfun_funpred])
 *)

lemma RepFun_typ :
  "RepFun : (\<Pi> x : Set. (x \<leadsto> \<beta>) \<rightarrow> SetOf \<beta>)"
proof (rule depfunI, rule funI)
  fix x :: 'a and F :: "'a \<Rightarrow> 'a"
  assume "x : Set" "F : x \<leadsto> \<beta>"
  hence "(\<lambda>a b. b = F a) : ReplFunPred x \<beta>"
    using replfun_funpred by auto
  thus "RepFun x F : SetOf \<beta>"
    unfolding RepFun_def by (rule funE[OF depfunE[OF Repl_typ2 \<open>x : Set\<close>]])
qed

lemmas repfun_setof = funE[OF depfunE[OF RepFun_typ]]
lemmas repfun_set = funE[OF depfunE[OF RepFun_typ_set] anyI]

lemma repfunI :
  assumes x : "x : Set"
      and b : "b \<in> x" and Fb : "F b : SetMem"
    shows "F b \<in> {F b | b \<in> x}"
  unfolding RepFun_def
  by (rule replaceI[OF x any_replpred[OF x]],
      use b Fb in auto)

lemma repfun_eqI :
  assumes "x : Set"
    shows "\<lbrakk> c : SetMem ; c = F b ; b \<in> x \<rbrakk> \<Longrightarrow> c \<in> {F a | a \<in> x}"
  using repfunI[OF assms] by auto

lemma repfunE :
  assumes x : "x : Set" and b : "b \<in> RepFun x F"
  obtains a where "a \<in> x" "b : SetMem" "b = F a"
    using b unfolding RepFun_def
    using replaceE[OF x any_replpred[OF x], of b F] by blast

lemma repfun_cong :
  assumes x : "x : Set" and y : "y : Set"
  shows "\<lbrakk> x = y ; \<And>a. a \<in> y \<Longrightarrow> F a = G a \<rbrakk> \<Longrightarrow> RepFun x F = RepFun y G"
  unfolding RepFun_def
  using replace_cong[OF x any_replpred[OF x] y any_replpred[OF y]] by simp

lemma repfun_iff  :
  assumes "x : Set"
  shows "b \<in> RepFun x F \<longleftrightarrow> (\<exists>c \<in> x. b = F c) \<and> b : SetMem"
  using repfun_eqI[OF assms] repfunE[OF assms] by blast

lemma repfun_union :
  assumes x : "x : Set" and F : "F : x \<leadsto> Set"
  shows "b \<in> \<Union> {F a | a \<in> x} \<longleftrightarrow> (\<exists>a \<in> x. b \<in> F a)"
proof -
  have R:"RepFun x F : SetOf Set"
    by (rule funE[OF depfunE[OF RepFun_typ x] F])
  show ?thesis
    unfolding union_iff[OF R] bex_def rex_def
              repfun_iff[OF \<open>x : Set\<close>]
    by (auto, use set_setmem[OF mem_funE[OF F]] in auto )
qed

lemma repfun_union_subset :
  assumes x : "x : Set" and y : "y : Set"
      and F : "F : x \<leadsto> Set"
    shows "a \<in> x \<Longrightarrow> y \<subseteq> F a \<Longrightarrow> y \<subseteq> \<Union> {F a | a \<in> x}"
proof -
  assume "a \<in> x" "y \<subseteq> F a"
  hence "F a : Set" using mem_funE[OF F] by auto
  have "\<Union> RepFun x F : Set"
    using union_set[OF repfun_setof[OF x F]] .
  from \<open>a \<in> x\<close> \<open>y \<subseteq> F a\<close> show ?thesis
    unfolding repfun_union[OF x F] subset_iff
    by auto
qed

subsection \<open>Rules for subset comprehension\<close>

lemma collect_replpred :
  "x : Set \<Longrightarrow> (\<lambda>a b. a = b \<and> P a) : ReplPred x"
  using setmemI
  unfolding ReplPred_def tuniq_def Uniq_def has_ty_def
  by auto
      (* rule, rule, rule, drule setmemI[OF \<open>x : Set\<close>], unfold has_ty_def, auto *)

lemma Collect_typ : "Collect : Set \<rightarrow> Any \<rightarrow> Set"
proof (rule funI)+
  fix x and P :: "'a => bool" assume "x : Set"
  moreover hence "(\<lambda>a b. a = b \<and> P a) : ReplPred x" by (rule collect_replpred)
  ultimately show "Collect x P : Set" unfolding Collect_def by (rule repl_set)
qed

lemmas collect_set = funE[OF funE[OF Collect_typ] anyI]

lemma collect_iff :
  assumes x : "x : Set"
    shows "a \<in> { a \<in> x | P a} \<longleftrightarrow> a \<in> x \<and> P a"
  unfolding Collect_def replace_iff[OF \<open>x : Set\<close> collect_replpred[OF \<open>x : Set\<close>]]
  using setmemI[OF x] by auto

lemma collectI :
  assumes "x : Set"
    shows "\<lbrakk> a \<in> x ; P a \<rbrakk> \<Longrightarrow> a \<in> { a \<in> x | P a }"
  using collect_iff[OF \<open>x : Set\<close>] by auto

lemma collectE :
  assumes "x : Set"
    shows "\<lbrakk> a \<in> { a \<in> x | P a } ; \<lbrakk> a \<in> x ; P a \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  using collect_iff[OF assms] by auto

lemma collectD1 :
  assumes "x : Set"
    shows "a \<in> { a\<in>x | P a } \<Longrightarrow> a \<in> x"
  using collectE[OF assms] by auto

lemma collectD2 :
  assumes "x : Set"
    shows "a \<in> { a\<in>x | P a } \<Longrightarrow> P a"
  using collectE[OF assms] by auto

lemma collect_subset :
  assumes "x : Set"
    shows "{ a\<in>x | P a } \<subseteq> x"
proof (rule subsetI)
  fix a assume "a \<in> Collect x P"
  thus "a \<in> x" by (rule collectD1[OF \<open>x : Set\<close>])
qed

lemma collect_typ_subset :
  assumes "x : SetOf \<alpha>"
  shows "{ a\<in>x | P a } : SetOf \<alpha>"
proof (rule setof_subset[OF _ \<open>x : SetOf \<alpha>\<close>])
  have "x : Set" by (rule setof_set[OF \<open>x : SetOf \<alpha>\<close>])
  thus "Collect x P : Set" and "Collect x P \<subseteq> x"
    by (rule collect_set, rule collect_subset)
qed

lemma Collect_cong [cong]:
  assumes "x : Set" "y : Set"
  shows [cong]: "\<lbrakk> x = y;  \<And>a. a \<in> y \<Longrightarrow> P a \<longleftrightarrow> Q a \<rbrakk>
                  \<Longrightarrow> { a\<in>x | P a } = { a\<in>y | Q a }"
  unfolding Collect_def using collect_replpred[OF \<open>x : Set\<close>, of P]
                              collect_replpred[of _ Q] assms by auto

end
end


theory Predicate_Compile_Quickcheck_Examples
imports "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
begin

section {* Sets *}

lemma "x \<in> {(1::nat)} ==> False"
quickcheck[generator=predicate_compile_wo_ff, iterations=10]
oops

lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x \<noteq> Suc 0"
quickcheck[generator=predicate_compile_wo_ff]
oops

lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x = Suc 0"
quickcheck[generator=predicate_compile_wo_ff]
oops

lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x <= Suc 0"
quickcheck[generator=predicate_compile_wo_ff]
oops

section {* Numerals *}

lemma
  "x \<in> {1, 2, (3::nat)} ==> x = 1 \<or> x = 2"
quickcheck[generator=predicate_compile_wo_ff]
oops

lemma "x \<in> {1, 2, (3::nat)} ==> x < 3"
quickcheck[generator=predicate_compile_wo_ff]
oops

lemma
  "x \<in> {1, 2} \<union> {3, 4} ==> x = (1::nat) \<or> x = (2::nat)"
quickcheck[generator=predicate_compile_wo_ff]
oops

section {* Equivalences *}

inductive is_ten :: "nat => bool"
where
  "is_ten 10"

inductive is_eleven :: "nat => bool"
where
  "is_eleven 11"

lemma
  "is_ten x = is_eleven x"
quickcheck[tester = predicate_compile_wo_ff, iterations = 1, size = 1, expect = counterexample]
oops

section {* Context Free Grammar *}

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

lemma
  "w \<in> S\<^sub>1 \<Longrightarrow> w = []"
quickcheck[tester = predicate_compile_ff_nofs, iterations=1]
oops

theorem S\<^sub>1_sound:
"w \<in> S\<^sub>1 \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[generator=predicate_compile_ff_nofs, size=15]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"
(*
code_pred [random_dseq inductify] S\<^sub>2 .
thm S\<^sub>2.random_dseq_equation
thm A\<^sub>2.random_dseq_equation
thm B\<^sub>2.random_dseq_equation

values [random_dseq 1, 2, 8] 10 "{x. S\<^sub>2 x}"

lemma "w \<in> S\<^sub>2 ==> w \<noteq> [] ==> w \<noteq> [b, a] ==> w \<in> {}"
quickcheck[generator=predicate_compile, size=8]
oops

lemma "[x <- w. x = a] = []"
quickcheck[generator=predicate_compile]
oops

declare list.size(3,4)[code_pred_def]

(*
lemma "length ([x \<leftarrow> w. x = a]) = (0::nat)"
quickcheck[generator=predicate_compile]
oops
*)

lemma
"w \<in> S\<^sub>2 ==> length [x \<leftarrow> w. x = a] <= Suc (Suc 0)"
quickcheck[generator=predicate_compile, size = 10, iterations = 1]
oops
*)
theorem S\<^sub>2_sound:
"w \<in> S\<^sub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[generator=predicate_compile_ff_nofs, size=5, iterations=10]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

code_pred [inductify, skip_proof] S\<^sub>3 .
thm S\<^sub>3.equation
(*
values 10 "{x. S\<^sub>3 x}"
*)

lemma S\<^sub>3_sound:
"w \<in> S\<^sub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[generator=predicate_compile_ff_fs, size=10, iterations=10]
oops

lemma "\<not> (length w > 2) \<or> \<not> (length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b])"
quickcheck[size=10, tester = predicate_compile_ff_fs]
oops

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. b = x] \<longrightarrow> w \<in> S\<^sub>3"
(*quickcheck[generator=SML]*)
quickcheck[generator=predicate_compile_ff_fs, size=10, iterations=100]
oops

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

theorem S\<^sub>4_sound:
"w \<in> S\<^sub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = predicate_compile_ff_nofs, size=5, iterations=1]
oops

theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
quickcheck[tester = predicate_compile_ff_nofs, size=5, iterations=1]
oops

hide_const a b

subsection {* Lexicographic order *}
(* TODO *)
(*
lemma
  "(u, v) : lexord r ==> (x @ u, y @ v) : lexord r"
oops
*)
subsection {* IMP *}

type_synonym var = nat
type_synonym state = "int list"

datatype com =
  Skip |
  Ass var "int" |
  Seq com com |
  IF "state list" com com |
  While "state list" com

inductive exec :: "com => state => state => bool" where
  "exec Skip s s" |
  "exec (Ass x e) s (s[x := e])" |
  "exec c1 s1 s2 ==> exec c2 s2 s3 ==> exec (Seq c1 c2) s1 s3" |
  "s \<in> set b ==> exec c1 s t ==> exec (IF b c1 c2) s t" |
  "s \<notin> set b ==> exec c2 s t ==> exec (IF b c1 c2) s t" |
  "s \<notin> set b ==> exec (While b c) s s" |
  "s1 \<in> set b ==> exec c s1 s2 ==> exec (While b c) s2 s3 ==> exec (While b c) s1 s3"

code_pred [random_dseq] exec .

values [random_dseq 1, 2, 3] 10 "{(c, s, s'). exec c s s'}"

lemma
  "exec c s s' ==> exec (Seq c c) s s'"
  quickcheck[tester = predicate_compile_wo_ff, size=2, iterations=20, expect = counterexample]
oops

subsection {* Lambda *}

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs type dB

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = None"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
where
  "nth_el' (x # xs) 0 x"
| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"

inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "nth_el' env x T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : U \<Rightarrow> T \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs T s) k = Abs T (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"

lemma
  "\<Gamma> \<turnstile> t : U \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : U"
quickcheck[tester = predicate_compile_ff_fs, size = 7, iterations = 10]
oops

subsection {* JAD *}

definition matrix :: "('a :: semiring_0) list list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "matrix M rs cs \<longleftrightarrow> (\<forall> row \<in> set M. length row = cs) \<and> length M = rs"
(*
code_pred [random_dseq inductify] matrix .
thm matrix.random_dseq_equation

thm matrix_aux.random_dseq_equation

values [random_dseq 3, 2] 10 "{(M, rs, cs). matrix (M:: int list list) rs cs}"
*)
lemma [code_pred_intro]:
  "matrix [] 0 m"
  "matrix xss n m ==> length xs = m ==> matrix (xs # xss) (Suc n) m"
proof -
  show "matrix [] 0 m" unfolding matrix_def by auto
next
  show "matrix xss n m ==> length xs = m ==> matrix (xs # xss) (Suc n) m"
    unfolding matrix_def by auto
qed

code_pred [random_dseq inductify] matrix
  apply (cases x)
  unfolding matrix_def apply fastforce
  apply fastforce done

values [random_dseq 2, 2, 15] 6 "{(M::int list list, n, m). matrix M n m}"

definition "scalar_product v w = (\<Sum> (x, y)\<leftarrow>zip v w. x * y)"

definition mv :: "('a \<Colon> semiring_0) list list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where [simp]: "mv M v = map (scalar_product v) M"
text {*
  This defines the matrix vector multiplication. To work properly @{term
"matrix M m n \<and> length v = n"} must hold.
*}

subsection "Compressed matrix"

definition "sparsify xs = [i \<leftarrow> zip [0..<length xs] xs. snd i \<noteq> 0]"
(*
lemma sparsify_length: "(i, x) \<in> set (sparsify xs) \<Longrightarrow> i < length xs"
  by (auto simp: sparsify_def set_zip)

lemma listsum_sparsify[simp]:
  fixes v :: "('a \<Colon> semiring_0) list"
  assumes "length w = length v"
  shows "(\<Sum>x\<leftarrow>sparsify w. (\<lambda>(i, x). v ! i) x * snd x) = scalar_product v w"
    (is "(\<Sum>x\<leftarrow>_. ?f x) = _")
  unfolding sparsify_def scalar_product_def
  using assms listsum_map_filter[where f="?f" and P="\<lambda> i. snd i \<noteq> (0::'a)"]
  by (simp add: listsum_setsum)
*)
definition [simp]: "unzip w = (map fst w, map snd w)"

primrec insert :: "('a \<Rightarrow> 'b \<Colon> linorder) => 'a \<Rightarrow> 'a list => 'a list" where
  "insert f x [] = [x]" |
  "insert f x (y # ys) = (if f y < f x then y # insert f x ys else x # y # ys)"

primrec sort :: "('a \<Rightarrow> 'b \<Colon> linorder) \<Rightarrow> 'a list => 'a list" where
  "sort f [] = []" |
  "sort f (x # xs) = insert f x (sort f xs)"

definition
  "length_permutate M = (unzip o sort (length o snd)) (zip [0 ..< length M] M)"
(*
definition
  "transpose M = [map (\<lambda> xs. xs ! i) (takeWhile (\<lambda> xs. i < length xs) M). i \<leftarrow> [0 ..< length (M ! 0)]]"
*)
definition
  "inflate upds = foldr (\<lambda> (i, x) upds. upds[i := x]) upds (replicate (length upds) 0)"

definition
  "jad = apsnd transpose o length_permutate o map sparsify"

definition
  "jad_mv v = inflate o split zip o apsnd (map listsum o transpose o map (map (\<lambda> (i, x). v ! i * x)))"

lemma "matrix (M::int list list) rs cs \<Longrightarrow> False"
quickcheck[tester = predicate_compile_ff_nofs, size = 6]
oops

lemma
  "\<lbrakk> matrix M rs cs ; length v = cs \<rbrakk> \<Longrightarrow> jad_mv v (jad M) = mv M v"
quickcheck[tester = predicate_compile_wo_ff]
oops

end