section \<open>Combinatorics problems\<close>

subsection \<open>IMO 2017 SL - C1\<close>

theory IMO_2017_SL_C1_sol
  imports Complex_Main
begin

text \<open>A rectangle with line coordinates [x1, x2) and [y1, y2) is given by a quadruple (x1, x2, y1, y2).\<close>
type_synonym rect = "nat \<times> nat \<times> nat \<times> nat"

fun valid_rect :: "rect \<Rightarrow> bool" where
  "valid_rect (x1, x2, y1, y2) \<longleftrightarrow> x1 < x2 \<and> y1 < y2"

text \<open>A square is given by the coordinates of its lower-left corner\<close>
type_synonym square = "nat \<times> nat"

text \<open>All squares in a rectangle\<close>
fun squares :: "rect \<Rightarrow> square set" where
  "squares (x1, x2, y1, y2) = {x1..<x2} \<times> {y1..<y2}"

text \<open>One rectangle is inside another one\<close>
definition inside :: "rect \<Rightarrow> rect \<Rightarrow> bool" where
  "inside ri ro \<longleftrightarrow> squares ri \<subseteq> squares ro"

text \<open>Two rectangles overlap inside another one\<close>
definition overlap :: "rect \<Rightarrow> rect \<Rightarrow> bool" where
  "overlap r1 r2 \<longleftrightarrow> squares r1 \<inter> squares r2 \<noteq> {}"

text \<open>There are no two overlapping rectangles in a set\<close>
definition non_overlapping :: "rect set \<Rightarrow> bool" where
  "non_overlapping rs \<longleftrightarrow> (\<forall> r1 \<in> rs. \<forall> r2 \<in> rs. r1 \<noteq> r2 \<longrightarrow> \<not> overlap r1 r2)"

text \<open>A set of rectangles covers a given rectangle\<close>
definition cover :: "rect set \<Rightarrow> rect \<Rightarrow> bool" where
  "cover rs r \<longleftrightarrow> (\<Union> (squares ` rs)) = squares r"

text \<open>A rectangle is tiled by a set of non-overlapping, smaller rectangles\<close>
definition tiles :: "rect set \<Rightarrow> rect \<Rightarrow> bool" where
  "tiles rs r \<longleftrightarrow> cover rs r \<and> non_overlapping rs"

text \<open>Each square is colored either to green or yellow in a checkerboard pattern\<close>
fun green :: "square \<Rightarrow> bool" where
  "green (x, y) \<longleftrightarrow> (x + y) mod 2 = 0"

fun yellow :: "square \<Rightarrow> bool" where
  "yellow (x, y) \<longleftrightarrow> (x + y) mod 2 \<noteq> 0"

text \<open>All green squares in a rectangle\<close>
definition green_squares :: "rect \<Rightarrow> square set" where
  "green_squares r = {(x, y) \<in> squares r. green (x, y)}"

text \<open>All yellow squares in a rectangle\<close>
definition yellow_squares :: "rect \<Rightarrow> square set" where
  "yellow_squares r = {(x, y) \<in> squares r. yellow (x, y)}"

text \<open>Corner squares of a rectangle\<close>
fun corners :: "rect \<Rightarrow> square set" where
  "corners (x1, x2, y1, y2) = {(x1, y1), (x1, y2-1), (x2-1, y1), (x2-1, y2-1)}"

definition green_rect :: "rect \<Rightarrow> bool" where
  "green_rect r \<longleftrightarrow> (\<forall> c \<in> corners r. green c)"

definition yellow_rect :: "rect \<Rightarrow> bool" where
  "yellow_rect r \<longleftrightarrow> (\<forall> c \<in> corners r. yellow c)"

definition mixed_rect ::  "rect \<Rightarrow> bool" where
  "mixed_rect r \<longleftrightarrow> \<not> green_rect r \<and> \<not> yellow_rect r"

lemma finite_squares [simp]:
  shows "finite (squares r)"
  by (cases r, auto)

lemma finite_green_squares [simp]:
  shows "finite (green_squares r)"
  using finite_subset[of "green_squares r" "squares r"]
  by (auto simp add: green_squares_def)

lemma finite_yellow_squares [simp]:
  shows "finite (yellow_squares r)"
  using finite_subset[of "yellow_squares r" "squares r"]
  by (auto simp add: yellow_squares_def)

lemma card_green_squares_row:
  assumes "x1 < x2"
  shows "card {(x, y). x1 \<le> x \<and> x < x2 \<and> y = y0 \<and> green (x, y)} =
         (if yellow (x1, y0) then (x2 - x1) div 2 else (x2 - x1 + 1) div 2)"
  using assms
proof (induction k \<equiv> "x2 - x1 - 1" arbitrary: x2)
  case 0
  then have "x2 = x1 + 1"
    by simp
  then have "{(x, y). x1 \<le> x \<and> x < x2 \<and> y = y0 \<and> green (x, y)} =
         {(x, y). x = x1 \<and> y = y0 \<and> green (x, y)}"
    by auto
  also have "... = (if yellow (x1, y0) then {} else {(x1, y0)})"
    by auto
  finally show ?case
    using \<open>x2 = x1 + 1\<close>
    by (smt One_nat_def Suc_1 Suc_eq_plus1 add_diff_cancel_left' card_empty card_insert_if div_self equals0D finite.intros(1) nat.simps(3) one_div_two_eq_zero)
next
  case (Suc k)
  let ?S = "{(x, y). x1 \<le> x \<and> x < x2 \<and> y = y0 \<and> green (x, y)}"
  let ?S1 = "{(x, y). x1 \<le> x \<and> x < x2 - 1 \<and> y = y0 \<and> green (x, y)}"
  let ?S2 = "{(x, y). x = x2 - 1 \<and> y = y0 \<and> green (x, y)}"
  have "card (?S1 \<union> ?S2) = card ?S1 + card ?S2"
  proof (rule card_Un_disjoint)
    show "finite ?S1"
      using finite_subset[of ?S1 "{x1..<x2} \<times> {y0}"]
      by force
  next
    show "finite ?S2"
      using finite_subset[of ?S2 "{x2-1} \<times> {y0}"]
      by auto
  next
    show "?S1 \<inter> ?S2 = {}"
      by auto
  qed
  moreover
  have "?S = ?S1 \<union> ?S2"
    using \<open>x1 < x2\<close>
    by auto
  ultimately
  have 1: "card ?S = card ?S1 + card ?S2"
    by simp
  have 2: "card ?S1 = (if yellow (x1, y0) then (x2 - 1 - x1) div 2 else (x2 - x1) div 2)"
    using Suc(1)[of "x2 - 1"] Suc(2) Suc(3)
    by auto
  show ?case
  proof (cases "yellow (x1, y0)")
    case True
    show ?thesis
    proof (cases "green (x2-1, y0)")
      case True
      then have "even (x2 - x1)"
        using \<open>x1 < x2\<close> \<open>yellow (x1, y0)\<close>
        by simp presburger
      then have "(x2 - x1) div 2 = (x2 - x1 - 1) div 2 + 1"
        using \<open>x1 < x2\<close>
        by presburger+
      moreover
      have "?S2 = {(x2-1, y0)}"
        using \<open>green (x2-1, y0)\<close>
        by auto
      then have "card ?S2 = 1"
        by simp
      ultimately show ?thesis
        using \<open>yellow (x1, y0)\<close> 1 2 True
        by simp
    next
      case False
      then have "odd (x2 - x1)"
        using \<open>yellow (x1, y0)\<close> \<open>x1 < x2\<close>
        by simp presburger
      then have "(x2 - x1) div 2 = (x2 - x1 - 1) div 2"
        using \<open>x2 > x1\<close>
        by presburger
      moreover
      have "?S2 = {}"
        using False
        by auto
      then have "card ?S2 = 0"
        by (metis card_empty)
      ultimately show ?thesis
        using \<open>yellow (x1, y0)\<close> 1 2
        by simp
    qed
  next
    case False
    then have "green (x1, y0)"
      by simp
    show ?thesis
    proof (cases "green (x2-1, y0)")
      case True
      then have "odd (x2 - x1)"
        using \<open>green (x1, y0)\<close> \<open>x1 < x2\<close>
        by simp presburger
      then have "(x2 - x1) div 2 + 1 = (x2 - x1 + 1) div 2"
        using \<open>x1 < x2\<close>
        by presburger
      moreover
      have "?S2 = {(x2-1, y0)}"
        using True
        by auto
      then have "card ?S2 = 1"
        by simp
      ultimately show ?thesis
        using 1 2 \<open>green (x1, y0)\<close>
        by simp
    next
      case False
      then have "even (x2 - x1)"
        using \<open>green (x1, y0)\<close> \<open>x1 < x2\<close>
        by simp presburger
      then have "(x2 - x1) div 2 = (x2 - x1 + 1) div 2"
        using \<open>x2 > x1\<close>
        by presburger
      moreover
      have "?S2 = {}"
        using False
        by auto
      then have "card ?S2 = 0"
        by (metis card_empty)
      ultimately show ?thesis
        using 1 2 \<open>green (x1, y0)\<close>
        by simp
    qed
  qed
qed

lemma card_squares:
  shows "card (squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1)"
  by simp

lemma card_green_squares_start_yellow:
  assumes "yellow (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1) div 2"
  using assms
proof (induction k \<equiv> "y2 - y1 - 1" arbitrary: y2)
  case 0
  then have "y2 = y1 + 1"
    by simp
  then show ?case
    using \<open>yellow (x1, y1)\<close> \<open>valid_rect (x1, x2, y1, y2)\<close> card_green_squares_row[of x1 x2 y1]
    unfolding green_squares_def
    by simp
next
  case (Suc k)

  have "x1 < x2" "y1 < y2"
    using \<open>valid_rect (x1, x2, y1, y2)\<close>
    by simp_all

  let ?S = "green_squares (x1, x2, y1, y2)"
  let ?S1 = "green_squares (x1, x2, y1, y2-1)"
  let ?S2 = "{(x, y). x1 \<le> x \<and> x < x2 \<and> y = y2-1 \<and> green (x, y)}"

  have 1: "card ?S1 = (x2 - x1) * (y2 - 1 - y1) div 2"
    using Suc
    by auto

  have "card (?S1 \<union> ?S2) = card ?S1 + card ?S2"
  proof (rule card_Un_disjoint)
    show "finite ?S1"
      using finite_subset[of ?S1 "{x1..<x2} \<times> {y1..<y2}"]
      unfolding green_squares_def
      by force
  next
    show "finite ?S2"
      using finite_subset[of ?S2 "{x1..<x2} \<times> {y2 - 1}"]
      by force
  next
    show "?S1 \<inter> ?S2 = {}"
      unfolding green_squares_def
      by auto
  qed

  moreover

  have "?S = ?S1 \<union> ?S2"
    using \<open>y1 < y2\<close>
    by (auto simp add: green_squares_def)

  ultimately

  have 2: "card ?S = card ?S1 + card ?S2"
    by simp

  show ?case
  proof (cases "odd (y2 - y1)")
    case True
    then have "yellow (x1, y2-1)"
      using \<open>y1 < y2\<close> \<open>yellow (x1, y1)\<close>
      by simp presburger
    then have "card ?S2 = (x2 - x1) div 2"
      using card_green_squares_row[of x1 x2 "y2-1"] \<open>x1 < x2\<close>
      by simp
    then have "card ?S = (x2 - x1) * (y2 - y1 - 1) div 2 + (x2 - x1) div 2"
      using 1 2
      by simp
    also have "... = (x2 - x1) * (y2 - y1) div 2"
      using \<open>odd (y2 - y1)\<close> \<open>x1 < x2\<close> \<open>y1 < y2\<close>
      by (metis add_mult_distrib2 div_plus_div_distrib_dvd_left dvdI dvd_mult nat_mult_1_right odd_two_times_div_two_nat odd_two_times_div_two_succ)
    finally show ?thesis
      .
  next
    case False
    then have "green (x1, y2-1)"
      using \<open>y1 < y2\<close> \<open>yellow (x1, y1)\<close>
      by simp presburger
    then have "card ?S2 = (x2 - x1 + 1) div 2"
      using card_green_squares_row[of x1 x2 "y2-1"] \<open>x1 < x2\<close>
      by simp
    then have "card ?S = (x2 - x1) * (y2 - y1 - 1) div 2 + (x2 - x1 + 1) div 2"
      using 1 2
      by simp
    also have "... = (x2 - x1) * (y2 - y1) div 2"
      using \<open>\<not> odd (y2 - y1)\<close> \<open>x1 < x2\<close> \<open>y1 < y2\<close>
      apply (cases "odd (x2 - x1)")
       apply (smt Suc_diff_Suc add.commute add_Suc_shift diff_diff_left div_mult_self2 even_add even_mult_iff mult_Suc_right odd_two_times_div_two_succ plus_1_eq_Suc zero_neq_numeral)
      apply (metis Suc_diff_1 add.commute dvd_div_mult even_succ_div_two mult_Suc_right zero_less_diff)
      done
    finally show ?thesis
      .
  qed
qed

lemma card_yellow_squares_start_yellow:
  assumes "yellow (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (yellow_squares (x1, x2, y1, y2)) = ((x2 - x1) * (y2 - y1) + 1) div 2"
proof-
  let ?S = "squares (x1, x2, y1, y2)" and ?Y = "yellow_squares (x1, x2, y1, y2)" and ?G = "green_squares (x1, x2, y1, y2)"
  have "?S = ?Y \<union> ?G"
    unfolding green_squares_def yellow_squares_def
    by auto
  moreover
  have "card (?Y \<union> ?G) = card ?Y + card ?G"
  proof (rule card_Un_disjoint)
    show "finite ?Y"
      using finite_subset[of ?Y ?S]
      by (force simp add: yellow_squares_def)
  next
    show "finite ?G"
      using finite_subset[of ?G ?S]
      by (force simp add: green_squares_def)
  next
    show "?Y \<inter> ?G = {}"
      by (auto simp add: yellow_squares_def green_squares_def)
  qed
  ultimately
  have "card ?S = card ?G + card ?Y"
    by simp
  then have "card ?Y = card ?S - card ?G"
    by auto
  then have "card ?Y = (x2 - x1)*(y2 - y1) - (x2 - x1)*(y2 - y1) div 2"
    using assms(1) assms(2) card_green_squares_start_yellow card_squares
    by presburger
  also have "... = ((x2 - x1)*(y2 - y1) + 1) div 2"
    by presburger
  finally show ?thesis
    .
qed

lemma card_yellow_squares_start_green:
  assumes "green (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (yellow_squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1) div 2"
proof-
  let ?Y = "yellow_squares (x1, x2, y1, y2)" and ?G = "green_squares (x1+1, x2+1, y1, y2)"
  have "card ?Y = card ?G"
  proof (rule bij_betw_same_card)
    let ?f = "\<lambda> (x, y). (x+1, y)"
    show "bij_betw ?f ?Y ?G"
      unfolding bij_betw_def
    proof safe
      show "inj_on ?f ?Y"
        by (auto simp add: inj_on_def)
    next
      fix x y
      assume "(x, y) \<in> ?Y"
      then show "(x+1, y) \<in> ?G"
        unfolding green_squares_def yellow_squares_def
        by (auto simp add: mod_Suc)
    next
      fix x y
      assume "(x, y) \<in> ?G"
      then have "(x-1, y) \<in> ?Y" "x > 0"
        unfolding green_squares_def yellow_squares_def
        apply auto
        apply (metis Nat.add_diff_assoc2 Suc_eq_plus1 add_eq_if add_leD2 even_Suc even_iff_mod_2_eq_zero not_mod2_eq_Suc_0_eq_0 odd_add)
        by (metis Suc_leI add_gr_0 even_iff_mod_2_eq_zero lessI mod_nat_eqI not_mod2_eq_Suc_0_eq_0 numeral_2_eq_2 odd_even_add odd_pos)
      then show "(x, y) \<in> ?f ` ?Y"
        by (simp add: rev_image_eqI)
    qed
  qed
  then show ?thesis
    using card_green_squares_start_yellow[of "x1+1" y1 "x2+1" y2] \<open>valid_rect (x1, x2, y1, y2)\<close>
    using \<open>green (x1, y1)\<close>
    by auto
qed

lemma card_green_squares_start_green:
  assumes "green (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = ((x2 - x1) * (y2 - y1) + 1) div 2"
proof-
  let ?G = "green_squares (x1, x2, y1, y2)" and ?Y = "yellow_squares (x1+1, x2+1, y1, y2)"
  have "card ?G = card ?Y"
  proof (rule bij_betw_same_card)
    let ?f = "\<lambda> (x, y). (x+1, y)"
    show "bij_betw ?f ?G ?Y"
      unfolding bij_betw_def
    proof safe
      show "inj_on ?f ?G"
        by (auto simp add: inj_on_def)
    next
      fix x y
      assume "(x, y) \<in> ?G"
      then show "(x+1, y) \<in> ?Y"
        unfolding green_squares_def yellow_squares_def
        by auto
    next
      fix x y
      assume "(x, y) \<in> ?Y"
      then have "(x-1, y) \<in> ?G" "x > 0"
        unfolding green_squares_def yellow_squares_def
        apply auto
        apply (metis Suc_eq_plus1 add_eq_if even_Suc even_iff_mod_2_eq_zero not_mod2_eq_Suc_0_eq_0 odd_add)
        done
      then show "(x, y) \<in> ?f ` ?G"
        by (simp add: rev_image_eqI)
    qed
  qed
  then show ?thesis
    using card_yellow_squares_start_yellow[of "x1+1" y1 "x2+1" y2] \<open>valid_rect (x1, x2, y1, y2)\<close>
    using \<open>green (x1, y1)\<close>
    by auto
qed

lemma mixed_rect:
  assumes "valid_rect (x1, x2, y1, y2)" "mixed_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = card (yellow_squares (x1, x2, y1, y2))"
proof (cases "green (x1, y1)")
  case True
  then have "even ((x2 - x1) * (y2 - y1))"
    using assms
    unfolding mixed_rect_def green_rect_def yellow_rect_def
    by auto presburger+
  then show ?thesis
    using True
    using card_green_squares_start_green[of x1 y1 x2 y2] assms
    using card_yellow_squares_start_green[of x1 y1 x2 y2]
    by simp
next
  case False
  then have "even ((x2 - x1) * (y2 - y1))"
    using assms
    unfolding mixed_rect_def green_rect_def yellow_rect_def
    by auto presburger+
  then show ?thesis
    using False
    using card_green_squares_start_yellow[of x1 y1 x2 y2] assms
    using card_yellow_squares_start_yellow[of x1 y1 x2 y2]
    unfolding mixed_rect_def green_rect_def yellow_rect_def
    by simp
qed

lemma green_rect:
  assumes "valid_rect (x1, x2, y1, y2)"  "green_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = card (yellow_squares (x1, x2, y1, y2)) + 1"
  using assms
  using card_green_squares_start_green[of x1 y1 x2 y2]
  using card_yellow_squares_start_green[of x1 y1 x2 y2]
  unfolding green_rect_def
  by auto

lemma yellow_rect:
  assumes "valid_rect (x1, x2, y1, y2)" "yellow_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) + 1 = card (yellow_squares (x1, x2, y1, y2))"
  using assms
  using card_green_squares_start_yellow[of x1 y1 x2 y2]
  using card_yellow_squares_start_yellow[of x1 y1 x2 y2]
  unfolding yellow_rect_def
  by auto (metis dvd_imp_mod_0 even_Suc even_diff_nat even_mult_iff linorder_not_less nat_less_le odd_Suc_div_two odd_add)

lemma tiles_inside:
  assumes "tiles rs (x1, x2, y1, y2)" "r \<in> rs"
  shows "inside r (x1, x2, y1, y2)"
  using assms
  unfolding tiles_def inside_def cover_def
  by auto

lemma finite_tiles:
  assumes "tiles rs (x1, x2, y1, y2)" "\<forall> r \<in> rs. valid_rect r"
  shows "finite rs"
proof (rule finite_subset)
  show "rs \<subseteq> {x1..x2} \<times> {x1..x2} \<times> {y1..y2} \<times> {y1..y2}"
  proof
    fix r :: rect
    obtain x1r x2r y1r y2r where r: "r = (x1r, x2r, y1r, y2r)"
      by (cases r)
    assume "r \<in> rs"
    then have "inside r (x1, x2, y1, y2)"
      using tiles_inside[OF assms(1)]
      by auto
    moreover have "x1r < x2r" "y1r < y2r"
      using assms(2) \<open>r \<in> rs\<close> r
      by auto
    ultimately
    show "r \<in> {x1..x2} \<times> {x1..x2} \<times> {y1..y2} \<times> {y1..y2}"
      using r times_subset_iff[of "{x1r..<x2r}" "{y1r..<y2r}" "{x1..<x2}" "{y1..<y2}"]
      by (auto simp add: inside_def)
  qed
next
  show "finite ({x1..x2} \<times> {x1..x2} \<times> {y1..y2} \<times> {y1..y2})"
    by simp
qed

lemma green_tile:
  assumes "green_rect (x1, x2, y1, y2)" "valid_rect (x1, x2, y1, y2)"
          "tiles rs (x1, x2, y1, y2)" "\<forall> r \<in> rs. valid_rect r"
  shows "\<exists> r \<in> rs. green_rect r"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<forall> r \<in> rs. yellow_rect r \<or> mixed_rect r"
    using mixed_rect_def by blast
  then have **: "\<forall> r \<in> rs. card (green_squares r) \<le> card (yellow_squares r)"
    using yellow_rect mixed_rect \<open>\<forall> r \<in> rs. valid_rect r\<close>
    by (metis le_add1 order_refl prod_cases4)

  have "card (green_squares (x1, x2, y1, y2)) \<le> card (yellow_squares (x1, x2, y1, y2))"
  proof-
    have "card (green_squares (x1, x2, y1, y2)) = card (\<Union> (green_squares ` rs))"
    proof-
      have "green_squares (x1, x2, y1, y2) = \<Union> (green_squares ` rs)"
        using \<open>tiles rs (x1, x2, y1, y2)\<close>
        unfolding tiles_def cover_def green_squares_def
        by blast
      then show ?thesis
        by simp
    qed
    also have "... = (\<Sum> r \<in> rs. card (green_squares r))"
    proof (rule card_UN_disjoint)
      show "finite rs"
        using assms(3-4) finite_tiles
        by auto
    next
      show "\<forall> r \<in> rs. finite (green_squares r)"
        by auto
    next
      show "\<forall> r1 \<in> rs. \<forall> r2 \<in> rs. r1 \<noteq> r2 \<longrightarrow> green_squares r1 \<inter> green_squares r2 = {}"
      proof (rule, rule, rule)
        fix r1 r2
        assume "r1 \<in> rs" "r2 \<in> rs" "r1 \<noteq> r2"
        then have "squares r1 \<inter> squares r2 = {}"
          using \<open>tiles rs (x1, x2, y1, y2)\<close>
          unfolding tiles_def non_overlapping_def overlap_def
          by auto
        then show "green_squares r1 \<inter> green_squares r2 = {}"
          unfolding green_squares_def
          by auto
      qed
    qed
    also have "... \<le> (\<Sum> r \<in> rs. card (yellow_squares r))"
      using **
      by (simp add: sum_mono)
    also have "... = card (\<Union> (yellow_squares ` rs))"
    proof (rule card_UN_disjoint[symmetric])
      show "finite rs"
        using assms(3-4) finite_tiles by auto
    next
      show "\<forall>r\<in>rs. finite (yellow_squares r)"
        by auto
    next
      show "\<forall>r\<in>rs. \<forall>j\<in>rs. r \<noteq> j \<longrightarrow> yellow_squares r \<inter> yellow_squares j = {}"
      proof (rule, rule, rule)
        fix r1 r2
        assume "r1 \<in> rs" "r2 \<in> rs" "r1 \<noteq> r2"
        then have "squares r1 \<inter> squares r2 = {}"
          using \<open>tiles rs (x1, x2, y1, y2)\<close>
          unfolding tiles_def non_overlapping_def overlap_def
          by auto
        then show "yellow_squares r1 \<inter> yellow_squares r2 = {}"
          unfolding yellow_squares_def
          by auto
      qed
    qed
    also have "... = card (yellow_squares (x1, x2, y1, y2))"
    proof-
      have "yellow_squares (x1, x2, y1, y2) = \<Union> (yellow_squares ` rs)"
        using \<open>tiles rs (x1, x2, y1, y2)\<close>
        unfolding tiles_def cover_def yellow_squares_def
        by blast
      then show ?thesis
        by simp
    qed

    finally
    show ?thesis
      .
  qed

  then show False
    using \<open>green_rect (x1, x2, y1, y2)\<close> green_rect[of x1 x2 y1 y2] \<open>valid_rect (x1, x2, y1, y2)\<close>
    by auto
qed

lemma green_inside_green_distances:
  assumes "green_rect (x1i, x2i, y1i, y2i)" "green_rect (x1o, x2o, y1o, y2o)" "valid_rect (x1i, x2i, y1i, y2i)"
          "inside (x1i, x2i, y1i, y2i) (x1o, x2o, y1o, y2o)"
  shows   "let ds = {x1i - x1o, x2o - x2i, y1i - y1o, y2o - y2i}
            in (\<forall> d \<in> ds. even d) \<or> (\<forall> d \<in> ds. odd d)"
proof-
  have "x1o \<le> x1i" "x1i < x2i" "x2i \<le> x2o"
       "y1o \<le> y1i" "y1i < y2i" "y2i \<le> y2o"
    using assms times_subset_iff[of "{x1i..<x2i}" "{y1i..<y2i}" "{x1o..<x2o}" "{y1o..<y2o}"]
    unfolding Let_def inside_def
    by auto
  then show ?thesis
    using assms
    by (auto simp add: green_rect_def)
qed

theorem IMO_2017_SL_C1:
  fixes a b :: nat
  assumes "odd a" "odd b" "tiles rs (0, a, 0, b)" "\<forall> r \<in> rs. valid_rect r"
        shows "\<exists> (x1, x2, y1, y2) \<in> rs.
                  let ds = {x1 - 0, a - x2, y1 - 0, b - y2}
                   in (\<forall> d \<in> ds. even d) \<or> (\<forall> d \<in> ds. odd d)"
proof-
  have "green_rect (0, a, 0, b)"
    using \<open>odd a\<close> \<open>odd b\<close>
    unfolding green_rect_def
    by auto
  then obtain x1 x2 y1 y2 where
    "(x1, x2, y1, y2) \<in> rs" "valid_rect (x1, x2, y1, y2)" "green_rect (x1, x2, y1, y2)"
    "inside (x1, x2, y1, y2) (0, a, 0, b)"
    using assms green_tile[of 0 a 0 b rs] tiles_inside[of rs 0 a 0 b]
    by (auto simp add: odd_pos)
  then show ?thesis
    using \<open>green_rect (0, a, 0, b)\<close> green_inside_green_distances[of x1 x2 y1 y2 0 a 0 b]
    by (rule_tac x="(x1, x2, y1, y2)" in bexI, auto)
qed

end


theory Type
imports Main
begin

datatype kind = Star

datatype type =
  TyVar nat
| Arrow type type
| Record "type list"
| Variant "type list"
| Inductive kind type
| Forall kind type

primrec incr\<^sub>t\<^sub>t :: "nat \<Rightarrow> type \<Rightarrow> type" where
  "incr\<^sub>t\<^sub>t x (TyVar y) = TyVar (if x \<le> y then Suc y else y)"
| "incr\<^sub>t\<^sub>t x (Arrow t\<^sub>1 t\<^sub>2) = Arrow (incr\<^sub>t\<^sub>t x t\<^sub>1) (incr\<^sub>t\<^sub>t x t\<^sub>2)"
| "incr\<^sub>t\<^sub>t x (Record ts) = Record (map (incr\<^sub>t\<^sub>t x) ts)"
| "incr\<^sub>t\<^sub>t x (Variant ts) = Variant (map (incr\<^sub>t\<^sub>t x) ts)"
| "incr\<^sub>t\<^sub>t x (Inductive k t) = Inductive k (incr\<^sub>t\<^sub>t (Suc x) t)"
| "incr\<^sub>t\<^sub>t x (Forall k t) = Forall k (incr\<^sub>t\<^sub>t (Suc x) t)"

primrec subst\<^sub>t\<^sub>t :: "nat \<Rightarrow> type \<Rightarrow> type \<Rightarrow> type" where
  "subst\<^sub>t\<^sub>t x t' (TyVar y) = (if x = y then t' else TyVar (if x < y then y - 1 else y))"
| "subst\<^sub>t\<^sub>t x t' (Arrow t\<^sub>1 t\<^sub>2) = Arrow (subst\<^sub>t\<^sub>t x t' t\<^sub>1) (subst\<^sub>t\<^sub>t x t' t\<^sub>2)"
| "subst\<^sub>t\<^sub>t x t' (Record ts) = Record (map (subst\<^sub>t\<^sub>t x t') ts)"
| "subst\<^sub>t\<^sub>t x t' (Variant ts) = Variant (map (subst\<^sub>t\<^sub>t x t') ts)"
| "subst\<^sub>t\<^sub>t x t' (Inductive k t) = Inductive k (subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t 0 t') t)"
| "subst\<^sub>t\<^sub>t x t' (Forall k t) = Forall k (subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t 0 t') t)"

lemma [simp]: "y \<le> x \<Longrightarrow> incr\<^sub>t\<^sub>t y o incr\<^sub>t\<^sub>t x = incr\<^sub>t\<^sub>t (Suc x) o incr\<^sub>t\<^sub>t y"
  by rule simp

lemma subst_incr_swap [simp]: "y \<le> x \<Longrightarrow>
    subst\<^sub>t\<^sub>t y (incr\<^sub>t\<^sub>t x t') (incr\<^sub>t\<^sub>t (Suc x) t) = incr\<^sub>t\<^sub>t x (subst\<^sub>t\<^sub>t y t' t)"
  by (induction t arbitrary: x y t') auto

lemma [simp]: "y \<le> x \<Longrightarrow> subst\<^sub>t\<^sub>t y (incr\<^sub>t\<^sub>t x t') o incr\<^sub>t\<^sub>t (Suc x) = incr\<^sub>t\<^sub>t x o subst\<^sub>t\<^sub>t y t'"
  by rule simp

lemma [simp]: "subst\<^sub>t\<^sub>t x t' (incr\<^sub>t\<^sub>t x t) = t"
  proof (induction t arbitrary: x t')
  case (Record ts)
    thus ?case by (induction ts) simp_all
  next case (Variant ts)
    thus ?case by (induction ts) simp_all
  qed simp_all

lemma [simp]: "subst\<^sub>t\<^sub>t x t' o incr\<^sub>t\<^sub>t x = id"
  by rule simp

lemma [simp]: "y \<le> x \<Longrightarrow> incr\<^sub>t\<^sub>t y (subst\<^sub>t\<^sub>t x t' t) = subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t y t') (incr\<^sub>t\<^sub>t y t)"
  by (induction t arbitrary: x y t') auto

lemma [simp]: "y \<le> x \<Longrightarrow> incr\<^sub>t\<^sub>t y \<circ> subst\<^sub>t\<^sub>t x t' = subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t y t') \<circ> incr\<^sub>t\<^sub>t y"
  by rule simp

lemma [simp]: "y \<le> x \<Longrightarrow>
    subst\<^sub>t\<^sub>t x t\<^sub>1' (subst\<^sub>t\<^sub>t y t\<^sub>2' t) = subst\<^sub>t\<^sub>t y (subst\<^sub>t\<^sub>t x t\<^sub>1' t\<^sub>2') (subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t y t\<^sub>1') t)"
  by (induction t arbitrary: x y t\<^sub>1' t\<^sub>2') auto

lemma [simp]: "y \<le> x \<Longrightarrow>
    subst\<^sub>t\<^sub>t x t\<^sub>1' o subst\<^sub>t\<^sub>t y t\<^sub>2' = subst\<^sub>t\<^sub>t y (subst\<^sub>t\<^sub>t x t\<^sub>1' t\<^sub>2') o subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t y t\<^sub>1')"
  by rule simp

end


section \<open>Solving the puzzle\<close>

theory Puzzle_Bottom_Up
imports Parity_Swap "../lib/Lib"
begin

subsubsection \<open>Individual choice function\<close>

text \<open>Given a list of all hat numbers either @{text seen} or @{text heard}, we can reconstruct
      the set of all hat numbers from the length of that list. Excluding the members from the\<close>

definition
  "candidates xs \<equiv> {0 .. 1 + length xs} - set xs"

definition
  choice :: "nat list \<Rightarrow> nat list \<Rightarrow> nat"
where
  "choice heard seen \<equiv>
    case sorted_list_of_set (candidates (heard @ seen)) of
      [a,b] \<Rightarrow> if parity (a # heard @ b # seen) then b else a"

subsubsection \<open>Group choice function\<close>

primrec
  choices' :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "choices' heard [] = []"
| "choices' heard (_ # seen)
    = (let c = choice heard seen in c # choices' (heard @ [c]) seen)"

definition "choices \<equiv> choices' []"

subsubsection \<open>Examples\<close>

definition "example_even \<equiv> [4,2,3,6,0,5]"
lemma "parity (1 # example_even)" by eval
lemma "choices example_even = [4,2,3,6,0,5]" by eval

definition "example_odd \<equiv> [4,0,3,6,2,5]"
lemma "\<not> parity (1 # example_odd)" by eval
lemma "choices example_odd = [1,0,3,6,2,5]" by eval

subsubsection \<open>Group choice does not cheat\<close>

lemma choices':
  assumes "i < length assigned"
  assumes "spoken = choices' heard assigned"
  shows "spoken ! i = choice (heard @ take i spoken) (drop (Suc i) assigned)"
  using assms proof (induct assigned arbitrary: i spoken heard)
    case Cons thus ?case by (cases i) (auto simp: Let_def)
  qed simp

lemma choices:
  assumes "i < length assigned"
  assumes "spoken = choices assigned"
  shows "spoken ! i = choice (take i spoken) (drop (Suc i) assigned)"
  using assms by (simp add: choices_def choices')

subsubsection \<open>Group choice has the correct length\<close>

lemma choices'_length: "length (choices' heard assigned) = length assigned"
  by (induct assigned arbitrary: heard) (auto simp: Let_def)

lemma choices_length: "length (choices assigned) = length assigned"
  by (simp add: choices_def choices'_length)

subsection \<open>Correctness of choice function\<close>

context
  fixes spare :: "nat"
  fixes assigned :: "nat list"
  assumes assign: "set (spare # assigned) = {0 .. length assigned}"
begin

lemma distinct: "distinct (spare # assigned)"
  apply (rule card_distinct)
  apply (subst assign)
  by auto

lemma distinct_pointwise:
  assumes "i < length assigned"
  shows "spare \<noteq> assigned ! i
           \<and> (\<forall> j < length assigned. i \<noteq> j \<longrightarrow> assigned ! i \<noteq> assigned ! j)"
  using assms distinct by (auto simp: nth_eq_iff_index_eq)

context
  fixes spoken :: "nat list"
  assumes spoken: "spoken = choices assigned"
begin

lemma spoken_length: "length spoken = length assigned"
  using choices_length spoken by simp

lemma spoken_choice:
  "i < length assigned \<Longrightarrow> spoken ! i = choice (take i spoken) (drop (Suc i) assigned)"
  using choices spoken by simp

context
  assumes exists: "0 < length assigned"
  notes parity.simps(2) [simp del]
begin

lemmas assigned_0
  = Cons_nth_drop_Suc[OF exists, simplified]

lemma candidates_0:
  "candidates (drop (Suc 0) assigned) = {spare, assigned ! 0}"
  proof -
    have len: "1 + length (drop (Suc 0) assigned) = length assigned"
      using exists by simp
    have set: "set (drop (Suc 0) assigned) = {0..length assigned} - {spare, assigned ! 0}"
      using Diff_insert2 Diff_insert_absorb assign assigned_0 distinct
            distinct.simps(2) list.simps(15)
      by metis
    show ?thesis
      unfolding candidates_def len set
      unfolding Diff_Diff_Int subset_absorb_r
      unfolding assign[symmetric]
      using exists by auto
  qed

lemma spoken_0:
  "spoken ! 0 = (if parity (spare # assigned) then assigned ! 0 else spare)"
  unfolding spoken_choice[OF exists] choice_def take_0 append_Nil candidates_0
  using parity_swap_adj[where as="[]"] assigned_0 distinct_pointwise[OF exists]
  by (cases "assigned ! 0 < spare") auto

context
  fixes rejected :: "nat"
  fixes initial_order :: "nat list"
  assumes rejected: "rejected = (if parity (spare # assigned) then spare else assigned ! 0)"
  assumes initial_order: "initial_order = rejected # spoken ! 0 # drop (Suc 0) assigned"
begin

lemma parity_initial: "parity initial_order"
  unfolding initial_order spoken_0 rejected
  using parity_swap_adj[of "assigned ! 0" "spare" "[]"]
        distinct_pointwise[OF exists] assigned_0
  by auto

lemma distinct_initial: "distinct initial_order"
  unfolding initial_order rejected spoken_0
  using assigned_0 distinct distinct_length_2_or_more
  by (metis (full_types))

lemma set_initial: "set initial_order = {0..length assigned}"
  unfolding initial_order assign[symmetric] rejected spoken_0
  using arg_cong[where f=set, OF assigned_0, symmetric]
  by auto

lemma spoken_correct:
  "i \<in> {1 ..< length assigned} \<Longrightarrow> spoken ! i = assigned ! i"
  proof (induction i rule: nat_less_induct)
    case (1 i)

    have
      LB: "0 < i" and UB: "i < length assigned" and US: "i < length spoken" and
      IH: "\<forall> j \<in> {1 ..< i}. spoken ! j = assigned ! j"
      using 1 spoken_length by auto

    let ?heard = "take i spoken"
    let ?seen  = "drop (Suc i) assigned"

    have heard: "?heard = spoken ! 0 # map (op ! assigned) [Suc 0 ..< i]"
      using IH take_map_nth[OF less_imp_le, OF US] range_extract_head[OF LB] by auto

    let ?my_order = "rejected # ?heard @ assigned ! i # ?seen"

    have initial_order: "?my_order = initial_order"
      unfolding initial_order heard
      apply (simp add: UB Cons_nth_drop_Suc)
      apply (subst drop_map_nth[OF less_imp_le_nat, OF UB])
      apply (subst drop_map_nth[OF Suc_leI[OF exists]])
      apply (subst map_append[symmetric])
      apply (rule arg_cong[where f="map _"])
      apply (rule range_app)
      using UB LB less_imp_le Suc_le_eq by auto

    have distinct_my_order: "distinct ?my_order"
      using distinct_initial initial_order by simp

    have set_my_order: "set ?my_order = {0..length assigned}"
      using set_initial initial_order by simp

    have set: "set (?heard @ ?seen) = {0..length assigned} - {rejected, assigned ! i}"
      apply (rule subset_minusI)
      using distinct_my_order set_my_order by auto

    have len: "1 + length (?heard @ ?seen) = length assigned"
      using LB UB heard by simp

    have candidates: "candidates (?heard @ ?seen) = {rejected, assigned ! i}"
      unfolding candidates_def len set
      unfolding Diff_Diff_Int subset_absorb_r
      unfolding assign[symmetric]
      unfolding rejected
      using UB exists by auto

    show ?case
      apply (simp only: spoken_choice[OF UB] choice_def candidates)
      apply (subst sorted_list_of_set_distinct_pair)
       using distinct_my_order apply auto[1]
      apply (cases "assigned ! i < rejected"; clarsimp)
       apply (subst (asm) parity_swap[of _ _ _ "[]", simplified])
        apply (simp add: distinct_my_order[simplified])
       unfolding initial_order
       using parity_initial
       by auto
  qed

end
end
end

lemma choices_correct:
  "i \<in> {1 ..< length assigned} \<Longrightarrow> choices assigned ! i = assigned ! i"
  apply (rule spoken_correct) by auto

lemma choices_distinct: "distinct (choices assigned)"
  proof (cases "0 < length assigned")
    case True show ?thesis
    apply (clarsimp simp: distinct_conv_nth_less choices_length)
    apply (case_tac "i = 0")
    using True choices_correct spoken_0[OF _ True] distinct_pointwise
    by (auto split: if_splits)
  next
    case False thus ?thesis using choices_length[of assigned] by simp
  qed

end

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Concrete Matrices\<close>

theory DL_Concrete_Matrices
imports Jordan_Normal_Form.Matrix
begin

text \<open>The following definition allows non-square-matrices, mat\_one (mat\_one n) only allows square matrices.\<close>

definition id_matrix::"nat \<Rightarrow> nat \<Rightarrow> real mat"
where "id_matrix nr nc = mat nr nc (\<lambda>(r, c). if r=c then 1 else 0)"

lemma id_matrix_dim: "dim_row (id_matrix nr nc) = nr" "dim_col (id_matrix nr nc) = nc" by (simp_all add: id_matrix_def)

lemma unit_eq_0[simp]:
  assumes i: "i \<ge> n"
  shows "unit_vec n i = 0\<^sub>v n"
  by (rule eq_vecI, insert i, auto simp: unit_vec_def)

lemma mult_id_matrix:
assumes "i < nr"
shows "(id_matrix nr (dim_vec v) *\<^sub>v v) $ i = (if i<dim_vec v then v $ i else 0)" (is "?a $ i = ?b")
proof -
  have "?a $ i = row (id_matrix nr (dim_vec v)) i \<bullet> v" using index_mult_mat_vec assms id_matrix_dim by auto
  also have "... = unit_vec (dim_vec v) i \<bullet> v" using row_id_matrix assms by auto
  also have "... = ?b" using scalar_prod_left_unit carrier_vecI unit_eq_0 scalar_prod_left_zero by fastforce
  finally show ?thesis by auto
qed

definition all1_vec::"nat \<Rightarrow> real vec"
where "all1_vec n = vec n (\<lambda>i. 1)"

definition all1_matrix::"nat \<Rightarrow> nat \<Rightarrow> real mat"
where "all1_matrix nr nc = mat nr nc (\<lambda>(r, c). 1)"

lemma all1_matrix_dim: "dim_row (all1_matrix nr nc) = nr" "dim_col (all1_matrix nr nc) = nc"
  by (simp_all add: all1_matrix_def)

lemma row_all1_matrix:
assumes "i < nr"
shows "row (all1_matrix nr nc) i = all1_vec nc"
  apply (rule eq_vecI)
  apply (simp add: all1_matrix_def all1_vec_def assms)
  by (simp add: all1_matrix_def all1_vec_def)

lemma all1_vec_scalar_prod:
shows "all1_vec (length xs) \<bullet> (vec_of_list xs) = sum_list xs"
proof -
  have "all1_vec (length xs) \<bullet> (vec_of_list xs) = (\<Sum>i = 0..<dim_vec (vec_of_list xs). vec_of_list xs $ i)"
    unfolding scalar_prod_def by (metis (no_types, lifting) all1_vec_def mult_cancel_right1 sum.ivl_cong
    vec.abs_eq dim_vec index_vec vec_of_list.abs_eq)
  also have "... = (\<Sum>i = 0..<length xs. xs ! i)" using vec.abs_eq dim_vec vec_of_list.abs_eq
    by (metis sum.ivl_cong index_vec)
  also have "... = sum_list xs" by (simp add: sum_list_sum_nth)
  finally show ?thesis by auto
qed

lemma mult_all1_matrix:
assumes "i < nr"
shows "((all1_matrix nr (dim_vec v)) *\<^sub>v v) $ i = sum_list (list_of_vec v)" (is "?a $ i = sum_list (list_of_vec v)")
proof -
  have "?a $ i = row (all1_matrix nr (dim_vec v)) i \<bullet> v" using index_mult_mat_vec assms all1_matrix_dim by auto
  also have "... = sum_list (list_of_vec v)" unfolding row_all1_matrix[OF assms] using all1_vec_scalar_prod[of "list_of_vec v"]
    by (metis vec.abs_eq dim_vec vec_list vec_of_list.abs_eq)
  finally show ?thesis by auto
qed

definition copy_first_matrix::"nat \<Rightarrow> nat \<Rightarrow> real mat"
where "copy_first_matrix nr nc = mat nr nc (\<lambda>(r, c). if c = 0 then 1 else 0)"

lemma copy_first_matrix_dim: "dim_row (copy_first_matrix nr nc) = nr" "dim_col (copy_first_matrix nr nc) = nc"
  by (simp_all add: copy_first_matrix_def)

lemma row_copy_first_matrix:
assumes "i < nr"
shows "row (copy_first_matrix nr nc) i = unit_vec nc 0"
  apply (rule eq_vecI)
  apply (auto simp add: copy_first_matrix_def assms)[1]
  by (simp add: copy_first_matrix_def)

lemma mult_copy_first_matrix:
assumes "i < nr" and "dim_vec v > 0"
shows "(copy_first_matrix nr (dim_vec v) *\<^sub>v v) $ i = v $ 0" (is "?a $ i = v $ 0")
proof -
  have "?a $ i = row (copy_first_matrix nr (dim_vec v)) i \<bullet> v" using index_mult_mat_vec assms copy_first_matrix_dim by auto
  also have "... = unit_vec (dim_vec v) 0 \<bullet> v" using row_copy_first_matrix assms by auto
  also have "... = v $ 0" using assms(2) scalar_prod_left_unit carrier_dim_vec by blast
  finally show ?thesis by auto
qed

end


(*  Title:      HOL/UNITY/ListOrder.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Lists are partially ordered by Charpentier's Generalized Prefix Relation
   (xs,ys) : genPrefix(r)
     if ys = xs' @ zs where length xs = length xs'
     and corresponding elements of xs, xs' are pairwise related by r

Also overloads <= and < for lists!
*)

section \<open>The Prefix Ordering on Lists\<close>

theory ListOrder
imports MainRLT
begin

inductive_set
  genPrefix :: "('a * 'a)set => ('a list * 'a list)set"
  for r :: "('a * 'a)set"
 where
   Nil:     "([],[]) \<in> genPrefix(r)"

 | prepend: "[| (xs,ys) \<in> genPrefix(r);  (x,y) \<in> r |] ==>
             (x#xs, y#ys) \<in> genPrefix(r)"

 | append:  "(xs,ys) \<in> genPrefix(r) ==> (xs, ys@zs) \<in> genPrefix(r)"

instantiation list :: (type) ord
begin

definition
  prefix_def:        "xs <= zs \<longleftrightarrow>  (xs, zs) \<in> genPrefix Id"

definition
  strict_prefix_def: "xs < zs  \<longleftrightarrow>  xs \<le> zs \<and> \<not> zs \<le> (xs :: 'a list)"

instance ..

(*Constants for the <= and >= relations, used below in translations*)

end

definition Le :: "(nat*nat) set" where
    "Le == {(x,y). x <= y}"

definition  Ge :: "(nat*nat) set" where
    "Ge == {(x,y). y <= x}"

abbreviation
  pfixLe :: "[nat list, nat list] => bool"  (infixl "pfixLe" 50)  where
  "xs pfixLe ys == (xs,ys) \<in> genPrefix Le"

abbreviation
  pfixGe :: "[nat list, nat list] => bool"  (infixl "pfixGe" 50)  where
  "xs pfixGe ys == (xs,ys) \<in> genPrefix Ge"

subsection\<open>preliminary lemmas\<close>

lemma Nil_genPrefix [iff]: "([], xs) \<in> genPrefix r"
by (cut_tac genPrefix.Nil [THEN genPrefix.append], auto)

lemma genPrefix_length_le: "(xs,ys) \<in> genPrefix r \<Longrightarrow> length xs <= length ys"
by (erule genPrefix.induct, auto)

lemma cdlemma:
     "[| (xs', ys') \<in> genPrefix r |]
      ==> (\<forall>x xs. xs' = x#xs \<longrightarrow> (\<exists>y ys. ys' = y#ys & (x,y) \<in> r & (xs, ys) \<in> genPrefix r))"
apply (erule genPrefix.induct, blast, blast)
apply (force intro: genPrefix.append)
done

(*As usual converting it to an elimination rule is tiresome*)
lemma cons_genPrefixE [elim!]:
     "[| (x#xs, zs) \<in> genPrefix r;
         !!y ys. [| zs = y#ys;  (x,y) \<in> r;  (xs, ys) \<in> genPrefix r |] ==> P
      |] ==> P"
by (drule cdlemma, simp, blast)

lemma Cons_genPrefix_Cons [iff]:
     "((x#xs,y#ys) \<in> genPrefix r) = ((x,y) \<in> r \<and> (xs,ys) \<in> genPrefix r)"
by (blast intro: genPrefix.prepend)

subsection\<open>genPrefix is a partial order\<close>

lemma refl_genPrefix: "refl r ==> refl (genPrefix r)"
apply (unfold refl_on_def, auto)
apply (induct_tac "x")
prefer 2 apply (blast intro: genPrefix.prepend)
apply (blast intro: genPrefix.Nil)
done

lemma genPrefix_refl [simp]: "refl r \<Longrightarrow> (l,l) \<in> genPrefix r"
by (erule refl_onD [OF refl_genPrefix UNIV_I])

lemma genPrefix_mono: "r<=s ==> genPrefix r <= genPrefix s"
apply clarify
apply (erule genPrefix.induct)
apply (auto intro: genPrefix.append)
done

(** Transitivity **)

(*A lemma for proving genPrefix_trans_O*)
lemma append_genPrefix:
     "(xs @ ys, zs) \<in> genPrefix r \<Longrightarrow> (xs, zs) \<in> genPrefix r"
  by (induct xs arbitrary: zs) auto

(*Lemma proving transitivity and more*)
lemma genPrefix_trans_O:
  assumes "(x, y) \<in> genPrefix r"
  shows "\<And>z. (y, z) \<in> genPrefix s \<Longrightarrow> (x, z) \<in> genPrefix (r O s)"
  apply (atomize (full))
  using assms
  apply induct
    apply blast
   apply (blast intro: genPrefix.prepend)
  apply (blast dest: append_genPrefix)
  done

lemma genPrefix_trans:
  "(x, y) \<in> genPrefix r \<Longrightarrow> (y, z) \<in> genPrefix r \<Longrightarrow> trans r
    \<Longrightarrow> (x, z) \<in> genPrefix r"
  apply (rule trans_O_subset [THEN genPrefix_mono, THEN subsetD])
   apply assumption
  apply (blast intro: genPrefix_trans_O)
  done

lemma prefix_genPrefix_trans:
  "[| x<=y;  (y,z) \<in> genPrefix r |] ==> (x, z) \<in> genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma genPrefix_prefix_trans:
  "[| (x,y) \<in> genPrefix r;  y<=z |] ==> (x,z) \<in> genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma trans_genPrefix: "trans r ==> trans (genPrefix r)"
by (blast intro: transI genPrefix_trans)

(** Antisymmetry **)

lemma genPrefix_antisym:
  assumes 1: "(xs, ys) \<in> genPrefix r"
    and 2: "antisym r"
    and 3: "(ys, xs) \<in> genPrefix r"
  shows "xs = ys"
  using 1 3
proof induct
  case Nil
  then show ?case by blast
next
  case prepend
  then show ?case using 2 by (simp add: antisym_def)
next
  case (append xs ys zs)
  then show ?case
    apply -
    apply (subgoal_tac "length zs = 0", force)
    apply (drule genPrefix_length_le)+
    apply (simp del: length_0_conv)
    done
qed

lemma antisym_genPrefix: "antisym r ==> antisym (genPrefix r)"
  by (blast intro: antisymI genPrefix_antisym)

subsection\<open>recursion equations\<close>

lemma genPrefix_Nil [simp]: "((xs, []) \<in> genPrefix r) = (xs = [])"
  by (induct xs) auto

lemma same_genPrefix_genPrefix [simp]:
    "refl r \<Longrightarrow> ((xs@ys, xs@zs) \<in> genPrefix r) = ((ys,zs) \<in> genPrefix r)"
  by (induct xs) (simp_all add: refl_on_def)

lemma genPrefix_Cons:
     "((xs, y#ys) \<in> genPrefix r) =
      (xs=[] | (\<exists>z zs. xs=z#zs & (z,y) \<in> r & (zs,ys) \<in> genPrefix r))"
  by (cases xs) auto

lemma genPrefix_take_append:
     "[| refl r;  (xs,ys) \<in> genPrefix r |]
      ==>  (xs@zs, take (length xs) ys @ zs) \<in> genPrefix r"
apply (erule genPrefix.induct)
apply (frule_tac [3] genPrefix_length_le)
apply (simp_all (no_asm_simp) add: diff_is_0_eq [THEN iffD2])
done

lemma genPrefix_append_both:
     "[| refl r;  (xs,ys) \<in> genPrefix r;  length xs = length ys |]
      ==>  (xs@zs, ys @ zs) \<in> genPrefix r"
apply (drule genPrefix_take_append, assumption)
apply simp
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_eq: "xs @ y # ys = (xs @ [y]) @ ys"
by auto

lemma aolemma:
     "[| (xs,ys) \<in> genPrefix r;  refl r |]
      ==> length xs < length ys \<longrightarrow> (xs @ [ys ! length xs], ys) \<in> genPrefix r"
apply (erule genPrefix.induct)
  apply blast
 apply simp
txt\<open>Append case is hardest\<close>
apply simp
apply (frule genPrefix_length_le [THEN le_imp_less_or_eq])
apply (erule disjE)
apply (simp_all (no_asm_simp) add: neq_Nil_conv nth_append)
apply (blast intro: genPrefix.append, auto)
apply (subst append_cons_eq, fast intro: genPrefix_append_both genPrefix.append)
done

lemma append_one_genPrefix:
     "[| (xs,ys) \<in> genPrefix r;  length xs < length ys;  refl r |]
      ==> (xs @ [ys ! length xs], ys) \<in> genPrefix r"
by (blast intro: aolemma [THEN mp])

(** Proving the equivalence with Charpentier's definition **)

lemma genPrefix_imp_nth:
    "i < length xs \<Longrightarrow> (xs, ys) \<in> genPrefix r \<Longrightarrow> (xs ! i, ys ! i) \<in> r"
  apply (induct xs arbitrary: i ys)
   apply auto
  apply (case_tac i)
   apply auto
  done

lemma nth_imp_genPrefix:
  "length xs <= length ys \<Longrightarrow>
     (\<forall>i. i < length xs \<longrightarrow> (xs ! i, ys ! i) \<in> r) \<Longrightarrow>
     (xs, ys) \<in> genPrefix r"
  apply (induct xs arbitrary: ys)
   apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib)
  apply (case_tac ys)
   apply (force+)
  done

lemma genPrefix_iff_nth:
     "((xs,ys) \<in> genPrefix r) =
      (length xs <= length ys & (\<forall>i. i < length xs \<longrightarrow> (xs!i, ys!i) \<in> r))"
apply (blast intro: genPrefix_length_le genPrefix_imp_nth nth_imp_genPrefix)
done

subsection\<open>The type of lists is partially ordered\<close>

declare refl_Id [iff]
        antisym_Id [iff]
        trans_Id [iff]

lemma prefix_refl [iff]: "xs <= (xs::'a list)"
by (simp add: prefix_def)

lemma prefix_trans: "!!xs::'a list. [| xs <= ys; ys <= zs |] ==> xs <= zs"
apply (unfold prefix_def)
apply (blast intro: genPrefix_trans)
done

lemma prefix_antisym: "!!xs::'a list. [| xs <= ys; ys <= xs |] ==> xs = ys"
apply (unfold prefix_def)
apply (blast intro: genPrefix_antisym)
done

lemma prefix_less_le_not_le: "!!xs::'a list. (xs < zs) = (xs <= zs & \<not> zs \<le> xs)"
by (unfold strict_prefix_def, auto)

instance list :: (type) order
  by (intro_classes,
      (assumption | rule prefix_refl prefix_trans prefix_antisym
                     prefix_less_le_not_le)+)

(*Monotonicity of "set" operator WRT prefix*)
lemma set_mono: "xs <= ys ==> set xs <= set ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

(** recursion equations **)

lemma Nil_prefix [iff]: "[] <= xs"
by (simp add: prefix_def)

lemma prefix_Nil [simp]: "(xs <= []) = (xs = [])"
by (simp add: prefix_def)

lemma Cons_prefix_Cons [simp]: "(x#xs <= y#ys) = (x=y & xs<=ys)"
by (simp add: prefix_def)

lemma same_prefix_prefix [simp]: "(xs@ys <= xs@zs) = (ys <= zs)"
by (simp add: prefix_def)

lemma append_prefix [iff]: "(xs@ys <= xs) = (ys <= [])"
by (insert same_prefix_prefix [of xs ys "[]"], simp)

lemma prefix_appendI [simp]: "xs <= ys ==> xs <= ys@zs"
apply (unfold prefix_def)
apply (erule genPrefix.append)
done

lemma prefix_Cons:
   "(xs <= y#ys) = (xs=[] | (\<exists>zs. xs=y#zs \<and> zs <= ys))"
by (simp add: prefix_def genPrefix_Cons)

lemma append_one_prefix:
  "[| xs <= ys; length xs < length ys |] ==> xs @ [ys ! length xs] <= ys"
apply (unfold prefix_def)
apply (simp add: append_one_genPrefix)
done

lemma prefix_length_le: "xs <= ys ==> length xs <= length ys"
apply (unfold prefix_def)
apply (erule genPrefix_length_le)
done

lemma splemma: "xs<=ys ==> xs~=ys --> length xs < length ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

lemma strict_prefix_length_less: "xs < ys ==> length xs < length ys"
apply (unfold strict_prefix_def)
apply (blast intro: splemma [THEN mp])
done

lemma mono_length: "mono length"
by (blast intro: monoI prefix_length_le)

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff: "(xs <= zs) = (\<exists>ys. zs = xs@ys)"
apply (unfold prefix_def)
apply (auto simp add: genPrefix_iff_nth nth_append)
apply (rule_tac x = "drop (length xs) zs" in exI)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append)
done

lemma prefix_snoc [simp]: "(xs <= ys@[y]) = (xs = ys@[y] | xs <= ys)"
apply (simp add: prefix_iff)
apply (rule iffI)
 apply (erule exE)
 apply (rename_tac "zs")
 apply (rule_tac xs = zs in rev_exhaust)
  apply simp
 apply clarify
 apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

lemma prefix_append_iff:
     "(xs <= ys@zs) = (xs <= ys | (\<exists>us. xs = ys@us & us <= zs))"
apply (rule_tac xs = zs in rev_induct)
 apply force
apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear:
  fixes xs ys zs :: "'a list"
  shows "xs <= zs \<Longrightarrow> ys <= zs \<Longrightarrow> xs <= ys | ys <= xs"
  by (induct zs rule: rev_induct) auto

subsection\<open>pfixLe, pfixGe: properties inherited from the translations\<close>

(** pfixLe **)

lemma refl_Le [iff]: "refl Le"
by (unfold refl_on_def Le_def, auto)

lemma antisym_Le [iff]: "antisym Le"
by (unfold antisym_def Le_def, auto)

lemma trans_Le [iff]: "trans Le"
by (unfold trans_def Le_def, auto)

lemma pfixLe_refl [iff]: "x pfixLe x"
by simp

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: genPrefix_trans)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixLe: "xs<=ys ==> xs pfixLe ys"
apply (unfold prefix_def Le_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

lemma refl_Ge [iff]: "refl Ge"
by (unfold refl_on_def Ge_def, auto)

lemma antisym_Ge [iff]: "antisym Ge"
by (unfold antisym_def Ge_def, auto)

lemma trans_Ge [iff]: "trans Ge"
by (unfold trans_def Ge_def, auto)

lemma pfixGe_refl [iff]: "x pfixGe x"
by simp

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: genPrefix_trans)

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixGe: "xs<=ys ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

end


(*  Title:      HOL/ex/Set_Theory.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1991  University of Cambridge
*)

section {* Set Theory examples: Cantor's Theorem, Schröder-Bernstein Theorem, etc. *}

theory Set_Theory
imports Main
begin

text{*
  These two are cited in Benzmueller and Kohlhase's system description
  of LEO, CADE-15, 1998 (pages 139-143) as theorems LEO could not
  prove.
*}

lemma "(X = Y \<union> Z) =
    (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
  by blast

lemma "(X = Y \<inter> Z) =
    (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
  by blast

text {*
  Trivial example of term synthesis: apparently hard for some provers!
*}

schematic_lemma "a \<noteq> b \<Longrightarrow> a \<in> ?X \<and> b \<notin> ?X"
  by blast

subsection {* Examples for the @{text blast} paper *}

lemma "(\<Union>x \<in> C. f x \<union> g x) = \<Union>(f ` C)  \<union>  \<Union>(g ` C)"
  -- {* Union-image, called @{text Un_Union_image} in Main HOL *}
  by blast

lemma "(\<Inter>x \<in> C. f x \<inter> g x) = \<Inter>(f ` C) \<inter> \<Inter>(g ` C)"
  -- {* Inter-image, called @{text Int_Inter_image} in Main HOL *}
  by blast

lemma singleton_example_1:
     "\<And>S::'a set set. \<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  by blast

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  -- {*Variant of the problem above. *}
  by blast

lemma "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
  -- {* A unique fixpoint theorem --- @{text fast}/@{text best}/@{text meson} all fail. *}
  by metis

subsection {* Cantor's Theorem: There is no surjection from a set to its powerset *}

lemma cantor1: "\<not> (\<exists>f:: 'a \<Rightarrow> 'a set. \<forall>S. \<exists>x. f x = S)"
  -- {* Requires best-first search because it is undirectional. *}
  by best

schematic_lemma "\<forall>f:: 'a \<Rightarrow> 'a set. \<forall>x. f x \<noteq> ?S f"
  -- {*This form displays the diagonal term. *}
  by best

schematic_lemma "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  -- {* This form exploits the set constructs. *}
  by (rule notI, erule rangeE, best)

schematic_lemma "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  -- {* Or just this! *}
  by best

subsection {* The Schröder-Berstein Theorem *}

lemma disj_lemma: "- (f ` X) = g ` (-X) \<Longrightarrow> f a = g b \<Longrightarrow> a \<in> X \<Longrightarrow> b \<in> X"
  by blast

lemma surj_if_then_else:
  "-(f ` X) = g ` (-X) \<Longrightarrow> surj (\<lambda>z. if z \<in> X then f z else g z)"
  by (simp add: surj_def) blast

lemma bij_if_then_else:
  "inj_on f X \<Longrightarrow> inj_on g (-X) \<Longrightarrow> -(f ` X) = g ` (-X) \<Longrightarrow>
    h = (\<lambda>z. if z \<in> X then f z else g z) \<Longrightarrow> inj h \<and> surj h"
  apply (unfold inj_on_def)
  apply (simp add: surj_if_then_else)
  apply (blast dest: disj_lemma sym)
  done

lemma decomposition: "\<exists>X. X = - (g ` (- (f ` X)))"
  apply (rule exI)
  apply (rule lfp_unfold)
  apply (rule monoI, blast)
  done

theorem Schroeder_Bernstein:
  "inj (f :: 'a \<Rightarrow> 'b) \<Longrightarrow> inj (g :: 'b \<Rightarrow> 'a)
    \<Longrightarrow> \<exists>h:: 'a \<Rightarrow> 'b. inj h \<and> surj h"
  apply (rule decomposition [where f=f and g=g, THEN exE])
  apply (rule_tac x = "(\<lambda>z. if z \<in> x then f z else inv g z)" in exI)
    --{*The term above can be synthesized by a sufficiently detailed proof.*}
  apply (rule bij_if_then_else)
     apply (rule_tac [4] refl)
    apply (rule_tac [2] inj_on_inv_into)
    apply (erule subset_inj_on [OF _ subset_UNIV])
   apply blast
  apply (erule ssubst, subst double_complement, erule inv_image_comp [symmetric])
  done

subsection {* A simple party theorem *}

text{* \emph{At any party there are two people who know the same
number of people}. Provided the party consists of at least two people
and the knows relation is symmetric. Knowing yourself does not count
--- otherwise knows needs to be reflexive. (From Freek Wiedijk's talk
at TPHOLs 2007.) *}

lemma equal_number_of_acquaintances:
assumes "Domain R <= A" and "sym R" and "card A \<ge> 2"
shows "\<not> inj_on (%a. card(R `` {a} - {a})) A"
proof -
  let ?N = "%a. card(R `` {a} - {a})"
  let ?n = "card A"
  have "finite A" using `card A \<ge> 2` by(auto intro:ccontr)
  have 0: "R `` A <= A" using `sym R` `Domain R <= A`
    unfolding Domain_unfold sym_def by blast
  have h: "ALL a:A. R `` {a} <= A" using 0 by blast
  hence 1: "ALL a:A. finite(R `` {a})" using `finite A`
    by(blast intro: finite_subset)
  have sub: "?N ` A <= {0..<?n}"
  proof -
    have "ALL a:A. R `` {a} - {a} < A" using h by blast
    thus ?thesis using psubset_card_mono[OF `finite A`] by auto
  qed
  show "~ inj_on ?N A" (is "~ ?I")
  proof
    assume ?I
    hence "?n = card(?N ` A)" by(rule card_image[symmetric])
    with sub `finite A` have 2[simp]: "?N ` A = {0..<?n}"
      using subset_card_intvl_is_intvl[of _ 0] by(auto)
    have "0 : ?N ` A" and "?n - 1 : ?N ` A"  using `card A \<ge> 2` by simp+
    then obtain a b where ab: "a:A" "b:A" and Na: "?N a = 0" and Nb: "?N b = ?n - 1"
      by (auto simp del: 2)
    have "a \<noteq> b" using Na Nb `card A \<ge> 2` by auto
    have "R `` {a} - {a} = {}" by (metis 1 Na ab card_eq_0_iff finite_Diff)
    hence "b \<notin> R `` {a}" using `a\<noteq>b` by blast
    hence "a \<notin> R `` {b}" by (metis Image_singleton_iff assms(2) sym_def)
    hence 3: "R `` {b} - {b} <= A - {a,b}" using 0 ab by blast
    have 4: "finite (A - {a,b})" using `finite A` by simp
    have "?N b <= ?n - 2" using ab `a\<noteq>b` `finite A` card_mono[OF 4 3] by simp
    then show False using Nb `card A \<ge>  2` by arith
  qed
qed

text {*
  From W. W. Bledsoe and Guohui Feng, SET-VAR. JAR 11 (3), 1993, pages
  293-314.

  Isabelle can prove the easy examples without any special mechanisms,
  but it can't prove the hard ones.
*}

lemma "\<exists>A. (\<forall>x \<in> A. x \<le> (0::int))"
  -- {* Example 1, page 295. *}
  by force

lemma "D \<in> F \<Longrightarrow> \<exists>G. \<forall>A \<in> G. \<exists>B \<in> F. A \<subseteq> B"
  -- {* Example 2. *}
  by force

lemma "P a \<Longrightarrow> \<exists>A. (\<forall>x \<in> A. P x) \<and> (\<exists>y. y \<in> A)"
  -- {* Example 3. *}
  by force

lemma "a < b \<and> b < (c::int) \<Longrightarrow> \<exists>A. a \<notin> A \<and> b \<in> A \<and> c \<notin> A"
  -- {* Example 4. *}
  by auto --{*slow*}

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  -- {*Example 5, page 298. *}
  by force

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  -- {* Example 6. *}
  by force

lemma "\<exists>A. a \<notin> A"
  -- {* Example 7. *}
  by force

lemma "(\<forall>u v. u < (0::int) \<longrightarrow> u \<noteq> abs v)
    \<longrightarrow> (\<exists>A::int set. -2 \<in> A & (\<forall>y. abs y \<notin> A))"
  -- {* Example 8 needs a small hint. *}
  by force
    -- {* not @{text blast}, which can't simplify @{text "-2 < 0"} *}

text {* Example 9 omitted (requires the reals). *}

text {* The paper has no Example 10! *}

lemma "(\<forall>A. 0 \<in> A \<and> (\<forall>x \<in> A. Suc x \<in> A) \<longrightarrow> n \<in> A) \<and>
  P 0 \<and> (\<forall>x. P x \<longrightarrow> P (Suc x)) \<longrightarrow> P n"
  -- {* Example 11: needs a hint. *}
by(metis nat.induct)

lemma
  "(\<forall>A. (0, 0) \<in> A \<and> (\<forall>x y. (x, y) \<in> A \<longrightarrow> (Suc x, Suc y) \<in> A) \<longrightarrow> (n, m) \<in> A)
    \<and> P n \<longrightarrow> P m"
  -- {* Example 12. *}
  by auto

lemma
  "(\<forall>x. (\<exists>u. x = 2 * u) = (\<not> (\<exists>v. Suc x = 2 * v))) \<longrightarrow>
    (\<exists>A. \<forall>x. (x \<in> A) = (Suc x \<notin> A))"
  -- {* Example EO1: typo in article, and with the obvious fix it seems
      to require arithmetic reasoning. *}
  apply clarify
  apply (rule_tac x = "{x. \<exists>u. x = 2 * u}" in exI, auto)
   apply metis+
  done

end


theory Lists
  imports Basics
begin

section {* Lists *}

datatype natprod = pair "nat * nat"

fun fst :: "natprod \<Rightarrow> nat" where
  "fst (pair (x, y)) = x"

value "fst (pair (3, 5))"

fun snd :: "natprod \<Rightarrow> nat" where
  "snd (pair (x, y)) = y"

fun fst' :: "nat * nat \<Rightarrow> nat" where
  "fst' (x, y) = x"

value "fst' (3, 5)"

fun snd' :: "nat * nat \<Rightarrow> nat" where
  "snd' (x, y) = y"

fun swap_pair :: "natprod \<Rightarrow> natprod" where
  "swap_pair (pair (x, y)) = pair (y, x)"

fun swap_pair' :: "nat * nat \<Rightarrow> nat * nat" where
  "swap_pair' (x, y) = (y, x)"

theorem subjective_pairing': "\<forall> n m::nat. (n, m) = (fst'(n, m), snd'(n, m))" by simp

(* theorem subjective_pairing: "\<forall> p::natprod. p = pair (fst p, snd p)" *)
theorem subjective_pairing: "p = pair (fst p, snd p)"
  apply (induction p)
  apply (auto)
  done

theorem snd_fst_is_swap: "(snd' p, fst' p) = swap_pair' p"
  apply (induction p)
  apply (simp)
  done

theorem fst_swap_is_snd: "fst' (swap_pair' p) = snd' p"
  apply (induction p)
  apply (simp)
  done

no_notation Nil ("[]") and Cons (infixr "#" 65) and append (infixr "@" 65)

datatype natlist = Nil ("[]")
  | Cons nat "natlist" (infixr "#" 65)
hide_type list

fun repeat :: "nat \<Rightarrow> nat \<Rightarrow> natlist" where
  "repeat _ 0 = []"
| "repeat n (Suc count') = n # (repeat n count')"

fun length :: "natlist \<Rightarrow> nat" where
  "length [] = 0"
| "length (x # xs) = Suc (length xs)"

primrec app :: "natlist \<Rightarrow> natlist \<Rightarrow> natlist" (infixr "@" 65)
  where
  "[] @ ys = ys"
| "(x # xs) @ ys = x # (xs @ ys)"

lemma test_app1: "(1 # (2 # (3 # []))) @ (4 # (5 # [])) = 1 # 2 # 3 # 4 # 5 # []" by simp

fun hd :: "nat \<Rightarrow> natlist \<Rightarrow> nat" where
  "hd init [] = init"
| "hd _ (x # xs) = x"

fun tl :: "natlist \<Rightarrow> natlist" where
  "tl [] = []"
| "tl (x # xs) = xs"

lemma test_hd1: "hd 0 (1 # 2 # 3 # []) = 1" by simp
lemma test_hd2: "hd 0 [] = 0" by simp
lemma test_tl: "tl (1 # 2 # 3 # []) = 2 # 3 # []" by simp

fun nonzeros :: "natlist \<Rightarrow> natlist" where
  "nonzeros [] = []"
| "nonzeros (x # xs) = (if x = 0 then nonzeros xs else x # (nonzeros xs))"

lemma test_nonzeros: "nonzeros (0 # 1 # 0 # 2 # 3 # 0 # 0 # []) = 1 # 2 # 3 # []"
  apply (simp)
  done

fun oddmembers :: "natlist \<Rightarrow> natlist" where
  "oddmembers [] = []"
| "oddmembers (x # xs) = (if odd x then x # oddmembers xs else oddmembers xs)"

lemma test_oddmembers: "oddmembers (0 # 1 # 0 # 2 # 3 # 0 # 0 # []) = 1 # 3 # []"
  apply (simp)
  done

definition countoddmembers :: "natlist \<Rightarrow> nat" where
  "countoddmembers xs = length (oddmembers xs)"

lemma test_countoddmembers1: "countoddmembers (1 # 0 # 3 # 1 # 4 # 5 # []) = 4"
  unfolding countoddmembers_def
  apply (simp)
  done

lemma test_countoddmembers2: "countoddmembers (0 # 2 # 4 # []) = 0"
  unfolding countoddmembers_def
  apply (simp)
  done

lemma test_countoddmembers3: "countoddmembers [] = 0"
  unfolding countoddmembers_def
  apply (simp)
  done

subsection {* inferences *}

theorem nil_app: "\<forall> xs::natlist. [] @ xs = xs" by simp

(* theorem tl_length_pred: "\<forall> xs::natlist. pred (length xs) = length (tl xs)" *)
theorem tl_length_pred: "pred (length xs) = length (tl xs)"
  apply (induction xs)
   apply (simp_all)
  done

(* theorem app_assoc: "\<forall> xs ys::natlist. (xs @ ys) @zs = xs @ (ys @ zs)" *)
theorem app_assoc: "(xs @ ys) @zs = xs @ (ys @ zs)"
  apply (induction xs)
   apply (simp_all)
  done

fun rev :: "natlist \<Rightarrow> natlist" where
  "rev [] = []"
| "rev (x # xs) = (rev xs) @ (x # [])"

lemma test_rev1: "rev (1 # 2 # 3 # []) = 3 # 2 # 1 # []" by simp
lemma test_rev2: "rev [] = []" by simp

(* theorem app_length: "\<forall> xs ys::natlist. length (xs @ ys) = (length xs) + (length ys)" *)
theorem app_length: "length (xs @ ys) = (length xs) + (length ys)"
  apply (induct xs)
   apply (simp_all)
  done

(* theorem rev_length: "\<forall> xs::natlist. length (rev xs) = length xs" *)
theorem rev_length: "length (rev xs) = length xs"
  apply (induct xs)
   apply (simp)
  apply (simp add: app_length)
  done

(* theorem app_nil_r: "\<forall> xs::natlist. xs @ [] = xs" *)
theorem app_nil_r: "xs @ [] = xs"
  apply (induction xs)
   apply (simp_all)
  done

theorem rev_app_distr: "rev (xs @ ys) = rev ys @ rev xs"
  apply (induction xs)
   apply (simp add: app_nil_r)
  apply (simp add: app_assoc)
  done

theorem rev_involutive: "rev (rev xs) = xs"
  apply (induction xs)
   apply (auto)
  apply (simp add: rev_app_distr)
  done

end


theory ListLexorder
imports Main
begin

section\<open>Detour: Lexicographic ordering for lists\<close>
text\<open>Simplicial complexes are defined as sets of sets.
To conveniently run computations on them, we convert those sets to lists via @{const sorted_list_of_set}.
This requires providing an arbitrary linear order for lists.
We pick a lexicographic order.\<close>

(* There's probably an easier way to get a sorted list of lists from a set of lists. Some lexicographic ordering does have to exist. No idea... *)

datatype 'a :: linorder linorder_list = LinorderList "'a list"

definition "linorder_list_unwrap L \<equiv> case L of LinorderList L \<Rightarrow> L" (* Meh, there is a way to get datatype to generate this. I forgot *)

fun less_eq_linorder_list_pre where
  "less_eq_linorder_list_pre (LinorderList []) (LinorderList []) = True" |
  "less_eq_linorder_list_pre (LinorderList []) _ = True" |
  "less_eq_linorder_list_pre _ (LinorderList []) = False" |
  "less_eq_linorder_list_pre (LinorderList (a # as)) (LinorderList (b # bs))
    = (if a = b then less_eq_linorder_list_pre (LinorderList as) (LinorderList bs) else a < b)"

instantiation linorder_list :: (linorder) linorder
begin
definition "less_linorder_list x y \<equiv>
              (less_eq_linorder_list_pre x y \<and> \<not> less_eq_linorder_list_pre y x)"
definition "less_eq_linorder_list x y \<equiv> less_eq_linorder_list_pre x y"
instance
proof (standard; unfold less_eq_linorder_list_def less_linorder_list_def)
  fix x y z
  show "less_eq_linorder_list_pre x x"
  proof(induction x)
    case (LinorderList xa)
    then show ?case by(induction xa; simp)
  qed
  show "less_eq_linorder_list_pre x y \<Longrightarrow> less_eq_linorder_list_pre y x \<Longrightarrow> x = y"
    by(induction x y rule: less_eq_linorder_list_pre.induct; simp split: if_splits)
  show "less_eq_linorder_list_pre x y \<or> less_eq_linorder_list_pre y x"
    by(induction x y rule: less_eq_linorder_list_pre.induct; auto)
  show "less_eq_linorder_list_pre x y \<Longrightarrow> less_eq_linorder_list_pre y z \<Longrightarrow> less_eq_linorder_list_pre x z"
  proof(induction x z arbitrary: y rule: less_eq_linorder_list_pre.induct)
    case (3 va vb)
    then show ?case
      using less_eq_linorder_list_pre.elims(2) by blast
  next
    case (4 a1 as b1 bs)
    obtain y1 ys where y: "y = LinorderList (y1 # ys)"
      using "4.prems"(1) less_eq_linorder_list_pre.elims(2) by blast
    then show ?case proof(cases "a1 = b1")
      case True
      have prems: "less_eq_linorder_list_pre (LinorderList as) (LinorderList ys)" "less_eq_linorder_list_pre (LinorderList ys) (LinorderList bs)"
        by (metis "4.prems" True y less_eq_linorder_list_pre.simps(4) not_less_iff_gr_or_eq)+
      note IH = "4.IH"[OF _ this]
      then show ?thesis
        using True by simp

    next
      case False
        then show ?thesis using "4.prems" less_trans y by (simp  split: if_splits)
      qed
  qed simp_all
qed simp

end

text\<open>The main product of this theory file:\<close>
definition "sorted_list_of_list_set L \<equiv>
  map linorder_list_unwrap (sorted_list_of_set (LinorderList ` L))"

lemma set_sorted_list_of_list_set[simp]:
  "finite L \<Longrightarrow> set (sorted_list_of_list_set L) = L"
  by(force simp add: sorted_list_of_list_set_def linorder_list_unwrap_def)

end


theory "Syntax"
imports
  Complex_Main
  "Identifiers"
begin
section \<open>Syntax\<close>

text \<open>
  Defines the syntax of Differential Game Logic as inductively defined data types.
  \<^url>\<open>https://doi.org/10.1145/2817824\<close> \<^url>\<open>https://doi.org/10.1007/978-3-319-94205-6_15\<close>
\<close>

subsection \<open>Terms\<close>

text \<open>Numeric literals\<close>
type_synonym lit = real

text \<open>the set of all real variables\<close>
abbreviation allidents:: "ident set"
  where "allidents \<equiv> {x | x. True}"

text \<open>Variables and differential variables\<close>

datatype variable =
  RVar ident
| DVar ident

datatype trm =
  Var variable
| Number lit
| Const ident
| Func ident trm
| Plus trm trm
| Times trm trm
| Differential trm

subsection \<open>Formulas and Hybrid Games\<close>

datatype fml =
  Pred ident trm
| Geq trm trm
| Not fml                 ("!")
| And fml fml             (infixr "&&" 8)
| Exists variable fml
| Diamond game fml        ("(\<langle> _ \<rangle> _)" 20)
and game =
  Game ident
| Assign variable trm     (infixr ":=" 20)
| Test fml                ("?")
| Choice game game        (infixr "\<union>\<union>" 10)
| Compose game game       (infixr ";;" 8)
| Loop game               ("_**")
| Dual game               ("_^d")
| ODE ident trm

paragraph \<open>Derived operators\<close>
definition Neg ::"trm \<Rightarrow> trm"
where "Neg \<theta> = Times (Number (-1)) \<theta>"

definition Minus ::"trm \<Rightarrow> trm \<Rightarrow> trm"
where "Minus \<theta> \<eta> = Plus \<theta> (Neg \<eta>)"

definition Or :: "fml \<Rightarrow> fml \<Rightarrow> fml" (infixr "||" 7)
where "Or P Q = Not (And (Not P) (Not Q))"

definition Implies :: "fml \<Rightarrow> fml \<Rightarrow> fml" (infixr "\<rightarrow>" 10)
where "Implies P Q = Or Q (Not P)"

definition Equiv :: "fml \<Rightarrow> fml \<Rightarrow> fml" (infixr "\<leftrightarrow>" 10)
where "Equiv P Q = Or (And P Q) (And (Not P) (Not Q))"

definition Forall :: "variable \<Rightarrow> fml \<Rightarrow> fml"
where "Forall x P = Not (Exists x (Not P))"

definition Equals :: "trm \<Rightarrow> trm \<Rightarrow> fml"
where "Equals \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Geq \<theta>' \<theta>))"

definition Greater :: "trm \<Rightarrow> trm \<Rightarrow> fml"
where "Greater \<theta> \<theta>' = ((Geq \<theta> \<theta>') && (Not (Geq \<theta>' \<theta>)))"

text \<open>Justification: determinacy theorem justifies this equivalent syntactic abbreviation for box modalities from diamond modalities
  Theorem 3.1 \<^url>\<open>https://doi.org/10.1145/2817824\<close>\<close>
definition Box :: "game \<Rightarrow> fml \<Rightarrow> fml" ("([[_]]_)" 20)
where "Box \<alpha> P = Not (Diamond \<alpha> (Not P))"

definition TT ::"fml"
where "TT = Geq (Number 0) (Number 0)"

definition FF ::"fml"
where "FF = Geq (Number 0) (Number 1)"

definition Skip ::"game"
where "Skip = Test TT"

text \<open>Inference: premises, then conclusion\<close>
type_synonym inference = "fml list * fml"

type_synonym sequent = "fml list * fml list"
text \<open>Rule: premises, then conclusion\<close>
type_synonym rule = "sequent list * sequent"

subsection \<open>Structural Induction\<close>

text \<open>Induction principles for hybrid games owing to their mutually recursive definition with formulas \<close>

lemma game_induct [case_names Game Assign ODE Test Choice Compose Loop Dual]:
   "(\<And>a. P (Game a))
    \<Longrightarrow> (\<And>x \<theta>. P (Assign x \<theta>))
    \<Longrightarrow> (\<And>x \<theta>. P (ODE x \<theta>))
    \<Longrightarrow> (\<And>\<phi>. P (? \<phi>))
    \<Longrightarrow> (\<And>\<alpha> \<beta>. P \<alpha> \<Longrightarrow> P \<beta> \<Longrightarrow> P (\<alpha> \<union>\<union> \<beta>))
    \<Longrightarrow> (\<And>\<alpha> \<beta>. P \<alpha> \<Longrightarrow> P \<beta> \<Longrightarrow> P (\<alpha> ;; \<beta>))
    \<Longrightarrow> (\<And>\<alpha>. P \<alpha> \<Longrightarrow> P (\<alpha>**))
    \<Longrightarrow> (\<And>\<alpha>. P \<alpha> \<Longrightarrow> P (\<alpha>^d))
    \<Longrightarrow> P \<alpha>"
  by(induction rule: game.induct) (auto)

lemma fml_induct [case_names Pred Geq Not And Exists Diamond]:
  "(\<And>x \<theta>. P (Pred x \<theta>))
  \<Longrightarrow> (\<And>\<theta> \<eta>. P (Geq \<theta> \<eta>))
  \<Longrightarrow> (\<And>\<phi>. P \<phi> \<Longrightarrow> P (Not \<phi>))
  \<Longrightarrow> (\<And>\<phi> \<psi>. P \<phi> \<Longrightarrow> P \<psi> \<Longrightarrow> P (And \<phi> \<psi>))
  \<Longrightarrow> (\<And>x \<phi>. P \<phi> \<Longrightarrow> P (Exists x \<phi>))
  \<Longrightarrow> (\<And>\<alpha> \<phi>. P \<phi> \<Longrightarrow> P (Diamond \<alpha> \<phi>))
  \<Longrightarrow> P \<phi>"
  by (induction rule: fml.induct) (auto)

text \<open>the set of all variables\<close>
abbreviation allvars:: "variable set"
  where "allvars \<equiv> {x::variable. True}"

end


(*  Title       : Fact.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
    The integer version of factorial and other additions by Jeremy Avigad.
*)

section{*Factorial Function*}

theory Fact
imports Main
begin

class fact =
  fixes fact :: "'a \<Rightarrow> 'a"

instantiation nat :: fact
begin

fun
  fact_nat :: "nat \<Rightarrow> nat"
where
  fact_0_nat: "fact_nat 0 = Suc 0"
| fact_Suc: "fact_nat (Suc x) = Suc x * fact x"

instance ..

end

(* definitions for the integers *)

instantiation int :: fact

begin

definition
  fact_int :: "int \<Rightarrow> int"
where
  "fact_int x = (if x >= 0 then int (fact (nat x)) else 0)"

instance proof qed

end

subsection {* Set up Transfer *}

lemma transfer_nat_int_factorial:
  "(x::int) >= 0 \<Longrightarrow> fact (nat x) = nat (fact x)"
  unfolding fact_int_def
  by auto

lemma transfer_nat_int_factorial_closure:
  "x >= (0::int) \<Longrightarrow> fact x >= 0"
  by (auto simp add: fact_int_def)

declare transfer_morphism_nat_int[transfer add return:
    transfer_nat_int_factorial transfer_nat_int_factorial_closure]

lemma transfer_int_nat_factorial:
  "fact (int x) = int (fact x)"
  unfolding fact_int_def by auto

lemma transfer_int_nat_factorial_closure:
  "is_nat x \<Longrightarrow> fact x >= 0"
  by (auto simp add: fact_int_def)

declare transfer_morphism_int_nat[transfer add return:
    transfer_int_nat_factorial transfer_int_nat_factorial_closure]

subsection {* Factorial *}

lemma fact_0_int [simp]: "fact (0::int) = 1"
  by (simp add: fact_int_def)

lemma fact_1_nat [simp]: "fact (1::nat) = 1"
  by simp

lemma fact_Suc_0_nat [simp]: "fact (Suc 0) = Suc 0"
  by simp

lemma fact_1_int [simp]: "fact (1::int) = 1"
  by (simp add: fact_int_def)

lemma fact_plus_one_nat: "fact ((n::nat) + 1) = (n + 1) * fact n"
  by simp

lemma fact_plus_one_int:
  assumes "n >= 0"
  shows "fact ((n::int) + 1) = (n + 1) * fact n"
  using assms unfolding fact_int_def
  by (simp add: nat_add_distrib algebra_simps int_mult)

lemma fact_reduce_nat: "(n::nat) > 0 \<Longrightarrow> fact n = n * fact (n - 1)"
  apply (subgoal_tac "n = Suc (n - 1)")
  apply (erule ssubst)
  apply (subst fact_Suc)
  apply simp_all
  done

lemma fact_reduce_int: "(n::int) > 0 \<Longrightarrow> fact n = n * fact (n - 1)"
  apply (subgoal_tac "n = (n - 1) + 1")
  apply (erule ssubst)
  apply (subst fact_plus_one_int)
  apply simp_all
  done

lemma fact_nonzero_nat [simp]: "fact (n::nat) \<noteq> 0"
  apply (induct n)
  apply (auto simp add: fact_plus_one_nat)
  done

lemma fact_nonzero_int [simp]: "n >= 0 \<Longrightarrow> fact (n::int) ~= 0"
  by (simp add: fact_int_def)

lemma fact_gt_zero_nat [simp]: "fact (n :: nat) > 0"
  by (insert fact_nonzero_nat [of n], arith)

lemma fact_gt_zero_int [simp]: "n >= 0 \<Longrightarrow> fact (n :: int) > 0"
  by (auto simp add: fact_int_def)

lemma fact_ge_one_nat [simp]: "fact (n :: nat) >= 1"
  by (insert fact_nonzero_nat [of n], arith)

lemma fact_ge_Suc_0_nat [simp]: "fact (n :: nat) >= Suc 0"
  by (insert fact_nonzero_nat [of n], arith)

lemma fact_ge_one_int [simp]: "n >= 0 \<Longrightarrow> fact (n :: int) >= 1"
  apply (auto simp add: fact_int_def)
  apply (subgoal_tac "1 = int 1")
  apply (erule ssubst)
  apply (subst zle_int)
  apply auto
  done

lemma dvd_fact_nat [rule_format]: "1 <= m \<longrightarrow> m <= n \<longrightarrow> m dvd fact (n::nat)"
  apply (induct n)
  apply force
  apply (auto simp only: fact_Suc)
  apply (subgoal_tac "m = Suc n")
  apply (erule ssubst)
  apply (rule dvd_triv_left)
  apply auto
  done

lemma dvd_fact_int [rule_format]: "1 <= m \<longrightarrow> m <= n \<longrightarrow> m dvd fact (n::int)"
  apply (case_tac "1 <= n")
  apply (induct n rule: int_ge_induct)
  apply (auto simp add: fact_plus_one_int)
  apply (subgoal_tac "m = i + 1")
  apply auto
  done

lemma interval_plus_one_nat: "(i::nat) <= j + 1 \<Longrightarrow>
  {i..j+1} = {i..j} Un {j+1}"
  by auto

lemma interval_Suc: "i <= Suc j \<Longrightarrow> {i..Suc j} = {i..j} Un {Suc j}"
  by auto

lemma interval_plus_one_int: "(i::int) <= j + 1 \<Longrightarrow> {i..j+1} = {i..j} Un {j+1}"
  by auto

lemma fact_altdef_nat: "fact (n::nat) = (PROD i:{1..n}. i)"
  apply (induct n)
  apply force
  apply (subst fact_Suc)
  apply (subst interval_Suc)
  apply auto
done

lemma fact_altdef_int: "n >= 0 \<Longrightarrow> fact (n::int) = (PROD i:{1..n}. i)"
  apply (induct n rule: int_ge_induct)
  apply force
  apply (subst fact_plus_one_int, assumption)
  apply (subst interval_plus_one_int)
  apply auto
done

lemma fact_dvd: "n \<le> m \<Longrightarrow> fact n dvd fact (m::nat)"
  by (auto simp add: fact_altdef_nat intro!: setprod_dvd_setprod_subset)

lemma fact_mod: "m \<le> (n::nat) \<Longrightarrow> fact n mod fact m = 0"
  by (auto simp add: dvd_imp_mod_0 fact_dvd)

lemma fact_div_fact:
  assumes "m \<ge> (n :: nat)"
  shows "(fact m) div (fact n) = \<Prod>{n + 1..m}"
proof -
  obtain d where "d = m - n" by auto
  from assms this have "m = n + d" by auto
  have "fact (n + d) div (fact n) = \<Prod>{n + 1..n + d}"
  proof (induct d)
    case 0
    show ?case by simp
  next
    case (Suc d')
    have "fact (n + Suc d') div fact n = Suc (n + d') * fact (n + d') div fact n"
      by simp
    also from Suc.hyps have "... = Suc (n + d') * \<Prod>{n + 1..n + d'}"
      unfolding div_mult1_eq[of _ "fact (n + d')"] by (simp add: fact_mod)
    also have "... = \<Prod>{n + 1..n + Suc d'}"
      by (simp add: atLeastAtMostSuc_conv setprod.insert)
    finally show ?case .
  qed
  from this `m = n + d` show ?thesis by simp
qed

lemma fact_mono_nat: "(m::nat) \<le> n \<Longrightarrow> fact m \<le> fact n"
apply (drule le_imp_less_or_eq)
apply (auto dest!: less_imp_Suc_add)
apply (induct_tac k, auto)
done

lemma fact_neg_int [simp]: "m < (0::int) \<Longrightarrow> fact m = 0"
  unfolding fact_int_def by auto

lemma fact_ge_zero_int [simp]: "fact m >= (0::int)"
  apply (case_tac "m >= 0")
  apply auto
  apply (frule fact_gt_zero_int)
  apply arith
done

lemma fact_mono_int_aux [rule_format]: "k >= (0::int) \<Longrightarrow>
    fact (m + k) >= fact m"
  apply (case_tac "m < 0")
  apply auto
  apply (induct k rule: int_ge_induct)
  apply auto
  apply (subst add.assoc [symmetric])
  apply (subst fact_plus_one_int)
  apply auto
  apply (erule order_trans)
  apply (subst mult_le_cancel_right1)
  apply (subgoal_tac "fact (m + i) >= 0")
  apply arith
  apply auto
done

lemma fact_mono_int: "(m::int) <= n \<Longrightarrow> fact m <= fact n"
  apply (insert fact_mono_int_aux [of "n - m" "m"])
  apply auto
done

text{*Note that @{term "fact 0 = fact 1"}*}
lemma fact_less_mono_nat: "[| (0::nat) < m; m < n |] ==> fact m < fact n"
apply (drule_tac m = m in less_imp_Suc_add, auto)
apply (induct_tac k, auto)
done

lemma fact_less_mono_int_aux: "k >= 0 \<Longrightarrow> (0::int) < m \<Longrightarrow>
    fact m < fact ((m + 1) + k)"
  apply (induct k rule: int_ge_induct)
  apply (simp add: fact_plus_one_int)
  apply (subst (2) fact_reduce_int)
  apply (auto simp add: ac_simps)
  apply (erule order_less_le_trans)
  apply auto
  done

lemma fact_less_mono_int: "(0::int) < m \<Longrightarrow> m < n \<Longrightarrow> fact m < fact n"
  apply (insert fact_less_mono_int_aux [of "n - (m + 1)" "m"])
  apply auto
done

lemma fact_num_eq_if_nat: "fact (m::nat) =
  (if m=0 then 1 else m * fact (m - 1))"
by (cases m) auto

lemma fact_add_num_eq_if_nat:
  "fact ((m::nat) + n) = (if m + n = 0 then 1 else (m + n) * fact (m + n - 1))"
by (cases "m + n") auto

lemma fact_add_num_eq_if2_nat:
  "fact ((m::nat) + n) =
    (if m = 0 then fact n else (m + n) * fact ((m - 1) + n))"
by (cases m) auto

lemma fact_le_power: "fact n \<le> n^n"
proof (induct n)
  case (Suc n)
  then have "fact n \<le> Suc n ^ n" by (rule le_trans) (simp add: power_mono)
  then show ?case by (simp add: add_le_mono)
qed simp

subsection {* @{term fact} and @{term of_nat} *}

lemma of_nat_fact_not_zero [simp]: "of_nat (fact n) \<noteq> (0::'a::semiring_char_0)"
by auto

lemma of_nat_fact_gt_zero [simp]: "(0::'a::{linordered_semidom}) < of_nat(fact n)" by auto

lemma of_nat_fact_ge_zero [simp]: "(0::'a::linordered_semidom) \<le> of_nat(fact n)"
by simp

lemma inv_of_nat_fact_gt_zero [simp]: "(0::'a::linordered_field) < inverse (of_nat (fact n))"
by (auto simp add: positive_imp_inverse_positive)

lemma inv_of_nat_fact_ge_zero [simp]: "(0::'a::linordered_field) \<le> inverse (of_nat (fact n))"
by (auto intro: order_less_imp_le)

lemma fact_eq_rev_setprod_nat: "fact (k::nat) = (\<Prod>i<k. k - i)"
  unfolding fact_altdef_nat
  by (rule setprod.reindex_bij_witness[where i="\<lambda>i. k - i" and j="\<lambda>i. k - i"]) auto

lemma fact_div_fact_le_pow:
  assumes "r \<le> n" shows "fact n div fact (n - r) \<le> n ^ r"
proof -
  have "\<And>r. r \<le> n \<Longrightarrow> \<Prod>{n - r..n} = (n - r) * \<Prod>{Suc (n - r)..n}"
    by (subst setprod.insert[symmetric]) (auto simp: atLeastAtMost_insertL)
  with assms show ?thesis
    by (induct r rule: nat.induct) (auto simp add: fact_div_fact Suc_diff_Suc mult_le_mono)
qed

lemma fact_numeral:  --{*Evaluation for specific numerals*}
  "fact (numeral k) = (numeral k) * (fact (pred_numeral k))"
  by (simp add: numeral_eq_Suc)

end