theory Linear_Programming
  imports
    "HOL-Library.Code_Target_Int"
    "LP_Preliminaries"
    Farkas.Simplex_for_Reals
begin

section \<open> Abstract LPs \<close>

(* A b c, where A leq b are the constraints and c is the objective function *)

text \<open> Primal Problem \<close>
definition "sat_primal A b = { x. [A *\<^sub>v x]\<le>b }"

text \<open> Dual Problem \<close>
definition "sat_dual A c  = {y. [y \<^sub>v* A]=c \<and> (\<forall>i<dim_vec y. y $ i \<ge> 0)}"

definition "optimal_set f S = {x \<in> S. (\<forall>y\<in> S. f x y)}"

abbreviation max_lp where
  "max_lp A b c \<equiv> optimal_set (\<lambda>x y. (y \<bullet> c) \<le> (x \<bullet> c)) (sat_primal A b)"

abbreviation min_lp where
  "min_lp A b c \<equiv> optimal_set (\<lambda>x y. (y \<bullet> c) \<ge> (x \<bullet> c)) (sat_dual A c)"

lemma optimal_setI[intro]:
  assumes "x \<in> S"
  assumes "\<And>y. y \<in> S \<Longrightarrow> (\<lambda>x y. (y \<bullet> c) \<ge> (x \<bullet> c)) x y"
  shows "x \<in> optimal_set (\<lambda>x y. (y \<bullet> c) \<ge> (x \<bullet> c)) S"
  unfolding optimal_set_def using assms
  by blast

lemma max_lpI [intro]:
  assumes "[A *\<^sub>v x]\<le>b"
  assumes "(\<And>y. [A *\<^sub>v y]\<le>b \<Longrightarrow> (\<lambda>x y. (y \<bullet> c) \<ge> (x \<bullet> c)) y x)"
  shows "x \<in> max_lp A b c"
  using optimal_setI[of x "{ x. [A *\<^sub>v x]\<le>b }" c]
  unfolding optimal_set_def optimal_setI
  by (simp add: assms(1) assms(2) sat_primal_def)

lemma min_lpI [intro]:
  assumes "[y \<^sub>v* A]=c"
    and "(\<And>i. i<dim_vec y \<Longrightarrow> y $ i \<ge> 0)"
  assumes "(\<And>x. x \<in> sat_dual A c \<Longrightarrow> (\<lambda>x y. (y \<bullet> c) \<ge> (x \<bullet> c)) y x)"
  shows "y \<in> min_lp A b c"
  using optimal_setI[of y "sat_dual A c" c]
  unfolding optimal_set_def optimal_setI sat_dual_def
  by (simp add: assms(1) assms(2) assms(3) sat_dual_def)

lemma sat_primalD [dest]:
  assumes "x \<in> sat_primal A b"
  shows "[A *\<^sub>v x]\<le>b"
  using assms sat_primal_def by force

lemma sat_primalI [intro]:
  assumes "[A *\<^sub>v x]\<le>b"
  shows "x \<in> sat_primal A b"
  using assms sat_primal_def by force

lemma sat_dualD [dest]:
  assumes "y \<in> sat_dual A c"
  shows "[y \<^sub>v* A]=c" "(\<forall>i<dim_vec y. y $ i \<ge> 0)"
  using assms sat_dual_def apply force
  using assms sat_dual_def by force

lemma sat_dualI [intro]:
  assumes "[y \<^sub>v* A]=c" "(\<forall>i<dim_vec y. y $ i \<ge> 0)"
  shows "y \<in> sat_dual A c"
  using assms sat_dual_def by auto

lemma sol_dim_in_sat_primal: "x \<in> sat_primal A b \<Longrightarrow> dim_vec x = dim_col A"
  unfolding mat_times_vec_leq_def by (simp add: mat_times_vec_leq_def sat_primal_def)

lemma sol_dim_in_max_lp: "x \<in> max_lp A b c \<Longrightarrow> dim_vec x = dim_col A"
  unfolding optimal_set_def using sol_dim_in_sat_primal[of x A b] by blast

lemma sol_dim_in_sat_dual: "x \<in> sat_dual A c \<Longrightarrow> dim_vec x = dim_row A"
  unfolding mat_times_vec_leq_def by (simp add: sat_dual_def vec_times_mat_eq_def)

lemma sol_dim_in_min_lp: "x \<in> min_lp A b c \<Longrightarrow> dim_vec x = dim_row A"
  unfolding optimal_set_def using sol_dim_in_sat_dual[of x A] by blast

lemma min_lp_in_sat_dual: "x \<in> min_lp A b c \<Longrightarrow> x \<in> sat_dual A c"
  unfolding optimal_set_def using sol_dim_in_sat_dual[of x A] by blast

lemma max_lp_in_sat_primal: "x \<in> max_lp A b c \<Longrightarrow> x \<in> sat_primal A b"
  unfolding optimal_set_def using sol_dim_in_sat_dual[of x A] by blast

locale abstract_LP =
  fixes A :: "('a::{comm_semiring_1,ordered_semiring,linorder}) mat"
  fixes b :: "'a vec"
  fixes c :: "'a vec"
  fixes m
  fixes n
  assumes "b \<in> carrier_vec m"
  assumes "c \<in> carrier_vec n"
  assumes "A \<in> carrier_mat m n"
begin

lemma dim_b_row_A: "dim_vec b = dim_row A"
  using abstract_LP_axioms abstract_LP_def carrier_matD(1) carrier_vecD
  by metis

lemma dim_b_col_A: "dim_vec c = dim_col A"
  using abstract_LP_axioms abstract_LP_def carrier_matD(2) carrier_vecD
  by metis

lemma weak_duality_aux:
  fixes i j
  assumes "i \<in> {c \<bullet> x |x. x \<in> sat_primal A b}"
    and "j \<in> {b \<bullet> y |y. y \<in> sat_dual A c}"
  shows "i \<le> j"
proof -
  obtain x where x: "i = c \<bullet> x" "[A *\<^sub>v x]\<le>b"
    using assms by blast
  obtain y where y: "j = b \<bullet> y" "[y \<^sub>v* A]=c" "(\<forall>i<dim_vec y. 0 \<le> y $ i)"
    using assms by blast
  have d1: "dim_vec x = n" using mat_times_vec_leq_def[of A x b] x
    by (metis abstract_LP_axioms abstract_LP_def carrier_matD(2))
  have d2: "dim_vec y = m"
    by (metis abstract_LP_axioms abstract_LP_def carrier_matD(1) index_transpose_mat(3) vec_times_mat_eq_def y(2))
  have "i = c \<bullet> x" using x by auto
  also have "... = (A\<^sup>T *\<^sub>v y) \<bullet> x"
    using mult_right_eq carrier_vecD y abstract_LP_def
    by (metis abstract_LP_axioms calculation d1)
  also have "... = (A *\<^sub>v x) \<bullet> y"
    using assoc_scalar_prod_mult_mat_vec[symmetric, of y m x n A] abstract_LP_axioms abstract_LP_def d1 d2
      carrier_vec_dim_vec by blast
  also have "... \<le> b \<bullet> y"
    using mult_right_leq
    by (metis index_transpose_mat(3) mat_times_vec_leq_def vec_times_mat_eq_def x(2) y(2) y(3))
  also have "... = j" using y by simp
  finally show "i \<le> j" .
qed

theorem weak_duality_theorem:
  assumes "x \<in> max_lp A b c"
  assumes "y \<in> min_lp A b c"
  shows "x \<bullet> c \<le> y \<bullet> b"
proof -
  define i where i: "i = x \<bullet> c"
  define j where j: "j = y \<bullet> b"
  have dx: "dim_vec x = n"
    using sol_dim_in_max_lp[of x c A b, OF assms(1)] abstract_LP_axioms abstract_LP_def
      carrier_matD(2) by blast
  have dy: "dim_vec y = m"
    using sol_dim_in_min_lp[of y c A, OF assms(2)]  abstract_LP_axioms abstract_LP_def
      carrier_matD(1) by blast
  have *: "i \<in> {c \<bullet> x |x. [A *\<^sub>v x]\<le>b}" using assms(1) unfolding optimal_set_def dx sat_primal_def
    using abstract_LP_axioms abstract_LP_def carrier_vec_dim_vec comm_scalar_prod dx i by blast
  have **: "j \<in> {b \<bullet> y |y. [y \<^sub>v* A]=c \<and> (\<forall>i < dim_vec y. y$i \<ge> 0)}"
    using assms(2) unfolding optimal_set_def using abstract_LP_axioms abstract_LP_def
      carrier_vec_dim_vec comm_scalar_prod dy j by blast
  from weak_duality_aux[of i j] have "i \<le> j" unfolding sat_primal_def sat_dual_def
    using "*" "**" by blast
  then show ?thesis using i j by auto
qed

end

fun create_optimal_solutions where
  "create_optimal_solutions A b c =
        (case simplex (x_times_c_geq_y_times_b c b #
                                      mat_leqb_eqc A b c @
                                      from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b)))
                                    of
                                      Unsat X \<Rightarrow> Unsat X
                                      | Sat X \<Rightarrow> Sat X)"

fun optimize_no_cond where "optimize_no_cond A b c = (case create_optimal_solutions A b c of
                          Unsat X \<Rightarrow> Unsat X
                        | Sat X \<Rightarrow>  Sat (fst (split_n_m_x (dim_vec c) (dim_vec b) X)))"

lemma create_opt_sol_satisfies:
  assumes "create_optimal_solutions A b c = Sat X"
  shows "\<langle>X\<rangle> \<Turnstile>\<^sub>c\<^sub>s set ((x_times_c_geq_y_times_b c b # mat_leqb_eqc A b c @
                      from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b))))"
proof -
  have "simplex (x_times_c_geq_y_times_b c b # mat_leqb_eqc A b c @
        from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b))) = Sat X"
  proof (rule ccontr)
    assume "simplex (x_times_c_geq_y_times_b c b # mat_leqb_eqc A b c @ from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b))) \<noteq> Inr X"
    then have "\<exists>e. simplex (x_times_c_geq_y_times_b c b # mat_leqb_eqc A b c @ from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b))) = Unsat e"
      by (metis assms create_optimal_solutions.simps sum.case(2) sumE)
    then have "\<exists>e. create_optimal_solutions A b c = Unsat e"
      using assms option.split by force
    then show False using assms(1) assms by auto
  qed
  then show ?thesis using simplex(3) by blast
qed

lemma create_opt_sol_sat_leq_mat:
  assumes "dim_vec b = dim_row A"
  assumes "create_optimal_solutions A b c = Sat X"
    and "(x, y) = split_i_j_x (dim_col A) (dim_vec b) X"
  shows "[A *\<^sub>v x]\<le>b"
proof -
  have *: "\<langle>X\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (mat_leqb_eqc A b c)"
    using create_opt_sol_satisfies[of A b c X] sat_mono[of "(mat_leqb_eqc A b c)" _ X]
    using assms(2) by (metis append_Cons append_assoc in_set_conv_decomp)
  then show ?thesis using mat_leqb_eqc_split_correct1[of b A c X x y, OF assms(1) *] assms
    by blast
qed

lemma create_opt_sol_sat_eq_mat:
  assumes "dim_vec c = dim_row A\<^sup>T"
    and "dim_vec b = dim_col A\<^sup>T"
  assumes "create_optimal_solutions A b c = Sat X"
    and "(x, y) = split_i_j_x (dim_vec c) (dim_vec c + dim_vec b) X"
  shows "[y \<^sub>v* A]=c"
proof -
  have *: "\<langle>X\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (mat_leqb_eqc A b c)"
    using create_opt_sol_satisfies[of A b c X] sat_mono[of "(mat_leqb_eqc A b c)" _ X]
      assms(2) assms by (metis UnCI list.set_intros(2) set_append)
  have "dim_row A\<^sup>T = dim_vec c"
    using assms(1) by linarith
  moreover have "dim_col A\<^sup>T = dim_vec b"
    by (simp add: assms(2))
  ultimately show ?thesis
    using assms by (metis mat_leqb_eqc_split_correct2[of c A b X x y, OF assms(1) assms(2) *]
        \<open>dim_vec b = dim_col A\<^sup>T\<close> \<open>dim_vec c = dim_row A\<^sup>T\<close>)
qed

lemma create_opt_sol_satisfies_leq:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "x \<bullet> c \<ge> y \<bullet> b"
  using create_opt_sol_satisfies[of A b c X]
  by (metis assms(1) assms(2) carrier_vec_dim_vec comm_scalar_prod list.set_intros(1)
      split_n_m_x_abbrev_dims(2) split_vec_dims(1) x_times_c_geq_y_times_b_split_dotP)

lemma create_opt_sol_satisfies_geq0:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "\<And>i. i < dim_vec y \<Longrightarrow> y$i \<ge> 0"
proof -
  fix i
  assume "i < dim_vec y"
  have *: "\<langle>X\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (from_index_geq0_vector (dim_vec c) (0\<^sub>v (dim_vec b)))"
    using assms(1) create_opt_sol_satisfies by (metis UnCI append_Cons set_append)
  have **: "i < dim_vec b"
    by (metis \<open>i < dim_vec y\<close> assms(2) split_n_m_x_abbrev_dims(2))
  then show "0 \<le> y $ i"
    using from_index_geq0_vector_split_snd[of "dim_vec c" "0\<^sub>v (dim_vec b)" X x y
        "dim_vec b" i, OF * assms(2)] by simp
qed

locale rat_LP = abstract_LP A b c m n
  for A ::"rat mat"
    and b :: "rat vec"
    and c :: "rat vec"
    and m  :: "nat"
    and n  :: "nat"
begin

lemma create_opt_sol_in_LP:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "[A *\<^sub>v x]\<le>b" "[y \<^sub>v* A]=c" "x \<bullet> c \<ge> y \<bullet> b" "\<And>i. i < dim_vec y \<Longrightarrow> y$i \<ge> 0"
  apply (metis Pair_inject assms(1) assms(2) create_opt_sol_sat_leq_mat dim_b_col_A dim_b_row_A split_i_j_x_def)
  using assms(1) assms(2) create_opt_sol_sat_eq_mat dim_b_col_A dim_b_row_A
    apply (metis index_transpose_mat(2) index_transpose_mat(3))
  using assms(1) assms(2) create_opt_sol_satisfies_leq apply blast
  using assms(1) assms(2) create_opt_sol_satisfies_geq0 by blast

lemma create_optim_in_sols:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "c \<bullet> x \<in> {c \<bullet> x |x. [A *\<^sub>v x]\<le>b}"
    "b \<bullet> y \<in> {b \<bullet> y |y. [y \<^sub>v* A]=c \<and> (\<forall>i < dim_vec y. y$i \<ge> 0)}"
  using assms(1) assms(2) create_opt_sol_in_LP(1) apply blast
  using assms(1) assms(2) create_opt_sol_in_LP(2) create_opt_sol_in_LP(4) by blast

lemma cx_leq_bx_in_creating_opt:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "c \<bullet> x \<le> b \<bullet> y"
  using weak_duality_aux[of "c \<bullet> x" "b \<bullet> y"]  create_optim_in_sols[of X x y, OF assms] by auto

lemma min_max_for_sol:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "c \<bullet> x = b \<bullet> y"
  using create_opt_sol_in_LP(3)[of X x y, OF assms] cx_leq_bx_in_creating_opt[OF assms]
    comm_scalar_prod[of c "dim_vec c" x] comm_scalar_prod[of b "dim_vec b" y]
  by (metis add_diff_cancel_left' antisym assms(2) carrier_vec_dim_vec split_vec_dims(1) split_vec_dims(2))

lemma create_opt_solutions_correct:
  assumes "create_optimal_solutions A b c = Sat X"
  assumes "(x, y) = split_n_m_x (dim_vec c) (dim_vec b) X"
  shows "x \<in> max_lp A b c"
proof
  show "[A *\<^sub>v x]\<le>b"
    using assms(1) assms(2) create_opt_sol_in_LP(1) by blast
  fix z
  assume a: "[A *\<^sub>v z]\<le>b"
  have 1: "c \<bullet> z \<in> {c \<bullet> x |x. x \<in> sat_primal A b}"
    using sat_primalI[of A z b, OF a] by blast
  have 2: "b \<bullet> y \<in> {b \<bullet> y |y. y \<in> sat_dual A c}"
    using sat_dualI
    by (metis (mono_tags, lifting) assms(1) assms(2) create_opt_sol_in_LP(2)
        mem_Collect_eq rat_LP.create_opt_sol_in_LP(4) rat_LP_axioms)
  then have "c \<bullet> z \<le> b \<bullet> y"
    using weak_duality_aux[of "c \<bullet> z" "b \<bullet> y", OF 1 2] sat_primalI[of A z b, OF a] by blast
  also have "... = x \<bullet> c"
    by (metis assms(1) assms(2) carrier_vec_dim_vec comm_scalar_prod
        min_max_for_sol split_n_m_x_abbrev_dims(1))
  finally show "z \<bullet> c \<le> x \<bullet> c"
    by (metis a carrier_vec_dim_vec comm_scalar_prod dim_b_col_A mat_times_vec_leqD(2))
qed

lemma optimize_no_cond_correct:
  assumes "optimize_no_cond A b c = Sat x"
  shows "x \<in> max_lp A b c"
proof -
  obtain X where X: "create_optimal_solutions A b c = Sat X"
    by (metis Inr_Inl_False assms old.sum.exhaust old.sum.simps(5) optimize_no_cond.simps)
  have "x = (fst (split_n_m_x (dim_vec c) (dim_vec b) X))"
    using X assms by (metis old.sum.inject(2) old.sum.simps(6) optimize_no_cond.simps)
  then show ?thesis
    using create_opt_solutions_correct[of X x] by (metis X fst_conv old.prod.exhaust)
qed

lemma optimize_no_cond_sol_sat:
  assumes "optimize_no_cond A b c = Sat x"
  shows "x \<in> sat_primal A b"
  using max_lp_in_sat_primal[OF optimize_no_cond_correct[OF assms]] by auto

end (* end of \<open> rat_LP \<close> *)

fun maximize where
  "maximize A b c = (if dim_vec b = dim_row A \<and> dim_vec c = dim_col A then
                      Some (optimize_no_cond A b c)
                    else None)"

lemma optimize_sound:
  assumes "maximize A b c = Some (Sat x)"
  shows "x \<in> max_lp A b c"
proof -
  have *: "dim_vec b = dim_row A \<and> dim_vec c = dim_col A"
    by (metis assms maximize.simps option.distinct(1))
  then interpret rat: rat_LP A b c "dim_vec b" "dim_vec c"
    by (metis abstract_LP_def carrier_mat_triv carrier_vec_dim_vec rat_LP.intro)
  have "Sat x = optimize_no_cond A b c"
    using assms * by auto
  then show ?thesis
    by (simp add: rat.optimize_no_cond_correct)
qed

lemma maximize_option_elim:
  assumes "maximize A b c = Some x"
  shows "dim_vec b = dim_row A" "dim_vec c = dim_col A"
  by (metis assms maximize.simps option.distinct(1))+

lemma optimize_sol_dimension:
  assumes "maximize A b c = Some (Sat x)"
  shows "x \<in> carrier_vec (dim_col A)"
  using assms carrier_dim_vec max_lp_in_sat_primal optimize_sound sol_dim_in_sat_primal by blast

lemma optimize_sat:
  assumes "maximize A b c = Some (Sat x)"
  shows "[A *\<^sub>v x]\<le>b"
  using assms maximize_option_elim[OF assms]
    max_lp_in_sat_primal[OF optimize_sound[of A b c x, OF assms]] by blast

derive (eq) ceq rat
derive (linorder) compare rat
derive (compare) ccompare rat
derive (rbt) set_impl rat

derive (eq) ceq atom QDelta
derive (linorder) compare_order QDelta
derive compare_order atom
derive ccompare atom QDelta
derive (rbt) set_impl atom QDelta

(*export_code maximize mat_of_cols_list mat_of_rows_list mat_of_cols vec_of_list quotient_of Inr Inl Some None list_of_vec nat
Rat.Fract int_of_integer in Haskell module_name LP  file "/home/julian/coding/ForGET/LPBenchmarks/HaskellLP/src"
*)
(*
export_code  maximize mat_of_cols_list mat_of_rows_list mat_of_cols vec_of_list quotient_of Inr Inl Some None list_of_vec nat
Rat.Fract int_of_integer in Scala
*)

(*
section \<open> Testing \<close>
lemma "(let A = mat_of_rows 3 (map vec_of_list [[1, 12, 2], [1, 5, 9], [-1,0,0], [0,-1,0],[0,0,-1]]) in
       (let b = vec_of_list [10000, 8539,0,0,0] in
       (let c = vec_of_list [100, 600, 400] in
       maximize A b c))) =  Some (Inr (vec_of_list [52468 / 7, 1461 / 7, 0]))"
  by eval

lemma "(let A = mat_of_cols 4 (map vec_of_list [[2::rat, -1, -1, 1/2], [1, 2, -1, -1/2]]) in
       (let b = vec_of_list [5, 2, -1, 1/2] in
       (let c = vec_of_list [7, 1::rat] in
       maximize A b c))) = Some (Inr (vec_of_list [2::rat, 1]))"
  by eval
*)

(*
value "(let A = mat_of_cols_list 4 [[-1::rat, -1, -0, 1], [1, -1, -1, -2]] in
       (let b = vec_of_list [1, -2, -0, 4] in
       (let c = vec_of_list [-2, 1::rat] in
       maximize A b c)))"

value "(let A = mat_of_cols 4 (map vec_of_list [[2::rat, 2, -1, 0], [3, 1, 0, -1]]) in
       (let b = vec_of_list [1500::rat,1000,0,0] in
       (let c = vec_of_list [50, 40::rat] in
       maximize A b c)))"
 (*  Sol should be 375, 250 *)

value "(let A = mat_of_cols 2 (map vec_of_list [[-1::rat, 1], [-1,-1]]) in
       (let b = vec_of_list [2::rat, 2] in
       (let c = vec_of_list [0, 1::rat] in
       maximize A b c)))"
  (* Sol should be 375, 250 *)

value "(let A = mat_of_rows 2 (map vec_of_list [[2::rat,3],[2, 1], [-1,0],[0,-1]]) in
       (let b = vec_of_list [1500::rat,1000,0,0] in
       (let c = vec_of_list [50, 40::rat] in
       maximize A b c)))"
  (* Sol should be 375, 250 *)
*)

lemma of_rat_val: "simplex cs = (Sat v) \<Longrightarrow> of_rat_val \<langle>v\<rangle> \<Turnstile>\<^sub>r\<^sub>c\<^sub>s set cs"
  using of_rat_val_constraint simplex_real(3) by blast

end


theory ConjPredicateTransformers
  imports MonoPredicateTransformers
begin

definition conjunctive :: "('a :: bbi \<Rightarrow> 'b :: bbi) \<Rightarrow> bool" where
  "conjunctive f \<equiv> \<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y"

definition comp_conjunctive :: "('a :: bbi \<Rightarrow> 'b :: bbi) \<Rightarrow> bool" where
  "comp_conjunctive f \<equiv> \<forall>X. f (\<Sqinter>X) = \<Sqinter>{f x | x. x \<in> X}"

lemma comp_conj_conjI: "comp_conjunctive f \<Longrightarrow> conjunctive f"
proof (auto simp: comp_conjunctive_def conjunctive_def)
  fix x y assume "\<forall>X. f (\<Sqinter>X) = \<Sqinter>{f x | x. x \<in> X}"
  hence "f (\<Sqinter>{x, y}) = \<Sqinter>{f z |z. z \<in> {x, y}}" by metis
  thus "f (x \<sqinter> y) = f x \<sqinter> f y"
    by (auto intro!: Inf_eqI) metis+
qed

lemma conj_mono[dest?]: "conjunctive F \<Longrightarrow> mono F"
  by (auto simp add: mono_def conjunctive_def) (metis le_iff_inf)

lemma conj_conj_mono[dest?]: "comp_conjunctive F \<Longrightarrow> mono F"
  by (auto intro: comp_conj_conjI conj_mono)

text {* Closed operations *}

lemma comp_conjunctive_skip [simp,intro]: "comp_conjunctive id"
  by (simp add: comp_conjunctive_def)

lemma comp_conjunctive_comp_clos [intro]: "\<lbrakk>comp_conjunctive (F :: 'a :: bbi \<Rightarrow> 'a); comp_conjunctive (G :: 'a :: bbi \<Rightarrow> 'a)\<rbrakk> \<Longrightarrow> comp_conjunctive (F o G)"
  by (auto simp: comp_conjunctive_def intro!: Inf_eqI Inf_lower Inf_greatest) force

lemma comp_conjunctive_magic [simp,intro]: "comp_conjunctive \<top>"
  by (simp add: comp_conjunctive_def)

lemma comp_conjunctive_inf_clos [intro]: "\<lbrakk>comp_conjunctive F; comp_conjunctive G\<rbrakk> \<Longrightarrow> comp_conjunctive (F \<sqinter> G)"
  apply (auto simp: comp_conjunctive_def intro!: Inf_eqI[symmetric])
  apply (rule le_infI1, auto intro!: Inf_lower Inf_greatest)
  by (auto intro!: le_infI2 Inf_lower)

text {* Meet and top are not closed under complete additivity *}

lemma comp_conjunctive_sup_clos [intro]: "\<lbrakk>comp_conjunctive F; comp_conjunctive G\<rbrakk> \<Longrightarrow> comp_conjunctive (F + G)"
  (* nitpick *) oops

lemma comp_conjunctive_abort [simp,intro]: "comp_conjunctive \<bottom>"
  (* nitpick *) oops

lemma comp_conjunctive_Inf_clos [intro]: "\<forall>f \<in> F. comp_conjunctive f \<Longrightarrow> comp_conjunctive (\<Sqinter>F)"
proof (simp add: comp_conjunctive_def, rule allI)
  fix X
  assume assm: "\<forall>f \<in> F. \<forall>X. f (\<Sqinter>X) = \<Sqinter>{f x |x. x \<in> X}"
  hence "(INF f:F. f (\<Sqinter>X)) = (INF f:F. \<Sqinter> {f x| x. x \<in> X})"
    by (auto intro: INF_cong)
  also have "... = \<Sqinter> {(INF f:F. f x) | x. x \<in> X}"
    apply (auto intro!: INF_eqI)
    apply (rule Inf_mono)
    apply auto
    apply (rule_tac x="(INF f:F. f x)" in exI)
    apply auto
    apply (rule INF_lower)
    apply simp
    apply (rule Inf_greatest)
    apply auto
    apply (rule INF_greatest)
    apply (subgoal_tac "\<Sqinter>{f x |x. x \<in> X} \<le> f xa")
    apply force
    apply (rule Inf_lower)
    by auto
  finally show "(INF f:F. f (\<Sqinter>X)) = \<Sqinter>{INF f:F. f x |x. x \<in> X}"
    by auto
qed

text {* Type of conjunctive predicate transformers *}

typedef 'a ctran = "{F:: 'a :: bbi \<Rightarrow> 'a. comp_conjunctive F}"
  by (rule_tac x=id in exI) (auto simp: comp_conjunctive_def)
setup_lifting type_definition_ctran

text {* Every conjunctive predicate transformer is a monotonic one *}

lemma "\<forall>(F :: 'a :: bbi ctran). \<exists>(G :: 'a mtran). Rep_mtran G = Rep_ctran F"
  by transfer (auto intro: conj_conj_mono)

text {* Morphism between conjunctive to monotonic predicate transformers *}

lift_definition mptran :: "'a :: bbi ctran \<Rightarrow> 'a mtran" is "\<lambda>F. F"
  by (metis conj_conj_mono)

text {* The order in the semilattice is inversed *}

instantiation ctran :: (bbi) bounded_semilattice_sup_bot
begin
lift_definition bot_ctran :: "'a ctran" is \<top> ..
lift_definition less_eq_ctran:: "'a ctran \<Rightarrow> 'a ctran \<Rightarrow> bool" is "op \<ge>" .
lift_definition less_ctran :: "'a ctran \<Rightarrow> 'a ctran \<Rightarrow> bool" is "op >" .
lift_definition sup_ctran :: "'a ctran \<Rightarrow> 'a ctran \<Rightarrow> 'a ctran" is inf ..
instance
  by default (transfer, auto)+
end

text {* Complete conjunctive predicate transformers form a complete join-semilattice*}

instantiation ctran :: (bbi) Sup
begin
lift_definition Sup_ctran :: "'a ctran set \<Rightarrow> 'a ctran" is Inf by auto
instance ..
end

text {*
  All complete join semilattice for a complete lattice.
  Note that meet and top are different from the complete lattice formed by ptran
*}

instantiation ctran :: (bbi) complete_lattice
begin

definition "\<Sqinter>(F :: 'a ctran set) \<equiv> \<Squnion>{g. \<forall>f \<in> F. g \<le> f}"
definition "\<top> :: 'a ctran \<equiv> \<Sqinter>{}"
definition "(F :: 'a ctran) \<sqinter> G \<equiv> \<Sqinter>{F, G}"

instance
  apply (default, simp_all add: inf_ctran_def Inf_ctran_def top_ctran_def)
  by (transfer, auto intro: Sup_least Sup_upper Inf_greatest Inf_lower)+
end

text {*
  It forms a monoid
*}

instantiation ctran :: (bbi) monoid_mult
begin
lift_definition one_ctran :: "'a ctran" is "id" ..
lift_definition times_ctran :: "'a ctran \<Rightarrow> 'a ctran \<Rightarrow> 'a ctran" is "op o" ..
instance
  by default (transfer, auto)+
end

text {*
  It forms a Quantale
*}

instance ctran :: (bbi) near_quantale
  by default (transfer, auto)

instance ctran :: (bbi) near_quantale_unital ..

instance ctran :: (bbi) pre_quantale
  apply default
  apply transfer
  apply (rule le_funI)
  apply (simp add: comp_conjunctive_def)
  apply (unfold INF_def)
  apply (erule_tac x="((\<lambda>f. f xa) ` Y)" in allE)
  apply simp
  apply (rule INF_greatest)
  apply (rule Inf_lower)
  by auto

instance ctran :: (bbi) quantale
  apply default
  apply transfer
  apply (rule le_funI)
  apply (simp add: comp_conjunctive_def)
  apply (unfold INF_def)
  apply (erule_tac x="((\<lambda>f. f xa) ` Y)" in allE)
  apply simp
  apply (rule Inf_greatest)
  apply (unfold INF_def)
  apply (rule Inf_lower)
  by auto

instance ctran :: (bbi) quantale_unital ..

end


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

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "Nat => Nat" where
  "nmsorttdhalf1 x =
   (if (x = (S Z)) then Z else
      (case x of
         Z => Z
         | S y => plus (S Z) (nmsorttdhalf1 (minus x (S (S Z))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function nmsorttd :: "Nat list => Nat list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (nmsorttd xs) xs"
  oops

end


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

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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ssortminimum1 :: "Nat => Nat list => Nat" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if le y1 x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

(*fun did not finish the proof*)
function ssort :: "Nat list => Nat list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: Nat = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: Nat) => % (x2 :: Nat) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "((ssort xs) = (isort xs))"
  oops

end


(*
  File:     Anonymous_PAPP_Lowering.thy
  Author:   Manuel Eberl, University of Innsbruck
*)
section \<open>Lowering P-APP Rules to Smaller Settings\<close>
theory Anonymous_PAPP_Lowering
  imports Anonymous_PAPP
begin

text \<open>
  In this section, we prove a number of lemmas (corresponding to Lemma~1 in the paper) that allow
  us to take an anonymous P-APP rule with some additional properties (typically
  Cardinality-Strategyproofness and Weak Representation or Weak Proportional Representation) and
  construct from it an anonymous P-APP rule for a different setting, i.e.\ different number of
  voters, parties, and/or result committee size.

  In the reverse direction, this also allows us to lift impossibility results from one setting
  to another.
\<close>

subsection \<open>Preliminary Lemmas\<close>

context card_stratproof_anon_papp
begin

text \<open>
  The following lemma is obtained by applying Strategyproofness repeatedly. It shows that
  if we have \<open>l\<close> voters with identical approval lists, then this entire group of voters has no
  incentive to submit wrong preferences. That is, the outcome they obtain by submitting their
  genuine approval lists is weakly preferred by them over all outcomes obtained where these \<open>l\<close>
  voters submit any other preferences (and the remaining $n - l$ voters submit the same preferences
  as before).

  This is stronger than regular Strategyproofness, where we only demand that no voter has an
  incentive to submit wrong preferences \<^emph>\<open>unilaterally\<close> (and everyone else keeps the same
  preferences). Here we know that the entire group of \<open>l\<close> voters has no incentive to submit
  wrong preferences in coordination with one another.
\<close>
lemma proposition2:
  assumes "size B = l" "size A + l = n_voters"
  assumes "X \<noteq> {}" "X \<subseteq> parties" "{} \<notin># A+B" "\<forall>X'\<in>#A+B. X' \<subseteq> parties"
  shows   "r (replicate_mset l X + A) \<succeq>[Comm(X)] r (B + A)"
  using assms
proof (induction l arbitrary: A B)
  case 0
  thus ?case
    by simp
next
  case (Suc l A B)
  from Suc.prems have "set_mset B \<noteq> {}"
    by auto
  then obtain Y where Y: "Y \<in># B"
    by blast
  define B' where "B' = B - {#Y#}"
  define A' where "A' = A + {#Y#}"
  have [simp]: "size B' = l"
    using Suc.prems Y by (simp add: B'_def size_Diff_singleton)
  have [simp]: "size A' = n_voters - l"
    using Suc.prems Y by (simp add: A'_def)

  have "r (B' + A') \<preceq>[Comm(X)] r (replicate_mset l X + A')"
    by (rule Suc.IH) (use Suc.prems Y in \<open>auto simp: A'_def B'_def size_Diff_singleton\<close>)
  also have "B' + A' = B + A"
    using Y by (simp add: B'_def A'_def)
  also have "r (replicate_mset l X + A') \<preceq>[Comm(X)] r (replicate_mset (Suc l) X + A)"
  proof (rule not_manipulable'')
    show "replicate_mset (Suc l) X + A + {#Y#} = replicate_mset l X + A' + {#X#}"
      by (simp add: A'_def)
  next
    show "is_pref_profile (replicate_mset (Suc l) X + A)"
     using Suc.prems by unfold_locales (auto split: if_splits)
  next
    show "is_pref_profile (replicate_mset l X + A')"
      using Suc.prems Y by unfold_locales (auto split: if_splits simp: A'_def)
  qed
  finally show ?case .
qed

end

context card_stratproof_weak_rep_anon_papp
begin

text \<open>
  In a setting with Weak Representation and Cardinality-Strategyproofness, Proposition 2 allows
  us to strengthen Weak Representation in the following way: Suppose we at least
  $l \lfloor n/k\rfloor$ voters with the same approval list \<open>X\<close>, and \<open>X\<close> consists of at least \<open>l\<close>
  parties. Then at least \<open>l\<close> of the members of the result committee are in \<open>X\<close>.
\<close>
lemma proposition3:
  assumes "is_pref_profile A" "X \<subseteq> parties" "card X \<ge> l"
  assumes "committee_size > 0"
  assumes "count A X \<ge> l * \<lceil>n_voters / committee_size\<rceil>"
  shows   "size {# x\<in># r A. x \<in> X #} \<ge> l"
  using assms
proof (induction l arbitrary: A X rule: less_induct)
  case (less l A X)
  interpret A: anon_papp_profile n_voters parties committee_size A
    by fact
  consider "l = 0" | "l = 1" | "l > 1"
    by force
  thus ?case
  proof cases
    assume "l = 0"
    thus ?thesis by simp
  next
    assume [simp]: "l = 1"
    define n where "n = count A X"
    with less.prems have "X \<noteq> {}"
      by auto
    then obtain x where x: "x \<in> X"
      by blast
    have "n \<le> size A"
      unfolding n_def by (rule count_le_size)
    hence "n \<le> n_voters"
      by (simp add: A.size_A)

    have "count A X > 0"
      by (rule Nat.gr0I) (use n_voters_pos less.prems in \<open>auto simp: field_simps\<close>)
    hence "X \<in># A"
      by force
    have [simp]: "replicate_mset n X \<subseteq># A"
      by (simp add: n_def flip: count_le_replicate_mset_subset_eq)

    define A'' where "A'' = A - replicate_mset n X"
    define A' where "A' = A'' + replicate_mset n {x}"
    interpret A': anon_papp_profile n_voters parties committee_size A'
      using A.A_nonempty A.A_subset A.size_A x \<open>X \<in># A\<close>
      by unfold_locales
         (fastforce simp: A'_def A''_def size_Diff_submset subset_mset.add_increasing2
                    split: if_splits dest!: in_diffD)+

    have "x \<in># r A'"
    proof (rule weak_representation)
      show "is_pref_profile A'"
        by (fact A'.anon_papp_profile_axioms)
    next
      have "n_voters \<le> committee_size * n"
        using less.prems by (simp add: n_def ceiling_le_iff field_simps flip: of_nat_mult)
      also have "n \<le> count A' {x}"
        by (simp add: A'_def)
      finally show "n_voters \<le> committee_size * count A' {x}"
        by simp
    qed
    hence "1 \<le> count (r A') x"
      by simp
    also have "\<dots> = size {# y \<in># r A'. y = x #}"
      by simp
    also have "\<dots> \<le> size {# y \<in># r A'. y \<in> X #}"
      by (intro size_mset_mono multiset_filter_mono') (use x in auto)

    also have "r A' \<preceq>[Comm(X)] r A"
    proof -
      have "r (replicate_mset n {x} + A'') \<preceq>[Comm(X)] r (replicate_mset n X + A'')"
      proof (rule proposition2)
        show "{} \<notin># A'' + replicate_mset n {x}"
          using A'.A_nonempty by (auto simp: A'_def)
        show "\<forall>X'\<in>#A'' + replicate_mset n {x}. X' \<subseteq> parties"
          using A'.A_subset x by (auto simp: A'_def dest: in_diffD)
        show "size A'' + n = n_voters"
          using \<open>n \<le> n_voters\<close> by (auto simp: A''_def size_Diff_submset A.size_A)
      qed (use less.prems in auto)
      also have "replicate_mset n X + A'' = A"
        by (simp add: A''_def n_def flip: count_le_replicate_mset_subset_eq)
      finally show ?thesis
        by (simp add: A'_def add_ac)
    qed
    hence "size {# y \<in># r A'. y \<in> X #} \<le> size {# y \<in># r A. y \<in> X #}"
      by (simp add: committee_preference_def)

    finally show ?thesis
      by simp

  next
    assume l: "l > 1"

    define n where "n = count A X"
    have "n \<le> size A"
      unfolding n_def by (rule count_le_size)
    hence "n \<le> n_voters"
      by (simp add: A.size_A)

    define m where "m = nat (ceiling (n_voters / committee_size))"
    have "n_voters / committee_size \<le> m"
      unfolding m_def by linarith
    hence m: "n_voters \<le> committee_size * m"
      using \<open>committee_size > 0\<close> by (simp add: field_simps flip: of_nat_mult)
    have "real n_voters / real committee_size > 0"
      using n_voters_pos less.prems by auto
    hence m': "\<lceil>real n_voters / real committee_size\<rceil> = int m"
      by (simp add: m_def)
    have "1 * m \<le> l * m"
      using l by (intro mult_right_mono) auto
    also have "l * m \<le> n"
      using less.prems by (simp add: m' n_def flip: of_nat_mult)
    finally have "m \<le> n"
      by simp

    with less.prems l have "X \<noteq> {}"
      by auto
    then obtain x where x: "x \<in> X"
      by blast
    have "card (X - {x}) > 0"
      using less.prems x l by simp
    hence "X - {x} \<noteq> {}"
      by force

    have "count A X > 0"
      by (rule Nat.gr0I) (use n_voters_pos less.prems l in \<open>auto simp: field_simps mult_le_0_iff\<close>)
    hence "X \<in># A"
      by force
    have [simp]: "replicate_mset n X \<subseteq># A"
      by (simp add: n_def flip: count_le_replicate_mset_subset_eq)

    define A'' where "A'' = A - replicate_mset n X"
    define A' where "A' = A'' + replicate_mset m {x} + replicate_mset (n - m) (X - {x})"
    interpret A': anon_papp_profile n_voters parties committee_size A'
    proof
      show "Y \<subseteq> parties" if "Y \<in># A'" for Y
        using that A.A_subset x \<open>X \<in># A\<close>
        by (fastforce simp: A'_def A''_def dest!: in_diffD split: if_splits)
    next
      show "{} \<notin># A'"
        using A.A_nonempty x \<open>X \<in># A\<close> \<open>X - {x} \<noteq> {}\<close>
        by (auto simp: A'_def A''_def dest!: in_diffD split: if_splits)
    next
      show "size A' = n_voters"
        using \<open>m \<le> n\<close>
        by (auto simp: A'_def A''_def A.size_A subset_mset.add_increasing2 size_Diff_submset)
    qed

    have "x \<in># r A'"
    proof (rule weak_representation)
      show "is_pref_profile A'"
        by (fact A'.anon_papp_profile_axioms)
    next
      have "n_voters \<le> committee_size * m"
        by (fact m)
      also have "m \<le> count A' {x}"
        by (simp add: A'_def)
      finally show "n_voters \<le> committee_size * count A' {x}"
        by simp
    qed
    hence "1 \<le> count (r A') x"
      by simp
    also have "\<dots> = size {# y \<in># r A'. y = x #}"
      by simp
    finally have 1: "size {#y \<in># r A'. y = x#} \<ge> 1" .

    have 2: "size {# y \<in># r A'. y \<in> X - {x} #} \<ge> l - 1"
    proof (rule less.IH)
      have "int (l - 1) * \<lceil>real n_voters / real committee_size\<rceil> = int ((l - 1) * m)"
        by (auto simp add: m' not_less)
      also have "(l - 1) * m = l * m - m"
        by (simp add: algebra_simps)
      also have "l * m \<le> n"
        using less.prems by (simp add: m' n_def flip: of_nat_mult)
      hence "l * m - m \<le> n - m"
        by (meson diff_le_mono)
      also have "n - m \<le> count A' (X - {x})"
        by (simp add: A'_def A''_def)
      finally show "int (l - 1) * \<lceil>real n_voters / real committee_size\<rceil> \<le> int (count A' (X - {x}))"
        by simp
    qed (use l A'.anon_papp_profile_axioms x less.prems in \<open>auto\<close>)

    have "1 + (l - 1) \<le> size {#y \<in># r A'. y = x#} + size {#y \<in># r A'. y \<in> X - {x}#}"
      by (intro add_mono 1 2)
    also have "\<dots> = size ({#y \<in># r A'. y = x#} + {#y \<in># r A'. y \<in> X - {x}#})"
      by simp
    also have "{#y \<in># r A'. y = x#} + {#y \<in># r A'. y \<in> X - {x}#} =
               {#y \<in># r A'. y = x \<or> y \<in> X - {x}#}"
      by (rule filter_mset_disjunction [symmetric]) auto
    also have "(\<lambda>y. y = x \<or> y \<in> X - {x}) = (\<lambda>y. y \<in> X)"
      using x by auto
    also have "1 + (l - 1) = l"
      using l by simp

    also have "r A' \<preceq>[Comm(X)] r A"
    proof -
      have "r (replicate_mset m {x} + replicate_mset (n - m) (X - {x}) + A'') \<preceq>[Comm(X)]
            r (replicate_mset n X + A'')"
      proof (rule proposition2)
        show " {} \<notin># A'' + (replicate_mset m {x} + replicate_mset (n - m) (X - {x}))"
          using A'.A_nonempty by (auto simp: A'_def)
        show "\<forall>X'\<in># A'' + (replicate_mset m {x} + replicate_mset (n - m) (X - {x})). X' \<subseteq> parties"
          using A'.A_subset x by (auto simp: A'_def dest: in_diffD)
        show "size A'' + n = n_voters"
          using \<open>n \<le> n_voters\<close> by (auto simp: A''_def size_Diff_submset A.size_A)
      qed (use less.prems l \<open>m \<le> n\<close> in auto)
      also have "replicate_mset n X + A'' = A"
        by (simp add: A''_def n_def flip: count_le_replicate_mset_subset_eq)
      finally show ?thesis
        by (simp add: A'_def add_ac)
    qed
    hence "size {# y \<in># r A'. y \<in> X #} \<le> size {# y \<in># r A. y \<in> X #}"
      by (simp add: committee_preference_def)

    finally show ?thesis
      by simp
  qed
qed

end

subsection \<open>Dividing the number of voters\<close>

text \<open>
  If we have a PAPP rule that satisfies weak representation and cardinality strategyproofness,
  for $ln$ voters, we can turn it into one for \<open>n\<close> voters.
  This is done by simply cloning each voter \<open>l\<close> times.

  Consequently, if we have an impossibility result for $n$ voters, it also holds for any
  integer multiple of \<open>n\<close>.
\<close>
locale divide_voters_card_stratproof_weak_rep_anon_papp =
  card_stratproof_weak_rep_anon_papp "l * n_voters" parties committee_size r
  for l n_voters parties committee_size r
begin

definition lift_profile :: "'a set multiset \<Rightarrow> 'a set multiset" where
  "lift_profile A = (\<Sum>X\<in>#A. replicate_mset l X)"

sublocale lowered: anon_papp_election n_voters parties
  by standard (use n_voters_pos in auto)

lemma l_pos: "l > 0"
  using n_voters_pos by auto

lemma empty_in_lift_profile_iff [simp]: "{} \<in># lift_profile A \<longleftrightarrow> {} \<in># A"
  using l_pos by (auto simp: lift_profile_def)

lemma set_mset_lift_profile [simp]: "set_mset (lift_profile A) = set_mset A"
  using l_pos by (auto simp: lift_profile_def)

lemma size_lift_profile: "size (lift_profile A) = l * size A"
  by (simp add: size_mset_sum_mset lift_profile_def image_mset.compositionality o_def)

lemma count_lift_profile [simp]: "count (lift_profile A) x = l * count A x"
  unfolding lift_profile_def by (induction A) auto

lemma is_pref_profile_lift_profile [intro]:
  assumes "lowered.is_pref_profile A"
  shows   "is_pref_profile (lift_profile A)"
proof -
  interpret anon_papp_profile n_voters parties committee_size A
    by fact
  show ?thesis
    using A_nonempty A_subset size_A
    by unfold_locales
       (auto simp: lift_profile_def size_mset_sum_mset image_mset.compositionality o_def)
qed

sublocale lowered: anon_papp n_voters parties committee_size "r \<circ> lift_profile"
proof
  fix A assume "lowered.is_pref_profile A"
  hence "is_pref_profile (lift_profile A)"
    by blast
  hence "is_committee (r (lift_profile A))"
    using rule_wf by blast
  thus "lowered.is_committee ((r \<circ> lift_profile) A)"
    by simp
qed

sublocale lowered: weak_rep_anon_papp n_voters parties committee_size "r \<circ> lift_profile"
proof
  fix A x
  assume A: "lowered.is_pref_profile A" and x: "n_voters \<le> committee_size * count A {x}"
  from A have A': "is_pref_profile (lift_profile A)"
    by blast
  from x have "l * n_voters \<le> l * (committee_size * count A {x})"
    by (rule mult_left_mono) auto
  also have "\<dots> = committee_size * count (lift_profile A) {x}"
    by simp
  finally have "x \<in># r (lift_profile A)"
    by (intro weak_representation A')
  thus "x \<in># (r \<circ> lift_profile) A"
    by simp
qed

sublocale lowered: card_stratproof_anon_papp n_voters parties committee_size "r \<circ> lift_profile"
proof
  fix A X Y
  show "\<not>lowered.card_manipulable A X Y"
    unfolding lowered.card_manipulable_def
  proof (rule notI, elim conjE)
    assume A: "lowered.is_pref_profile A" and XY: "X \<in># A" "Y \<noteq> {}" "Y \<subseteq> parties"
    assume *: "(r \<circ> lift_profile) A \<prec>[lowered.committee_preference X]
               (r \<circ> lift_profile) (A - {#X#} + {#Y#})"
    interpret anon_papp_profile n_voters parties committee_size A
      by fact
    have X: "X \<noteq> {}" "X \<subseteq> parties"
      using XY A_nonempty A_subset by auto

    define A' where "A' = A - {#X#}"
    have A': "A = A' + {#X#}"
      using XY by (simp add: A'_def)

    have "r (lift_profile A) \<prec>[committee_preference X]
          r (lift_profile (A - {#X#} + {#Y#}))"
      using * by simp
    also have "r (lift_profile (A - {#X#} + {#Y#})) \<preceq>[committee_preference X]
               r (lift_profile A - {#X#} + {#Y#})"
    proof -
      have "r (replicate_mset (l - 1) Y + (lift_profile A' + {#Y#})) \<preceq>[committee_preference X]
            r (replicate_mset (l - 1) X + (lift_profile A' + {#Y#}))"
      proof (rule proposition2)
        show "size (lift_profile A' + {#Y#}) + (l - 1) = l * n_voters"
          using XY l_pos n_voters_pos
          by (simp add: A'_def size_lift_profile size_Diff_singleton
                        algebra_simps Suc_diff_le size_A)
      next
        show "{} \<notin># lift_profile A' + {#Y#} + replicate_mset (l - 1) Y"
          using XY A_nonempty by (auto simp: A'_def dest: in_diffD)
      next
        show "\<forall>X'\<in>#lift_profile A' + {#Y#} + replicate_mset (l - 1) Y. X' \<subseteq> parties"
          using XY A_subset by (auto simp: A'_def dest: in_diffD)
      qed (use X in auto)
      thus ?thesis
        by (simp add: A' replicate_mset_rec l_pos lift_profile_def)
    qed
    finally have "card_manipulable (lift_profile A) X Y"
      unfolding card_manipulable_def using XY A by auto
    with not_manipulable show False
      by blast
  qed
qed

sublocale lowered: card_stratproof_weak_rep_anon_papp n_voters parties committee_size "r \<circ> lift_profile"
  ..

end

locale divide_voters_card_stratproof_weak_prop_rep_anon_papp =
  card_stratproof_weak_prop_rep_anon_papp "l * n_voters" parties committee_size r
  for l n_voters parties committee_size r
begin

sublocale divide_voters_card_stratproof_weak_rep_anon_papp ..

sublocale lowered: card_stratproof_weak_prop_rep_anon_papp
  n_voters parties committee_size "r \<circ> lift_profile"
proof
  fix A x l'
  assume A: "lowered.is_pref_profile A" and x: "l' * n_voters \<le> committee_size * count A {x}"
  from A have A': "is_pref_profile (lift_profile A)"
    by blast
  from x have "l * (l' * n_voters) \<le> l * (committee_size * count A {x})"
    by (rule mult_left_mono) auto
  also have "\<dots> = committee_size * count (lift_profile A) {x}"
    by simp
  also have "l * (l' * n_voters) = l' * (l * n_voters)"
    by (simp add: algebra_simps)
  finally have "count (r (lift_profile A)) x \<ge> l'"
    by (intro weak_proportional_representation A')
  thus "count ((r \<circ> lift_profile) A) x \<ge> l'"
    by simp
qed

end

subsection \<open>Decreasing the number of parties\<close>

text \<open>
  If we have a PAPP rule that satisfies weak representation and cardinality strategyproofness,
  for $m$ parties, we can turn it into one for $m-1$ parties. This is done by simply
  duplicating one particular party (say \<open>x\<close>) in the preference profile, i.e.\ whenever
  \<open>x\<close> is part of an approval list, we add a clone of \<open>x\<close> (say \<open>y\<close>) as well. Should \<open>y\<close> then end up
  in the committee, we simply replace it with \<open>x\<close>.

  Consequently, if we have an impossibility result for $k$ parties, it also holds for
  $\geq m$ parties.
\<close>
locale remove_alt_card_stratproof_weak_rep_anon_papp =
  card_stratproof_weak_rep_anon_papp n_voters parties committee_size r
  for n_voters and parties :: "'a set" and committee_size r +
  fixes x y :: 'a
  assumes xy: "x \<in> parties" "y \<in> parties" "x \<noteq> y"
begin

definition lift_applist :: "'a set \<Rightarrow> 'a set" where
  "lift_applist X = (if x \<in> X then insert y X else X)"

definition lift_profile :: "'a set multiset \<Rightarrow> 'a set multiset" where
  "lift_profile A = image_mset lift_applist A"

definition lower_result where "lower_result C = image_mset (\<lambda>z. if z = y then x else z) C"

definition lowered where "lowered = lower_result \<circ> r \<circ> lift_profile"

lemma lift_profile_empty [simp]: "lift_profile {#} = {#}"
  by (simp add: lift_profile_def)

lemma lift_profile_add_mset [simp]:
  "lift_profile (add_mset X A) = add_mset (lift_applist X) (lift_profile A)"
  by (simp add: lift_profile_def)

lemma empty_in_lift_profile_iff [simp]: "{} \<in># lift_profile A \<longleftrightarrow> {} \<in># A"
  by (auto simp: lift_applist_def lift_profile_def)

lemma size_lift_profile [simp]: "size (lift_profile A) = size A"
  by (simp add: lift_profile_def)

lemma lift_applist_eq_self_iff [simp]: "lift_applist X = X \<longleftrightarrow> x \<notin> X \<or> y \<in> X"
  by (auto simp: lift_applist_def)

lemma lift_applist_eq_self_iff' [simp]: "lift_applist (X - {y}) = X \<longleftrightarrow> (x \<in> X \<longleftrightarrow> y \<in> X)"
  by (cases "y \<in> X") (auto simp: lift_applist_def xy)

lemma in_lift_applist_iff: "z \<in> lift_applist X \<longleftrightarrow> z \<in> X \<or> (z = y \<and> x \<in> X)"
  by (auto simp: lift_applist_def)

lemma count_lift_profile:
  assumes "\<forall>Y\<in>#A. y \<notin> Y"
  shows   "count (lift_profile A) X = (if x \<in> X \<longleftrightarrow> y \<in> X then count A (X - {y}) else 0)"
  using assms xy by (induction A) (auto simp: lift_applist_def)

lemma y_notin_lower_result [simp]: "y \<notin># lower_result C"
  using xy by (auto simp: lower_result_def)

lemma lower_result_subset: "set_mset (lower_result C) \<subseteq> insert x (set_mset C - {y})"
  using xy by (auto simp: lower_result_def)

lemma lower_result_subset': "set_mset C \<subseteq> parties \<Longrightarrow> set_mset (lower_result C) \<subseteq> parties"
  using xy by (auto simp: lower_result_def)

lemma size_lower_result [simp]: "size (lower_result C) = size C"
  by (simp add: lower_result_def)

lemma count_lower_result:
  "count (lower_result C) z =
     (if z = y then 0
      else if z = x then count C x + count C y
      else count C z)"
  using xy by (induction C) (auto simp: lower_result_def)

lemma in_lower_result_iff:
  "z \<in># lower_result C \<longleftrightarrow> z \<noteq> y \<and> (z \<in># C \<or> (z = x \<and> y \<in># C))"
  unfolding lower_result_def using xy by (induction C) auto

sublocale lowered: anon_papp_election n_voters "parties - {y}"
  by standard (use n_voters_pos xy in auto)

lemma is_pref_profile_lift_profile [intro]:
  assumes "lowered.is_pref_profile A"
  shows   "is_pref_profile (lift_profile A)"
proof -
  interpret anon_papp_profile n_voters "parties - {y}" committee_size A
    by fact
  show ?thesis
    using A_nonempty A_subset size_A
    by unfold_locales
       (auto simp: lift_profile_def lift_applist_def xy
                   size_mset_sum_mset image_mset.compositionality o_def)
qed

sublocale lowered: anon_papp n_voters "parties - {y}" committee_size lowered
proof
  fix A assume "lowered.is_pref_profile A"
  hence "is_pref_profile (lift_profile A)"
    by blast
  hence "is_committee (r (lift_profile A))"
    using rule_wf by blast
  thus "lowered.is_committee (lowered A)"
    unfolding lowered.is_committee_def is_committee_def lowered_def
    using lower_result_subset'[of "r (lift_profile A)"] by auto
qed

sublocale lowered: weak_rep_anon_papp n_voters "parties - {y}" committee_size lowered
proof
  fix A z
  assume A: "lowered.is_pref_profile A" and z: "n_voters \<le> committee_size * count A {z}"
  interpret A: anon_papp_profile n_voters "parties - {y}" committee_size A
    by fact
  have "committee_size > 0"
    using z n_voters_pos by (intro Nat.gr0I) auto

  from A have A': "is_pref_profile (lift_profile A)"
    by blast
  have "count A {z} > 0"
    using z n_voters_pos by (intro Nat.gr0I) auto
  hence "{z} \<in># A"
    by simp
  hence z': "z \<in> parties - {y}"
    using A.A_subset z by auto

  define C where "C = r (lift_profile A)"

  show "z \<in># lowered A"
  proof (cases "z = x")
    case False
    have "n_voters \<le> committee_size * count A {z}"
      by fact
    also have "count A {z} \<le> count (lift_profile A) {z}"
      using A.A_subset z' False by (subst count_lift_profile) auto
    hence "committee_size * count A {z} \<le> committee_size * count (lift_profile A) {z}"
      by (intro mult_left_mono) auto
    finally have "z \<in># r (lift_profile A)"
      by (intro weak_representation A')
    thus "z \<in># lowered A"
      using False z' by (simp add: lowered_def in_lower_result_iff)
  next
    case [simp]: True
    have "1 \<le> size {#z \<in># C. z \<in> {x, y}#}"
      unfolding C_def
    proof (rule proposition3)
      have [simp]: "{x, y} - {y} = {x}"
        using xy by auto
      hence "n_voters \<le> committee_size * count (lift_profile A) {x, y}"
        using xy A.A_subset z by (subst count_lift_profile) auto
      thus "int 1 * \<lceil>real n_voters / real committee_size\<rceil> \<le> int (count (lift_profile A) {x, y})"
        using \<open>committee_size > 0\<close>
        by (auto simp: ceiling_le_iff field_simps simp flip: of_nat_mult)
    qed (use A' xy \<open>committee_size > 0\<close> in auto)
    also have "\<dots> = count C x + count C y"
      using xy by (induction C) auto
    also have "\<dots> = count (lowered A) x"
      using xy by (simp add: lowered_def count_lower_result C_def)
    finally show "z \<in># lowered A"
      by simp
  qed
qed

lemma filter_lower_result_eq:
  "y \<notin> X \<Longrightarrow> {#x \<in># lower_result C. x \<in> X#} = lower_result {#x \<in># C. x \<in> lift_applist X#}"
  by (induction C) (auto simp: lower_result_def lift_applist_def)

sublocale lowered: card_stratproof_anon_papp n_voters "parties - {y}" committee_size lowered
proof
  fix A X Y
  show "\<not>lowered.card_manipulable A X Y"
    unfolding lowered.card_manipulable_def
  proof (rule notI, elim conjE)
    assume A: "lowered.is_pref_profile A" and XY: "X \<in># A" "Y \<noteq> {}" "Y \<subseteq> parties - {y}"
    assume *: "lowered A \<prec>[lowered.committee_preference X] lowered (A - {#X#} + {#Y#})"
    interpret anon_papp_profile n_voters "parties - {y}" committee_size A
      by fact
    have X: "X \<noteq> {}" "X \<subseteq> parties - {y}"
      using XY A_nonempty A_subset by auto
    define A' where "A' = A - {#X#}"
    have A': "A = A' + {#X#}"
      using XY by (simp add: A'_def)

    from * have "size {#x \<in># lower_result (r (lift_profile A' + {#lift_applist X#})). x \<in> X#} <
                 size {#x \<in># lower_result (r (lift_profile A' + {#lift_applist Y#})). x \<in> X#}"
      by (simp add: lowered_def A' lowered.strong_committee_preference_iff)
    also have "{#x \<in># lower_result (r (lift_profile A' + {#lift_applist X#})). x \<in> X#} =
               lower_result {#x \<in># r (lift_profile A' + {#lift_applist X#}). x \<in> lift_applist X#}"
      using X by (subst filter_lower_result_eq) auto
    also have "{#x \<in># lower_result (r (lift_profile A' + {#lift_applist Y#})). x \<in> X#} =
               lower_result {#x \<in># r (lift_profile A' + {#lift_applist Y#}). x \<in> lift_applist X#}"
      using X by (subst filter_lower_result_eq) auto
    finally have "size {#x \<in># r (lift_profile A' + {#lift_applist X#}). x \<in> lift_applist X#} <
                  size {#x \<in># r (lift_profile A' + {#lift_applist Y#}). x \<in> lift_applist X#}"
      by simp
    hence "r (lift_profile A' + {#lift_applist X#}) \<prec>[committee_preference (lift_applist X)]
           r (lift_profile A' + {#lift_applist Y#})"
      by (simp add: strong_committee_preference_iff)
    moreover have "\<not>r (lift_profile A' + {#lift_applist X#}) \<prec>[committee_preference (lift_applist X)]
                    r (lift_profile A' + {#lift_applist Y#})"
    proof (rule not_manipulable' [where Y = "lift_applist Y"])
      have "is_pref_profile (lift_profile A)"
        using A by blast
      thus "is_pref_profile (lift_profile A' + {#lift_applist X#})"
        using A by (simp add: A')
    next
      have "is_pref_profile (lift_profile (A - {#X#} + {#Y#}))"
        using A  XY lowered.is_pref_profile_replace by blast
      thus "is_pref_profile (lift_profile A' + {#lift_applist Y#})"
        by (simp add: A')
    qed auto
    ultimately show False
      by contradiction
  qed
qed

sublocale lowered: card_stratproof_weak_rep_anon_papp n_voters "parties - {y}" committee_size lowered
  ..

end

text \<open>
  The following lemma is now simply an iterated application of the above. This allows us to
  restrict a P-APP rule to any non-empty subset of parties.
\<close>
lemma card_stratproof_weak_rep_anon_papp_restrict_parties:
  assumes "card_stratproof_weak_rep_anon_papp n parties k r" "parties' \<subseteq> parties" "parties' \<noteq> {}"
  shows   "\<exists>r. card_stratproof_weak_rep_anon_papp n parties' k r"
proof -
  have "finite parties"
  proof -
    interpret card_stratproof_weak_rep_anon_papp n parties k r
      by fact
    show ?thesis
      by (rule finite_parties)
  qed
  thus ?thesis
    using assms
  proof (induction parties arbitrary: r rule: finite_psubset_induct)
    case (psubset parties r)
    show ?thesis
    proof (cases "parties = parties'")
      case True
      thus ?thesis
        using psubset.prems by auto
    next
      case False
      obtain x where x: "x \<in> parties'"
        using psubset.prems by blast
      from False and psubset.prems have "parties - parties' \<noteq> {}"
        by auto
      then obtain y where y: "y \<in> parties - parties'"
        by blast

      interpret card_stratproof_weak_rep_anon_papp n parties k r
        by fact
      interpret remove_alt_card_stratproof_weak_rep_anon_papp n parties k r x y
        by standard (use x y psubset.prems in auto)
      show ?thesis
      proof (rule psubset.IH)
        show "parties - {y} \<subset> parties" and "parties' \<subseteq> parties - {y}" "parties' \<noteq> {}"
          using x y psubset.prems by auto
      next
        show "card_stratproof_weak_rep_anon_papp n (parties - {y}) k lowered"
          using lowered.card_stratproof_weak_rep_anon_papp_axioms .
      qed
    qed
  qed
qed

subsection \<open>Decreasing the committee size\<close>

text \<open>
  If we have a PAPP rule that satisfies weak representation and cardinality strategyproofness,
  for $l(k+1)$ voters, $m+1$ parties, and a committee size of $k+1$, we can turn it into
  one for $lk$ voters, $m$ parties, and a committee size of $k$.

  This is done by again cloning a party \<open>x\<close> into a new party \<open>y\<close> and additionally
  adding \<open>l\<close> new voters whose preferences are \<open>{x, y}\<close>. We again replace any \<open>y\<close> occuring in the
  output committee with \<open>x\<close>. Weak representation then ensures that \<open>x\<close> occurs in the output
  at least once, and we then simply remove one \<open>x\<close> from the committee to obtain an output
  committee of size \<open>k - 1\<close>.

  Consequently, if we have an impossibility result for a committee size of $m$, we can
  extend it to a larger committee size, but at the cost of introducing a new party
  and new voters, and with a restriction on the number of voters.
\<close>
(* n / k = l *)
locale decrease_committee_card_stratproof_weak_rep_anon_papp =
  card_stratproof_weak_rep_anon_papp "l * (k + 1)" "insert y parties" "k + 1" r
  for l k y and parties :: "'a set" and r +
  fixes x :: 'a
  assumes xy: "x \<in> parties" "y \<notin> parties"
  assumes k: "k > 0"
begin

definition lift_applist :: "'a set \<Rightarrow> 'a set" where
  "lift_applist X = (if x \<in> X then insert y X else X)"

definition lift_profile :: "'a set multiset \<Rightarrow> 'a set multiset" where
  "lift_profile A = image_mset lift_applist A + replicate_mset l {x, y}"

definition lower_result
  where "lower_result C = image_mset (\<lambda>z. if z = y then x else z) C - {#x#}"

definition lowered where "lowered = lower_result \<circ> r \<circ> lift_profile"

lemma l: "l > 0"
  using n_voters_pos by auto

lemma x_neq_y [simp]: "x \<noteq> y" "y \<noteq> x"
  using xy by auto

lemma lift_profile_empty [simp]: "lift_profile {#} = replicate_mset l {x, y}"
  by (simp add: lift_profile_def)

lemma lift_profile_add_mset [simp]:
  "lift_profile (add_mset X A) = add_mset (lift_applist X) (lift_profile A)"
  by (simp add: lift_profile_def)

lemma empty_in_lift_profile_iff [simp]: "{} \<in># lift_profile A \<longleftrightarrow> {} \<in># A"
  by (auto simp: lift_applist_def lift_profile_def)

lemma size_lift_profile [simp]: "size (lift_profile A) = size A + l"
  by (simp add: lift_profile_def)

lemma lift_applist_eq_self_iff [simp]: "lift_applist X = X \<longleftrightarrow> x \<notin> X \<or> y \<in> X"
  by (auto simp: lift_applist_def)

lemma lift_applist_eq_self_iff' [simp]: "lift_applist (X - {y}) = X \<longleftrightarrow> (x \<in> X \<longleftrightarrow> y \<in> X)"
  by (cases "y \<in> X") (auto simp: lift_applist_def xy)

lemma in_lift_applist_iff: "z \<in> lift_applist X \<longleftrightarrow> z \<in> X \<or> (z = y \<and> x \<in> X)"
  by (auto simp: lift_applist_def)

lemma count_lift_profile:
  assumes "\<forall>Y\<in>#A. y \<notin> Y"
  shows   "count (lift_profile A) X =
             (if x \<in> X \<longleftrightarrow> y \<in> X then count A (X - {y}) else 0) +
             (if X = {x, y} then l else 0)"
  using assms xy by (induction A) (auto simp: lift_applist_def)

lemma y_notin_lower_result [simp]: "y \<notin># lower_result C"
  using xy by (auto simp: lower_result_def dest: in_diffD)

lemma lower_result_subset: "set_mset (lower_result C) \<subseteq> insert x (set_mset C - {y})"
  using xy by (auto simp: lower_result_def dest: in_diffD)

lemma lower_result_subset': "set_mset C \<subseteq> insert y parties \<Longrightarrow> set_mset (lower_result C) \<subseteq> parties"
  by (rule order.trans[OF lower_result_subset]) (use xy in auto)

lemma size_lower_result [simp]:
  assumes "x \<in># C \<or> y \<in># C"
  shows   "size (lower_result C) = size C - 1"
  using assms by (auto simp: lower_result_def size_Diff_singleton)

lemma size_lower_result': "size (lower_result C) = size C - (if x \<in># C \<or> y \<in># C then 1 else 0)"
proof -
  define f where "f = (\<lambda>C. image_mset (\<lambda>z. if z = y then x else z) C)"
  have "size (lower_result C) = size (f C - {#x#})"
    by (simp add: lower_result_def f_def)
  also have "\<dots> = size (f C) - (if x \<in># f C then 1 else 0)"
    by (simp add: diff_single_trivial size_Diff_singleton)
  finally show ?thesis
    by (auto simp: f_def)
qed

lemma count_lower_result:
  "count (lower_result C) z =
     (if z = y then 0
      else if z = x then count C x + count C y - 1
      else count C z)" (is "_ = ?rhs")
proof -
  define f where "f = (\<lambda>C. image_mset (\<lambda>z. if z = y then x else z) C)"
  have "count (lower_result C) z = count (f C - {#x#}) z"
    by (simp add: lower_result_def f_def)
  also have "\<dots> = count (f C) z - (if z = x then 1 else 0)"
    by auto
  also have "count (f C) z = (if z = y then 0 else if z = x then count C x + count C y else count C z)"
    using xy by (induction C)  (auto simp: f_def)
  also have "\<dots> - (if z = x then 1 else 0) = ?rhs"
    by auto
  finally show ?thesis .
qed

lemma in_lower_resultD:
  "z \<in># lower_result C \<Longrightarrow> z = x \<or> z \<in># C"
  using xy by (auto simp: lower_result_def dest!: in_diffD)

lemma in_lower_result_iff:
  "z \<in># lower_result C \<longleftrightarrow> z \<noteq> y \<and> (if z = x then count C x + count C y > 1 else z \<in># C)"
  (is "_ = ?rhs")
proof -
  have "z \<in># lower_result C \<longleftrightarrow> count (lower_result C) z > 0"
    by auto
  also have "\<dots> \<longleftrightarrow> ?rhs"
    by (subst count_lower_result) auto
  finally show ?thesis .
qed

lemma filter_lower_result_eq:
  assumes "y \<notin> X"
  shows   "{#z \<in># lower_result C. z \<in> X#} = lower_result {#z \<in># C. z \<in> lift_applist X#}"
proof -
  define f where "f = (\<lambda>C. {#if z = y then x else z. z \<in># C#})"
  have "lower_result {#z \<in># C. z \<in> lift_applist X#} = f {#z \<in># C. z \<in> lift_applist X#} - {#x#}"
    by (simp add: f_def lower_result_def)
  also have "f {#z \<in># C. z \<in> lift_applist X#} = {#z \<in># f C. z \<in> X#}"
    using assms by (induction C) (auto simp: f_def lift_applist_def)
  also have "\<dots> - {#x#} = {#z \<in># f C - {#x#}. z \<in> X#}"
    by (subst filter_diff_mset') auto
  also have "f C - {#x#} = lower_result C"
    by (simp add: f_def lower_result_def)
  finally show ?thesis ..
qed

sublocale lowered: anon_papp_election "l * k" parties k
  by standard (use n_voters_pos xy finite_parties k in auto)

lemma is_pref_profile_lift_profile [intro]:
  assumes "lowered.is_pref_profile A"
  shows   "is_pref_profile (lift_profile A)"
proof -
  interpret A: anon_papp_profile "l * k" parties k A
    by fact
  show ?thesis
    using A.A_nonempty A.A_subset A.size_A l
    by unfold_locales
       (auto simp: lift_profile_def lift_applist_def xy
                   size_mset_sum_mset image_mset.compositionality o_def)
qed

lemma is_committee_lower_result:
  assumes "is_committee C" "x \<in># C \<or> y \<in># C"
  shows   "lowered.is_committee (lower_result C)"
  using assms unfolding is_committee_def lowered.is_committee_def
  using lower_result_subset'[of C] by auto

lemma x_or_y_in_r_lift_profile:
  assumes "lowered.is_pref_profile A"
  shows   "x \<in># r (lift_profile A) \<or> y \<in># r (lift_profile A)"
proof -
  interpret A: anon_papp_profile "l * k" parties k A
    by fact
  have "size {#z \<in># r (lift_profile A). z \<in> {x, y}#} \<ge> 1"
  proof (rule proposition3)
    have "real (l * (k + 1)) / real (k + 1) = real l"
      by (simp add: field_simps)
    also have "int 1 * \<lceil>\<dots>\<rceil> = int l"
      by simp
    also have "l \<le> count (lift_profile A) {x, y}"
      using xy A.A_subset by (subst count_lift_profile) auto
    finally show "int 1 * \<lceil>real (l * (k + 1)) / real (k + 1)\<rceil> \<le> int (count (lift_profile A) {x, y})"
      by simp
  next
    show "is_pref_profile (lift_profile A)"
      by (intro is_pref_profile_lift_profile) fact
  qed (use xy in auto)
  hence "{#z \<in># r (lift_profile A). z \<in> {x, y}#} \<noteq> {#}"
    by force
  thus ?thesis
    by auto
qed

sublocale lowered: anon_papp "l * k" parties k lowered
proof
  fix A assume A: "lowered.is_pref_profile A"
  hence "is_pref_profile (lift_profile A)"
    by blast
  hence "is_committee (r (lift_profile A))"
    using rule_wf by blast
  thus "lowered.is_committee (lowered A)"
    unfolding lowered_def o_def using x_or_y_in_r_lift_profile[of A] A
    by (intro is_committee_lower_result) auto
qed

sublocale lowered: weak_rep_anon_papp "l * k" parties k lowered
proof
  fix A z
  assume A: "lowered.is_pref_profile A" and z: "l * k \<le> k * count A {z}"
  interpret A: anon_papp_profile "l * k" "parties" k A
    by fact

  from A have A': "is_pref_profile (lift_profile A)"
    by blast
  have "count A {z} > 0"
    using z k n_voters_pos by (intro Nat.gr0I) auto
  hence "{z} \<in># A"
    by simp
  hence z': "z \<in> parties"
    using A.A_subset z by auto
  hence [simp]: "y \<noteq> z" "z \<noteq> y"
    using xy by auto

  define C where "C = r (lift_profile A)"

  show "z \<in># lowered A"
  proof (cases "z = x")
    case False
    have "l \<le> count A {z}"
      using z k by (simp add: algebra_simps)
    hence "l * (k + 1) \<le> (k + 1) * count A {z}"
      by (subst mult.commute, intro mult_right_mono) auto
    also have "count A {z} = count (lift_profile A) {z}"
      using False A.A_subset xy by (subst count_lift_profile) auto
    finally have "z \<in># r (lift_profile A)"
      by (intro weak_representation A')
    thus "z \<in># lowered A"
      using False by (auto simp: lowered_def in_lower_result_iff)
  next
    case [simp]: True
    from xy have [simp]: "{x, y} - {y} = {x}"
      by auto

    have "size {#z \<in># C. z \<in> {x, y}#} \<ge> 2"
      unfolding C_def
    proof (rule proposition3)
      have "real (l * (k + 1)) / real (k + 1) = l"
        unfolding of_nat_mult using k by (simp add: divide_simps)
      also have "int 2 * \<lceil>\<dots>\<rceil> = int (2 * l)"
        by simp
      also have "\<dots> \<le> count (lift_profile A) {x, y}"
        using z k xy A.A_subset by (subst count_lift_profile) auto
      finally show "int 2 * \<lceil>real (l * (k + 1)) / real (k + 1)\<rceil> \<le> \<dots>" .
    qed (use A' xy in auto)
    also have "size {#z \<in># C. z \<in> {x, y}#} = count C x + count C y"
      by (induction C) auto
    finally have "x \<in># lower_result C"
      by (subst in_lower_result_iff) auto
    thus "z \<in># lowered A"
      by (simp add: lowered_def C_def)
  qed
qed

sublocale lowered: card_stratproof_anon_papp "l * k" parties k lowered
proof
  fix A X Y
  show "\<not>lowered.card_manipulable A X Y"
    unfolding lowered.card_manipulable_def
  proof (rule notI, elim conjE)
    assume A: "lowered.is_pref_profile A" and XY: "X \<in># A" "Y \<noteq> {}" "Y \<subseteq> parties"
    assume *: "lowered A \<prec>[lowered.committee_preference X] lowered (A - {#X#} + {#Y#})"
    interpret anon_papp_profile "l * k" "parties" k A
      by fact
    have X: "X \<noteq> {}" "X \<subseteq> parties"
      using XY A_nonempty A_subset by auto
    define A' where "A' = A - {#X#}"
    have A': "A = A' + {#X#}"
      using XY by (simp add: A'_def)
    from xy X XY have [simp]: "y \<notin> X" "y \<notin> Y"
      by auto

    define Al1 where "Al1 = lift_profile A"
    define Al2 where "Al2 = lift_profile (A' + {#Y#})"
    have A'_plus_Y: "lowered.is_pref_profile (A' + {#Y#})"
      unfolding A'_def using A XY lowered.is_pref_profile_replace by blast
    have Al1: "is_pref_profile Al1"
      unfolding Al1_def using A by blast
    have Al2: "is_pref_profile Al2"
      unfolding Al2_def unfolding A'_def using A XY lowered.is_pref_profile_replace by blast

    have size_aux: "size (lower_result {#x \<in># r (lift_profile A). x \<in> lift_applist X#}) =
                    size {#x \<in># r (lift_profile A). x \<in> lift_applist X#} - (if x \<in> X then 1 else 0)"
      if A: "lowered.is_pref_profile A" for A
      using x_or_y_in_r_lift_profile[OF A]
      by (subst size_lower_result') (auto simp: lift_applist_def)

    from * have "size {#x \<in># lower_result (r Al1). x \<in> X#} <
                 size {#x \<in># lower_result (r Al2). x \<in> X#}"
      by (simp add: Al1_def Al2_def lowered_def A' lowered.strong_committee_preference_iff)
    also have "{#x \<in># lower_result (r Al1). x \<in> X#} = lower_result {#x \<in># r Al1. x \<in> lift_applist X#}"
      using X xy by (subst filter_lower_result_eq) auto
    also have "{#x \<in># lower_result (r Al2). x \<in> X#} = lower_result {#x \<in># r Al2. x \<in> lift_applist X#}"
      using X xy by (subst filter_lower_result_eq) auto
    also have "size (lower_result {#x \<in># r Al1. x \<in> lift_applist X#}) =
               size {#x \<in># r Al1. x \<in> lift_applist X#} - (if x \<in> X then 1 else 0)"
      unfolding Al1_def by (rule size_aux) fact
    also have "size (lower_result {#x \<in># r Al2. x \<in> lift_applist X#}) =
               size {#x \<in># r Al2. x \<in> lift_applist X#} - (if x \<in> X then 1 else 0)"
      unfolding Al2_def by (rule size_aux) fact
    finally have "size {#x \<in># r Al1. x \<in> lift_applist X#} < size {#x \<in># r Al2. x \<in> lift_applist X#}"
      by auto
    hence "r Al1 \<prec>[committee_preference (lift_applist X)] r Al2"
      by (simp add: strong_committee_preference_iff)

    moreover have "\<not>r Al1 \<prec>[committee_preference (lift_applist X)] r Al2"
      by (rule not_manipulable' [where Y = "lift_applist Y"])
         (use Al1 Al2 in \<open>auto simp: Al1_def Al2_def A'\<close>)

    ultimately show False
      by contradiction
  qed
qed

sublocale lowered: card_stratproof_weak_rep_anon_papp "l * k" parties k lowered
  ..

end

text \<open>
  For Weak \<^emph>\<open>Proportional\<close> Representation, the lowering argument to decrease the committee size
  is somewhat easier since it does not involve adding a new party; instead, we simply
  add \<open>l\<close> new voters whose preferences are \<open>{x}\<close>.
\<close>
locale decrease_committee_card_stratproof_weak_prop_rep_anon_papp =
  card_stratproof_weak_prop_rep_anon_papp "l * (k + 1)" parties "k + 1" r
  for l k and parties :: "'a set" and r +
  fixes x :: 'a
  assumes x: "x \<in> parties"
  assumes k: "k > 0"
begin

definition lift_profile :: "'a set multiset \<Rightarrow> 'a set multiset" where
  "lift_profile A = A + replicate_mset l {x}"

definition lower_result
  where "lower_result C = C - {#x#}"

definition lowered where "lowered = lower_result \<circ> r \<circ> lift_profile"

lemma l: "l > 0"
  using n_voters_pos by auto

lemma lift_profile_empty [simp]: "lift_profile {#} = replicate_mset l {x}"
  by (simp add: lift_profile_def)

lemma lift_profile_add_mset [simp]:
  "lift_profile (add_mset X A) = add_mset X (lift_profile A)"
  by (simp add: lift_profile_def)

lemma empty_in_lift_profile_iff [simp]: "{} \<in># lift_profile A \<longleftrightarrow> {} \<in># A"
  by (auto simp: lift_profile_def)

lemma size_lift_profile [simp]: "size (lift_profile A) = size A + l"
  by (simp add: lift_profile_def)

lemma count_lift_profile:
  "count (lift_profile A) X = count A X + (if X = {x} then l else 0)"
  by (auto simp: lift_profile_def)

lemma size_lower_result [simp]:
  assumes "x \<in># C"
  shows   "size (lower_result C) = size C - 1"
  using assms by (auto simp: lower_result_def size_Diff_singleton)

lemma size_lower_result': "size (lower_result C) = size C - (if x \<in># C then 1 else 0)"
  by (induction C) (auto simp: lower_result_def size_Diff_singleton)

lemma count_lower_result:
  "count (lower_result C) z = count C z - (if z = x then 1 else 0)"
  by (auto simp: lower_result_def)

lemma in_lower_resultD:
  "z \<in># lower_result C \<Longrightarrow> z \<in># C"
  by (auto simp: lower_result_def dest!: in_diffD)

lemma in_lower_result_iff:
  "z \<in># lower_result C \<longleftrightarrow> (if z = x then count C x > 1 else z \<in># C)"
  (is "_ = ?rhs")
proof -
  have "z \<in># lower_result C \<longleftrightarrow> count (lower_result C) z > 0"
    by auto
  also have "\<dots> \<longleftrightarrow> ?rhs"
    by (subst count_lower_result) auto
  finally show ?thesis .
qed

sublocale lowered: anon_papp_election "l * k" parties k
  by standard (use n_voters_pos finite_parties k in auto)

lemma is_pref_profile_lift_profile [intro]:
  assumes "lowered.is_pref_profile A"
  shows   "is_pref_profile (lift_profile A)"
proof -
  interpret A: anon_papp_profile "l * k" parties k A
    by fact
  show ?thesis
    using A.A_nonempty A.A_subset A.size_A l
    by unfold_locales
       (auto simp: lift_profile_def x size_mset_sum_mset image_mset.compositionality o_def)
qed

lemma is_committee_lower_result:
  assumes "is_committee C" "x \<in># C"
  shows   "lowered.is_committee (lower_result C)"
  using assms unfolding is_committee_def lowered.is_committee_def
  by (auto simp: lower_result_def size_Diff_singleton dest: in_diffD)

lemma x_in_r_lift_profile:
  assumes "lowered.is_pref_profile A"
  shows   "x \<in># r (lift_profile A)"
proof (rule weak_representation)
  show "is_pref_profile (lift_profile A)"
    using assms by blast
next
  have "(k + 1) * l \<le> (k + 1) * count (lift_profile A) {x}"
    by (intro mult_left_mono) (auto simp: count_lift_profile)
  thus "l * (k + 1) \<le> (k + 1) * count (lift_profile A) {x}"
    by (simp add: algebra_simps)
qed

sublocale lowered: anon_papp "l * k" parties k lowered
proof
  fix A assume A: "lowered.is_pref_profile A"
  hence "is_pref_profile (lift_profile A)"
    by blast
  hence "is_committee (r (lift_profile A))"
    using rule_wf by blast
  thus "lowered.is_committee (lowered A)"
    unfolding lowered_def o_def using x_in_r_lift_profile[of A] A
    by (intro is_committee_lower_result) auto
qed

sublocale lowered: weak_prop_rep_anon_papp "l * k" parties k lowered
proof
  fix A z l'
  assume A: "lowered.is_pref_profile A" and z: "l' * (l * k) \<le> k * count A {z}"
  interpret A: anon_papp_profile "l * k" "parties" k A
    by fact

  show "count (lowered A) z \<ge> l'"
  proof (cases "l' > 0")
    case False
    thus ?thesis by auto
  next
    case l: True

    from A have A': "is_pref_profile (lift_profile A)"
      by blast
    have "count A {z} > 0"
      using z k n_voters_pos l by (intro Nat.gr0I) auto
    hence "{z} \<in># A"
      by simp
    hence z': "z \<in> parties"
      using A.A_subset z by auto

    define C where "C = r (lift_profile A)"

    show "count (lowered A) z \<ge> l'"
    proof (cases "z = x")
      case False
      have "l' * l \<le> count A {z}"
        using z k by (simp add: algebra_simps)
      hence "l' * l * (k + 1) \<le> (k + 1) * count A {z}"
        by (subst mult.commute, intro mult_right_mono) auto
      also have "count A {z} = count (lift_profile A) {z}"
        using False A.A_subset by (subst count_lift_profile) auto
      finally have "count (r (lift_profile A)) z \<ge> l'"
        by (intro weak_proportional_representation A') (auto simp: algebra_simps)
      thus "l' \<le> count (lowered A) z"
        using False by (simp add: lowered_def lower_result_def)
    next
      case [simp]: True
      have "l' * l \<le> count A {x}"
        using z k by (simp add: algebra_simps)
      hence "l' * l * (k + 1) \<le> (k + 1) * count A {x}"
        by (subst mult.commute, intro mult_right_mono) auto
      also have "\<dots> + (k + 1) * l = (k + 1) * count (lift_profile A) {x}"
        by (simp add: count_lift_profile algebra_simps)
      finally have "(l' + 1) * (l * (k + 1)) \<le> (k + 1) * count (lift_profile A) {x}"
        by (simp add: algebra_simps)
      hence "count (r (lift_profile A)) x \<ge> l' + 1"
        by (intro weak_proportional_representation A')
      thus "l' \<le> count (lowered A) z"
        by (simp add: lowered_def lower_result_def)
    qed
  qed
qed

sublocale lowered: card_stratproof_anon_papp "l * k" parties k lowered
proof
  fix A X Y
  show "\<not>lowered.card_manipulable A X Y"
    unfolding lowered.card_manipulable_def
  proof (rule notI, elim conjE)
    assume A: "lowered.is_pref_profile A" and XY: "X \<in># A" "Y \<noteq> {}" "Y \<subseteq> parties"
    assume *: "lowered A \<prec>[lowered.committee_preference X] lowered (A - {#X#} + {#Y#})"
    interpret anon_papp_profile "l * k" "parties" k A
      by fact
    have X: "X \<noteq> {}" "X \<subseteq> parties"
      using XY A_nonempty A_subset by auto
    define A' where "A' = A - {#X#}"
    have A': "A = A' + {#X#}"
      using XY by (simp add: A'_def)

    define Al1 where "Al1 = lift_profile A"
    define Al2 where "Al2 = lift_profile (A' + {#Y#})"
    have A'_plus_Y: "lowered.is_pref_profile (A' + {#Y#})"
      unfolding A'_def using A XY lowered.is_pref_profile_replace by blast
    have Al1: "is_pref_profile Al1"
      unfolding Al1_def using A by blast
    have Al2: "is_pref_profile Al2"
      unfolding Al2_def unfolding A'_def using A XY lowered.is_pref_profile_replace by blast

    have size_aux: "size (lower_result {#x \<in># r (lift_profile A). x \<in> X#}) =
                    size {#x \<in># r (lift_profile A). x \<in> X#} - (if x \<in> X then 1 else 0)"
      if A: "lowered.is_pref_profile A" for A
      using x_in_r_lift_profile[OF A]  by (subst size_lower_result') auto

    from * have "size {#x \<in># lower_result (r Al1). x \<in> X#} <
                 size {#x \<in># lower_result (r Al2). x \<in> X#}"
      by (simp add: Al1_def Al2_def lowered_def A' lowered.strong_committee_preference_iff)
    also have "{#x \<in># lower_result (r Al1). x \<in> X#} = lower_result {#x \<in># r Al1. x \<in> X#}"
      using X x unfolding lower_result_def by (subst filter_diff_mset') auto
    also have "{#x \<in># lower_result (r Al2). x \<in> X#} = lower_result {#x \<in># r Al2. x \<in> X#}"
      using X x unfolding lower_result_def by (subst filter_diff_mset') auto
    also have "size (lower_result {#x \<in># r Al1. x \<in> X#}) =
               size {#x \<in># r Al1. x \<in> X#} - (if x \<in> X then 1 else 0)"
      unfolding Al1_def by (rule size_aux) fact
    also have "size (lower_result {#x \<in># r Al2. x \<in> X#}) =
               size {#x \<in># r Al2. x \<in> X#} - (if x \<in> X then 1 else 0)"
      unfolding Al2_def by (rule size_aux) fact
    finally have "size {#x \<in># r Al1. x \<in> X#} < size {#x \<in># r Al2. x \<in> X#}"
      by auto
    hence "r Al1 \<prec>[committee_preference X] r Al2"
      by (simp add: strong_committee_preference_iff)

    moreover have "\<not>r Al1 \<prec>[committee_preference X] r Al2"
      by (rule not_manipulable' [where Y = "Y"])
         (use Al1 Al2 in \<open>auto simp: Al1_def Al2_def A'\<close>)

    ultimately show False
      by contradiction
  qed
qed

sublocale lowered: card_stratproof_weak_prop_rep_anon_papp "l * k" parties k lowered
  ..

end

end


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

section "Depth-First Search"

theory DFS
  imports Main "Smart_Induct.Smart_Induct"
begin

subsection "Definition of Graphs"

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

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

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

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

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

subsection "Depth-First Search with Stack"

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

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

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

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

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

subsection "Depth-First Search with Nested-Recursion"

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

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

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

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

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

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

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

subsection "Basic Properties"

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

(* This example was formulated by Toshiaki Nishihara and Yasuhiko Minamide
 * For more details, visit
 *   http://isa-afp.org/entries/Depth-First-Search.html *)

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
  oops

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

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

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

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

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

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

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

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

subsection "Correctness"

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

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

subsection "Executable Code"

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

code_datatype Node

instantiation node :: equal
begin

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

instance proof
qed (simp add: equal_node_def)

end

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

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

end