subsection \<open>IMO 2018 SL - C2\<close>

theory IMO_2018_SL_C2_sol
imports Complex_Main
begin

locale dim =
  fixes files :: int
  fixes ranks :: int
  assumes pos: "files > 0 \<and> ranks > 0"
  assumes div4: "files mod 4 = 0 \<and> ranks mod 4 = 0"
begin

type_synonym square = "int \<times> int"

definition squares :: "square set" where
  "squares = {0..<files} \<times> {0..<ranks}"

datatype piece = Queen | Knight

type_synonym board = "square \<Rightarrow> piece option"

definition empty_board :: board where
  "empty_board = (\<lambda> square. None)"

fun attacks_knight :: "square \<Rightarrow> board \<Rightarrow> bool" where
  "attacks_knight (file, rank) board \<longleftrightarrow>
     (\<exists> file' rank'. (file', rank') \<in> squares \<and> board (file', rank') = Some Knight \<and>
                     ((abs (file - file') = 1 \<and> abs (rank - rank') = 2) \<or>
                      (abs (file - file') = 2 \<and> abs (rank - rank') = 1)))"

definition valid_horst_move' :: "square \<Rightarrow> board \<Rightarrow> board \<Rightarrow> bool" where
  "valid_horst_move' square board board' \<longleftrightarrow>
       square \<in> squares \<and> board square = None \<and>
       \<not> attacks_knight square board \<and>
       board' = board (square := Some Knight)"

definition valid_horst_move :: "board \<Rightarrow> board \<Rightarrow> bool" where
  "valid_horst_move board board' \<longleftrightarrow>
     (\<exists> square. valid_horst_move' square board board')"

definition valid_queenie_move :: "board \<Rightarrow> board \<Rightarrow> bool" where
  "valid_queenie_move board board' \<longleftrightarrow>
     (\<exists> square \<in> squares. board square = None \<and>
                          board' = board (square := Some Queen))"

type_synonym strategy = "board \<Rightarrow> board \<Rightarrow> bool"

inductive valid_game :: "strategy \<Rightarrow> strategy \<Rightarrow> nat \<Rightarrow> board \<Rightarrow> bool" where
  "valid_game horst_strategy queenie_strategy 0 empty_board"
| "\<lbrakk>valid_game horst_strategy queenie_strategy k board;
    valid_horst_move board board'; horst_strategy board board';
    valid_queenie_move board' board''; queenie_strategy board' board''\<rbrakk>\<Longrightarrow> valid_game horst_strategy queenie_strategy (k + 1) board''"

definition valid_queenie_strategy :: "strategy \<Rightarrow> bool" where
  "valid_queenie_strategy queenie_strategy \<longleftrightarrow>
     (\<forall>  horst_strategy board board' k.
         valid_game horst_strategy queenie_strategy k board \<and>
         valid_horst_move board board' \<and> horst_strategy board board' \<and>
         (\<exists> square \<in> squares. board' square = None) \<longrightarrow>
            (\<exists> board''. valid_queenie_move board' board'' \<and> queenie_strategy board' board''))"

text \<open>squares\<close>
lemma squares_card [simp]:
  shows "card squares = files * ranks"
  using pos
  unfolding squares_def
  by auto

lemma squares_finite [simp]:
  shows "finite squares"
  using pos
  unfolding squares_def
  by auto

text \<open>\<open>free_squares\<close>\<close>

definition free_squares :: "board \<Rightarrow> square set" where
  "free_squares board = {square \<in> squares. board square = None}"

lemma free_squares_finite [simp]:
  shows "finite (free_squares board)"
proof (rule finite_subset)
  show "free_squares board \<subseteq> squares"
    by (simp add: free_squares_def)
qed simp

lemma valid_game_free_squares_card_even:
  assumes "valid_game horst_strategy queenie_strategy k board"
  shows "card (free_squares board) mod 2 = 0"
  using assms
proof (induction horst_strategy queenie_strategy k board rule: valid_game.induct)
  case (1 horst_strategy queenie_strategy)
  show ?case
  proof-
    have "card (free_squares empty_board) = files * ranks"
      by (simp add: empty_board_def free_squares_def)
    then show ?thesis
      using div4
      by presburger
  qed
next
  case (2 horst_strategy queenie_strategy K board board' board'')
  then obtain square square' where
    "square \<in> squares" "board square = None" "board' = board (square := Some Knight)"
    "square' \<in> squares" "board' square' = None" "board'' = board' (square' := Some Queen)"
    unfolding valid_horst_move_def valid_horst_move'_def valid_queenie_move_def
    by auto
  then have "free_squares board = free_squares board'' \<union> {square, square'}"
        "square \<notin> free_squares board''" "square' \<notin> free_squares board''"
    unfolding free_squares_def
    by (auto split: if_split_asm)
  moreover
  have "square \<noteq> square'"
    using \<open>board' = board(square \<mapsto> Knight)\<close> \<open>board' square' = None\<close>
    by auto
  ultimately
  have "card (free_squares board) = card (free_squares board'') + 2"
    using card_Un_disjoint[of "free_squares board''" "{square, square'}"]
    by auto
  then show ?case
    using \<open>card (free_squares board) mod 2 = 0\<close>
    by simp
qed

text \<open>black squares\<close>

fun black :: "square \<Rightarrow> bool" where
 "black (file, rank) \<longleftrightarrow> (file + rank) mod 2 = 0"

definition black_squares :: "square set" where
  "black_squares = {square \<in> squares. black square}"

lemma black_squares_finite [simp]:
  shows "finite black_squares"
  using pos
  unfolding black_squares_def
  by auto

lemma black_squares_card:
  "card black_squares = (files * ranks) div 2"
proof-
  let ?black_squares = "{square \<in> squares. black square}"
  let ?white_squares = "{square \<in> squares. \<not> black square}"
  have "squares = ?black_squares \<union> ?white_squares"
    by blast
  moreover
  have "?black_squares \<inter> ?white_squares = {}"
    by blast
  moreover
  have "card ?black_squares = card ?white_squares"
  proof-
    let ?f = "\<lambda> (a::int, b::int). if a mod 2 = 0 then (a, b + 1) else (a, b - 1)"
    have "bij_betw ?f ?black_squares ?white_squares"
      unfolding bij_betw_def
    proof
      show "inj_on ?f ?black_squares"
        unfolding inj_on_def
        by auto
    next
      show "?f ` ?black_squares = ?white_squares"
      proof
        show "?f ` ?black_squares \<subseteq> ?white_squares"
          using div4
          by (auto simp add: squares_def split: if_split_asm) presburger+
      next
        show "?white_squares \<subseteq> ?f ` ?black_squares"
        proof
          fix wsq
          assume "wsq \<in> ?white_squares"
          let ?invf = "\<lambda> (a, b). if a mod 2 = 0 then (a, b - 1) else (a, b + 1)"
          have "?f (?invf wsq) = wsq"
            by (cases wsq, auto)
          moreover
          have "?invf wsq \<in> ?black_squares"
            using \<open>wsq \<in> ?white_squares\<close> div4
            by (cases wsq, auto simp add: squares_def) presburger+
          ultimately
          show "wsq \<in> ?f ` ?black_squares"
            by force
        qed
      qed
    qed
    then show ?thesis
      using bij_betw_same_card by blast
  qed
  ultimately
  have "2 * card ?black_squares = card squares"
    by (metis (no_types, lifting) card.infinite card_Un_disjoint finite_Un mult_2 mult_eq_0_iff)
  then have "2 * card ?black_squares = files * ranks"
    by auto
  then show ?thesis
    unfolding black_squares_def
    by simp
qed

text \<open>free black squares\<close>

definition free_black_squares :: "board \<Rightarrow> square set" where
  "free_black_squares board = {square \<in> squares. black square \<and> board square = None}"

lemma free_black_squares_add_piece:
  shows "card (free_black_squares board) \<le> card (free_black_squares (board (square := Some piece))) + 1"
proof-
  let ?board' = "board (square := Some piece)"
  have "free_black_squares board = free_black_squares ?board' \<or>
        free_black_squares board = free_black_squares ?board' \<union> {square}"
    unfolding free_black_squares_def Let_def
    by auto
  then show ?thesis
    by (metis One_nat_def add.right_neutral add_Suc_right card.infinite card_Un_le card_empty card_insert_if finite_Un finite_insert insert_absorb insert_not_empty le_add1 trans_le_add2)
qed

lemma free_black_squares_valid_horst_move:
  assumes "valid_horst_move board board'"
  shows "card (free_black_squares board) \<le> card (free_black_squares board') + 1"
  using assms
  using free_black_squares_add_piece
  unfolding valid_horst_move_def valid_horst_move'_def free_black_squares_def
  by auto

lemma free_black_squares_valid_queenie_move:
  assumes "valid_queenie_move board board'"
  shows "card (free_black_squares board) \<le> card (free_black_squares board') + 1"
  using assms
  using free_black_squares_add_piece
  unfolding valid_queenie_move_def free_black_squares_def
  by auto

text \<open>knights\<close>

definition knights :: "board \<Rightarrow> square set" where
  "knights board = {square \<in> squares. board square = Some Knight}"

lemma knights_finite [simp]:
  shows "finite (knights board)"
  by (rule finite_subset[of _ squares], simp_all add: knights_def)

lemma knights_card_horst_move [simp]:
  assumes "valid_horst_move board board'"
  shows "card (knights board') = card (knights board) + 1"
proof-
  obtain square where "square \<in> squares" "board square = None" "board' square = Some Knight"
    "board' = board (square := Some Knight)"
    using assms
    unfolding valid_horst_move_def valid_horst_move'_def
    by auto
  then have "knights board' = knights board \<union> {square}"
    unfolding knights_def
    by auto
  then show ?thesis
    using \<open>board square = None\<close>
    unfolding knights_def
    by auto
qed

lemma knights_card_queenie_move [simp]:
  assumes "valid_queenie_move board board'"
  shows "card (knights board') = card (knights board)"
proof-
  have "knights board' = knights board"
    using assms
    unfolding valid_queenie_move_def knights_def
    by force
  then show ?thesis
    by simp
qed

lemma valid_game_knights_card [simp]:
  assumes "valid_game horst_strategy queenie_strategy k board"
  shows "card (knights board) = k"
  using assms
proof (induction horst_strategy queenie_strategy k board rule: valid_game.induct)
  case (1 horst_strategy queenie_strategy)
  show ?case
    by (simp add: empty_board_def knights_def)
next
  case (2 horst_strategy queenie_strategy K board board' board'')
  then show ?case
    by auto
qed

text \<open>Cycles\<close>

fun cycle_opposite :: "square \<Rightarrow> square" where
  "cycle_opposite (file, rank) = (4 * (file div 4) + (3 - file mod 4), 4 * (rank div 4) + (3 - rank mod 4))"

lemma cycle_opposite_cycle_opposite [simp]:
  shows "cycle_opposite (cycle_opposite square) = square"
  by (cases square) auto

lemma cycle_opposite_different [simp]:
  shows "cycle_opposite square \<noteq> square"
  by (cases square, simp, presburger)

lemma cycle_opposite_squares [simp]:
  shows "cycle_opposite square \<in> squares \<longleftrightarrow> square \<in> squares"
  using pos div4
  by (cases square) (simp add: squares_def, safe, presburger+)

fun cycle4 :: "square \<Rightarrow> int" where
  "cycle4 (x, y) =
      (if x = 0 then y
       else if x = 1 then (y + 2) mod 4
       else if x = 2 then (5 - y) mod 4
       else 3 - y)"

lemma cycle_lt_4:
  assumes "0 \<le> x" "x < 4" "0 \<le> y" "y < 4"
  shows "0 \<le> cycle4 (x, y) \<and> cycle4 (x, y) < 4"
  using assms
  by auto

lemma cycle0:
  assumes "0 \<le> x" "x < 4" "0 \<le> y" "y < 4"
  shows "cycle4 (x, y) = 0 \<longleftrightarrow> (x, y) \<in> set [(0, 0), (2, 1), (1, 2), (3, 3)]"
  using assms
  by auto presburger+

lemma cycle1:
  assumes "0 \<le> x" "x < 4" "0 \<le> y" "y < 4"
  shows "cycle4 (x, y) = 1 \<longleftrightarrow> (x, y) \<in> set [(0, 1), (1, 3), (3, 2), (2, 0)]"
  using assms
  by auto presburger+

lemma cycle2:
  assumes "0 \<le> x" "x < 4" "0 \<le> y" "y < 4"
  shows "cycle4 (x, y) = 2 \<longleftrightarrow> (x, y) \<in> set [(0, 2), (2, 3), (1, 0), (3, 1)]"
  using assms
  by auto presburger+

lemma cycle3:
  assumes "0 \<le> x" "x < 4" "0 \<le> y" "y < 4"
  shows "cycle4 (x, y) = 3 \<longleftrightarrow> (x, y) \<in> set [(0, 3), (1, 1), (2, 2), (3, 0)]"
  using assms
  by auto presburger+

fun cycle :: "square \<Rightarrow> int \<times> int \<times> int" where
  "cycle (x, y) = (x div 4, y div 4, cycle4 (x mod 4, y mod 4))"

lemma cycles_card:
  shows "card (cycle ` squares) = (files * ranks) div 4"
proof-
  have "cycle ` squares = {(x, y, z). x \<in> {0..<files div 4} \<and> y \<in> {0..<ranks div 4} \<and> z \<in> {0..<4}}"
  proof safe
    fix f r x y z
    assume "(f, r) \<in> squares" "(x, y, z) = cycle (f, r)"
    then have "0 \<le> f \<and> f < files" "0 \<le> r \<and> r < ranks"
      by (auto simp add: squares_def)
    then have "0 \<le> f div 4 \<and> f div 4 < files div 4"  "0 \<le> r div 4 \<and> r div 4 < ranks div 4"
      using div4
      by presburger+
    then show "x \<in> {0..<files div 4}" "y \<in> {0..<ranks div 4}"
      using \<open>(x, y, z) = cycle (f, r)\<close>
      by auto
    show "z \<in> {0..<4}"
      using cycle_lt_4[rule_format, of "f mod 4" "r mod 4"]
      using \<open>(x, y, z) = cycle (f, r)\<close>
      by simp
  next
    fix x y z :: int
    assume *: "x \<in> {0..<files div 4}" "y \<in> {0..<ranks div 4}" "z \<in> {0..<4}"
    let ?f = "4 * x" and ?r = "4 * y + z"
    have "(?f, ?r) \<in> squares" "cycle (?f, ?r) = (x, y, z)"
      using *
      by (auto simp add: squares_def)
    then have "\<exists> square \<in> squares. cycle square = (x, y, z)"
      by blast
    then show "(x, y, z) \<in> cycle ` squares"
      by (metis imageI)
  qed
  also have "... = {0..<files div 4} \<times> {0..<ranks div 4} \<times> {0..<4}"
    by auto
  finally
  have "card (cycle ` squares) = (files div 4) * (ranks div 4) * 4"
    using pos
    by simp
  also have "... = (files * ranks) div 4"
    using div4
    by auto
  finally show ?thesis
    .
qed

lemma cycle4_exhausted:
  assumes "0 \<le> f1" "f1 < 4" "0 \<le> r1" "r1 < 4"
  assumes "0 \<le> f2" "f2 < 4" "0 \<le> r2" "r2 < 4"
  assumes "(f1, r1) \<noteq> (f2, r2)"
          "abs (f1 - f2) \<noteq> 1 \<or> abs (r1 - r2) \<noteq> 2"
          "abs (f1 - f2) \<noteq> 2 \<or> abs (r1 - r2) \<noteq> 1"
          "(f2, r2) \<noteq> (3 - f1, 3 - r1)"
  shows "cycle4 (f1, r1) \<noteq> cycle4 (f2, r2)"
  using assms cycle_lt_4[rule_format, of f1 r1]
  by (smt cycle0 cycle1 cycle2 cycle3 list.set_intros(1) list.set_intros(2))

lemma cycle_exhausted:
  assumes "\<forall> sq \<in> squares. board sq = Some Knight \<longrightarrow> \<not> attacks_knight sq board"
          "\<forall> sq \<in> squares. board sq = Some Knight \<longrightarrow> board (cycle_opposite sq) = Some Queen"
          "sq1 \<noteq> sq2" "sq1 \<in> squares" "sq2 \<in> squares" "board sq1 = Some Knight" "board sq2 = Some Knight"
  shows "cycle sq1 \<noteq> cycle sq2"
proof safe
  assume "cycle sq1 = cycle sq2"
  obtain f1 r1 where sq1: "sq1 = (f1, r1)"
    by (cases sq1)
  obtain f2 r2 where sq2: "sq2 = (f2, r2)"
    by (cases sq2)

  have **: "f1 div 4 = f2 div 4" "r1 div 4 = r2 div 4"
            "cycle4 (f1 mod 4, r1 mod 4) = cycle4 (f2 mod 4, r2 mod 4)"
    using \<open>cycle sq1 = cycle sq2\<close> sq1 sq2
    by simp_all

  have "\<not> attacks_knight (f1, r1) board" "(f2, r2) \<noteq> cycle_opposite (f1, r1)"
    using assms(1)[rule_format, of "(f1, r1)"]
    using assms(2)[rule_format, of "(f1, r1)"]
    using assms(4-7) sq1 sq2
    by auto

  have "f2 \<noteq> 4 * (f1 div 4) + (3 - f1 mod 4) \<or> r2 \<noteq> 4 * (r1 div 4) + (3 - r1 mod 4)"
    using \<open>(f2, r2) \<noteq> cycle_opposite (f1, r1)\<close>
    by auto

  then have "f2 mod 4 \<noteq> 3 - f1 mod 4 \<or> r2 mod 4 \<noteq> 3 - r1 mod 4"
    using **(1-2)
    by safe presburger+

  then have 1: "(f2 mod 4, r2 mod 4) \<noteq> (3 - f1 mod 4, 3 - r1 mod 4)"
    by simp

  have "(\<bar>f1 - f2\<bar> = 1 \<longrightarrow> \<bar>r1 - r2\<bar> \<noteq> 2) \<and> (\<bar>f1 - f2\<bar> = 2 \<longrightarrow> \<bar>r1 - r2\<bar> \<noteq> 1)"
    using \<open>\<not> attacks_knight (f1, r1) board\<close>
    using assms attacks_knight.simps sq1 sq2
    by blast

  then have 2: "\<bar>f1 mod 4 - f2 mod 4\<bar> \<noteq> 1 \<or> \<bar>r1 mod 4 - r2 mod 4\<bar> \<noteq> 2"
               "\<bar>f1 mod 4 - f2 mod 4\<bar> \<noteq> 2 \<or> \<bar>r1 mod 4 - r2 mod 4\<bar> \<noteq> 1"
    using **(1-2)
    by (smt mult_div_mod_eq)+

  have "(f1 mod 4, r1 mod 4) = (f2 mod 4, r2 mod 4)"
    using **(3) cycle4_exhausted[OF _ _ _ _ _ _ _ _ _ 2 1]
    using pos_mod_conj zero_less_numeral
    by blast

  then have "f1 = f2" "r1 = r2"
    using **(1-2)
    by (metis mult_div_mod_eq prod.inject)+

  then show False
    using sq1 sq2 \<open>sq1 \<noteq> sq2\<close>
    by simp
qed

text \<open>guaranteed game lengths\<close>

definition guaranteed_game_lengths :: "nat set" where
  "guaranteed_game_lengths = {K. \<exists> horst_strategy. \<forall> queenie_strategy. valid_queenie_strategy queenie_strategy \<longrightarrow> (\<exists> board. valid_game horst_strategy queenie_strategy K board)}"

lemma guaranteed_game_lengths_geq:
  shows "nat ((files * ranks) div 4) \<in> guaranteed_game_lengths"
  unfolding guaranteed_game_lengths_def
proof safe
  let ?l = "nat ((files * ranks) div 4)"
  let ?horst_strategy = "\<lambda> board board' :: board. (\<exists> square. black square \<and> valid_horst_move' square board board')"
  show "\<exists> horst_strategy. \<forall> queenie_strategy. valid_queenie_strategy queenie_strategy \<longrightarrow> (\<exists> board. valid_game horst_strategy queenie_strategy ?l board)"
  proof (rule_tac x="?horst_strategy" in exI, safe)
    fix queenie_strategy
    assume "valid_queenie_strategy queenie_strategy"

    have 1: "\<forall> k board. valid_game ?horst_strategy queenie_strategy k board \<longrightarrow> (\<forall> square \<in> squares. board square = Some Knight \<longrightarrow> black square)" (is "\<forall> k. ?P k")
    proof safe
      fix k board f r
      assume "valid_game ?horst_strategy queenie_strategy k board"
             "(f, r) \<in> squares" "board (f, r) = Some Knight"
      then show "black (f, r)"
      proof (induction ?horst_strategy queenie_strategy k board rule: valid_game.induct)
        case (1 queenie_strategy)
        then show ?case
          by (simp add: empty_board_def)
      next
        case (2 queenie_strategy K board board' board'')
        then show ?case
          by (smt map_upd_Some_unfold piece.simps(1) valid_horst_move'_def valid_queenie_move_def)
      qed
    qed

    have "\<forall> k \<le> (files * ranks) div 4. \<exists> board. valid_game ?horst_strategy queenie_strategy k board"
    proof safe
      fix k::nat
      assume "k \<le> (files * ranks) div 4"
      then show "\<exists> board. valid_game ?horst_strategy queenie_strategy k board"
      proof (induction k)
        case 0
        then show ?case
          by (rule_tac x=empty_board in exI, simp add: valid_game.intros)
      next
        case (Suc k)
        then obtain board where "valid_game ?horst_strategy queenie_strategy k board"
          by auto
        then have *: "(files * ranks) div 2 - 2 * k \<le> card (free_black_squares board)"
          using \<open>Suc k \<le> (files * ranks) div 4\<close>
        proof (induction ?horst_strategy queenie_strategy k board rule: valid_game.induct)
          case 1
          then show ?case
            using black_squares_card
            by (simp add: empty_board_def black_squares_def free_black_squares_def)
        next
          case (2 queenie_strategy k board board' board'')
          then have "(files * ranks) div 2 - 2 * k \<le> card (free_black_squares board)"
            by auto
          also have "... \<le> card (free_black_squares board') + 1"
            using 2
            using free_black_squares_valid_horst_move[of board board']
            by simp
          also have "... \<le> card (free_black_squares board'') + 2"
            using 2
            using free_black_squares_valid_queenie_move[of board' board'']
            by simp
          finally show ?case
            using \<open>Suc (k + 1) \<le> (files * ranks) div 4\<close>
            by (simp add: le_diff_conv)
        qed
        then have "card (free_black_squares board) > 0"
          using \<open>Suc k \<le> (files * ranks) div 4\<close>
          by auto
        then obtain square where "square \<in> free_black_squares board"
          by (metis Collect_empty_eq Collect_mem_eq card.infinite card_0_eq not_less0)

        have "\<not> attacks_knight square board"
        proof (rule ccontr)
          obtain x y where "square = (x, y)"
            by (cases square)
          assume "\<not> ?thesis"
          then obtain x' y' where "(x', y') \<in> squares" "board (x', y') = Some Knight" "\<bar>x - x'\<bar> = 1 \<and> \<bar>y - y'\<bar> = 2 \<or> \<bar>x - x'\<bar> = 2 \<and> \<bar>y - y'\<bar> = 1"
            using \<open>square = (x, y)\<close>
            by auto
          then have "black (x', y')"
            using 1[rule_format, OF \<open>valid_game ?horst_strategy queenie_strategy k board\<close>]
            by auto

          have "black (x, y)"
            using \<open>square \<in> free_black_squares board\<close> \<open>square = (x, y)\<close>
            by (simp add: free_black_squares_def)

          show False
            using \<open>black (x, y)\<close> \<open>black (x', y')\<close> \<open>\<bar>x - x'\<bar> = 1 \<and> \<bar>y - y'\<bar> = 2 \<or> \<bar>x - x'\<bar> = 2 \<and> \<bar>y - y'\<bar> = 1\<close>
            unfolding black.simps
            by presburger
        qed

        let ?board1 = "board (square := Some Knight)"
        have "valid_horst_move board ?board1"
          using \<open>square \<in> free_black_squares board\<close> \<open>\<not> attacks_knight square board\<close>
          unfolding valid_horst_move_def valid_horst_move'_def
          by (rule_tac x=square in exI, cases square, simp add: free_black_squares_def)

        moreover

        have "?horst_strategy board ?board1"
          using \<open>valid_horst_move board ?board1\<close> \<open>square \<in> free_black_squares board\<close>
          unfolding valid_horst_move_def free_black_squares_def
          by (rule_tac x=square in exI, cases square)
             (metis (mono_tags, lifting) map_upd_Some_unfold mem_Collect_eq option.discI valid_horst_move'_def)

        moreover

        have "\<exists> square \<in> squares. ?board1 square = None"
        proof-
          have "card (free_squares board) mod 2 = 0"
            using \<open>valid_game ?horst_strategy queenie_strategy k board\<close>
            using valid_game_free_squares_card_even
            by blast
          have "free_squares board = free_squares ?board1 \<union> {square}" "square \<notin> free_squares ?board1"
            using \<open>square \<in> free_black_squares board\<close>
            unfolding free_black_squares_def free_squares_def
            by auto
          then have "card (free_squares board) = card (free_squares ?board1) + 1"
            by auto
          then have "card (free_squares ?board1) mod 2 = 1"
            using \<open>card (free_squares board) mod 2 = 0\<close>
            by presburger
          then have "free_squares ?board1 \<noteq> {}"
            by auto
          then show ?thesis
            unfolding free_squares_def
            by blast
        qed

        then obtain board2 where "valid_queenie_move ?board1 board2" "queenie_strategy ?board1 board2"
          using \<open>valid_queenie_strategy queenie_strategy\<close>
          unfolding valid_queenie_strategy_def
          using \<open>valid_game ?horst_strategy queenie_strategy k board\<close> calculation(1) calculation(2) valid_horst_move'_def
          by blast

        ultimately

        show ?case
          using \<open>valid_game ?horst_strategy queenie_strategy k board\<close>
          by (metis (no_types, lifting) Suc_eq_plus1  valid_game.intros(2))
      qed
    qed
    then show "\<exists> board. valid_game ?horst_strategy queenie_strategy ?l board"
      using pos
      by simp
  qed
qed

lemma valid_game_not_attacks_knight:
  assumes "valid_game horst_strategy queenie_strategy k board"
          "square \<in> squares" "board square = Some Knight"
        shows "\<not> attacks_knight square board"
  using assms
proof (induction horst_strategy queenie_strategy k board rule: valid_game.induct)
  case (1 horst_strategy queenie_strategy)
  then show ?case
    by (simp add: empty_board_def)
next
  case (2 horst_strategy queenie_strategy K board board' board'')
  have "\<not> attacks_knight square board'"
  proof (cases "board square = Some Knight")
    case True
    then have "\<not> attacks_knight square board"
      using 2
      by simp
    show ?thesis
    proof (rule ccontr)
      assume "\<not> ?thesis"
      obtain x y where "square = (x, y)"
        by (cases square)
      then obtain x' y' where "(x', y') \<in> squares" "board' (x', y') = Some Knight"
        "\<bar>x - x'\<bar> = 1 \<and> \<bar>y - y'\<bar> = 2 \<or> \<bar>x - x'\<bar> = 2 \<and> \<bar>y - y'\<bar> = 1"
        using \<open>\<not> \<not> attacks_knight square board'\<close>
        by auto
      obtain square' where
        "square' \<in> squares" "\<not> attacks_knight square' board"
        "board square' = None" "board' = board (square' := Some Knight)"
        using \<open>valid_horst_move board board'\<close>
        unfolding valid_horst_move_def valid_horst_move'_def
        by auto
      have "square' = (x', y')"
        using \<open>\<bar>x - x'\<bar> = 1 \<and> \<bar>y - y'\<bar> = 2 \<or> \<bar>x - x'\<bar> = 2 \<and> \<bar>y - y'\<bar> = 1\<close>
        using \<open>\<not> attacks_knight square board\<close> \<open>board' (x', y') = Some Knight\<close> \<open>board' = board(square' \<mapsto> Knight)\<close> \<open>(x', y') \<in> squares\<close> \<open>square = (x, y)\<close>
        by (metis (full_types)  attacks_knight.simps fun_upd_other)
      then have "attacks_knight square' board"
        using \<open>square' \<in> squares\<close>  \<open>\<bar>x - x'\<bar> = 1 \<and> \<bar>y - y'\<bar> = 2 \<or> \<bar>x - x'\<bar> = 2 \<and> \<bar>y - y'\<bar> = 1\<close>
              \<open>board square = Some Knight\<close> \<open>square = (x, y)\<close>
        using \<open>square \<in> squares\<close> \<open>board square = Some Knight\<close>
        by (smt attacks_knight.simps)
      then show False
        using \<open>\<not> attacks_knight square' board\<close>
        by simp
    qed
  next
    case False
    have "board' square = Some Knight"
      using \<open>square \<in> squares\<close> \<open>board'' square = Some Knight\<close> \<open>valid_queenie_move board' board''\<close>
      by (metis map_upd_Some_unfold piece.distinct(1) valid_queenie_move_def)

    obtain square' where *: "square' \<in> squares"
      "board square' = None" "\<not> attacks_knight square' board"
      "board' = board(square' \<mapsto> Knight)"
      using \<open>valid_horst_move board board'\<close>
      unfolding valid_horst_move_def valid_horst_move'_def
      by blast
    then have "square = square'"
      using \<open>board square \<noteq> Some Knight\<close>
      using \<open>board' square = Some Knight\<close>
      by (metis fun_upd_apply)
    then have "\<not> attacks_knight square board"
      using \<open>\<not> attacks_knight square' board\<close>
      by simp
    then show ?thesis
      by (cases square) (simp add: "*"(4) \<open>square = square'\<close>)
  qed
  then show ?case
    using \<open>valid_queenie_move board' board''\<close>
    by (smt attacks_knight.elims(2) attacks_knight.elims(3) fun_upd_apply option.inject piece.simps(1) prod.simps(1) valid_queenie_move_def)
qed

lemma guaranteed_game_lengths_leq:
  shows "\<forall> k \<in> guaranteed_game_lengths. k \<le> (files * ranks) div 4"
proof safe
  fix k
  assume "k \<in> guaranteed_game_lengths"
  then obtain horst_strategy where
    *: "\<forall> queenie_strategy. valid_queenie_strategy queenie_strategy \<longrightarrow>
                            (\<exists> board. valid_game horst_strategy queenie_strategy k board)"
    unfolding guaranteed_game_lengths_def
    by auto
  show "k \<le> (files * ranks) div 4"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "k > (files * ranks) div 4"
      by simp

    let ?queenie_strategy = "\<lambda> board board'. (\<exists> square \<in> squares. board square = Some Knight \<and> board (cycle_opposite square) = None \<and> board' (cycle_opposite square) = Some Queen)"

    have 1: "\<forall> k horst_strategy board. valid_game horst_strategy ?queenie_strategy k board \<longrightarrow>
              (\<forall> square \<in> squares. board square = Some Knight \<longleftrightarrow> board (cycle_opposite square) = Some Queen)" (is "\<forall> k. ?P k")
    proof (rule allI, rule allI, rule allI, rule impI, rule ballI)
      fix k horst_strategy board square
      assume "valid_game horst_strategy ?queenie_strategy k board" "square \<in> squares"
      then show "(board square = Some Knight) = (board (cycle_opposite square) = Some Queen)"
      proof (induction horst_strategy ?queenie_strategy k board arbitrary: square rule: valid_game.induct)
        case (1 horst_strategy)
        then show ?case
          by (simp add: empty_board_def)
      next
        case (2 horst_strategy K board board' board'')
        show ?case
        proof safe
          assume "board'' square = Some Knight"
          show "board'' (cycle_opposite square) = Some Queen"
          proof (cases "board square = Some Knight")
            case True
            then have "board (cycle_opposite square) = Some Queen"
              using 2
              by blast
            then have "board' (cycle_opposite square) = Some Queen"
              using \<open>valid_horst_move board board'\<close>
              unfolding valid_horst_move_def valid_horst_move'_def
              by (metis fun_upd_apply option.distinct(1))
            then show ?thesis
              using \<open>valid_queenie_move board' board''\<close>
              using valid_queenie_move_def
              by auto
          next
            case False
            from \<open>valid_queenie_move board' board''\<close> \<open>?queenie_strategy board' board''\<close>
            obtain square' where
              "square' \<in> squares"
              "board' square' = Some Knight"
              "board' (cycle_opposite square') = None"
              "board'' (cycle_opposite square') = Some Queen"
              by auto

            have "square = square'"
            proof (rule ccontr)
              assume "square \<noteq> square'"
              then have "board square' = Some Knight"
                using \<open>board'' square = Some Knight\<close> \<open>board' square' = Some Knight\<close> \<open>valid_horst_move board board'\<close> \<open>valid_queenie_move board' board''\<close>
                by (smt False map_upd_Some_unfold piece.distinct(1) valid_horst_move'_def valid_horst_move_def valid_queenie_move_def)
              then have "board (cycle_opposite square') = Some Queen"
                using \<open>square' \<in> squares\<close> 2
                by simp
              then have "board' (cycle_opposite square') = Some Queen"
                by (metis \<open>board' (cycle_opposite square') = None\<close> \<open>valid_horst_move board board'\<close> fun_upd_def valid_horst_move'_def valid_horst_move_def)
              then show False
                using \<open>board' (cycle_opposite square') = None\<close>
                by simp
            qed
            then show ?thesis
              using \<open>board'' (cycle_opposite square') = Some Queen\<close>
              by simp
          qed
        next
          assume "board'' (cycle_opposite square) = Some Queen"
          show "board'' square = Some Knight"
          proof (cases "board (cycle_opposite square) = Some Queen")
            case True
            then have "board square = Some Knight"
              using 2
              by auto
            then have "board' square = Some Knight"
              using \<open>valid_horst_move board board'\<close>
              unfolding valid_horst_move_def valid_horst_move'_def valid_queenie_move_def
              by auto
            then show ?thesis
              using \<open>valid_queenie_move board' board''\<close>
              unfolding valid_queenie_move_def
              by auto
          next
            case False
            then have "board' (cycle_opposite square) \<noteq> Some Queen"
              using \<open>valid_horst_move board board'\<close>
              unfolding valid_horst_move_def valid_horst_move'_def valid_queenie_move_def
              by (meson map_upd_Some_unfold piece.simps(2))
            obtain square' where "square' \<in> squares"
              "board' (cycle_opposite square') = None"
              "board'' (cycle_opposite square') = Some Queen"
              "board' square' = Some Knight"
              using \<open>?queenie_strategy board' board''\<close>
              by auto
            moreover
            obtain square'' where "board' square'' = None"
              "board'' = board' (square'' := Some Queen)"
              using \<open>valid_queenie_move board' board''\<close>
              unfolding valid_queenie_move_def
              by auto
            ultimately
            have "cycle_opposite square' = square''"
              by (auto split: if_split_asm)
            then have "cycle_opposite square' = cycle_opposite square"
              using \<open>board'' (cycle_opposite square) = Some Queen\<close>
              using \<open>board' (cycle_opposite square) \<noteq> Some Queen\<close>
              using \<open>board'' = board' (square'' := Some Queen)\<close>
              by (auto split: if_split_asm)
            then have "cycle_opposite (cycle_opposite square') = cycle_opposite (cycle_opposite square)"
              by simp
            then have "square' = square"
              by simp
            then have "board' square = Some Knight"
              using \<open>board' square' = Some Knight\<close>
              by simp
            then show ?thesis
              using \<open>board'' = board'(square'' \<mapsto> Queen)\<close>
                    \<open>board' (cycle_opposite square') = None\<close>
                    \<open>cycle_opposite square' = square''\<close> \<open>square' = square\<close>
              by auto
          qed
        qed
      qed
    qed

    have "valid_queenie_strategy ?queenie_strategy"
      unfolding valid_queenie_strategy_def
    proof safe
      fix horst_strategy board board' k f r
      assume "valid_game horst_strategy ?queenie_strategy k board"
             "valid_horst_move board board'" "horst_strategy board board'"
      then obtain square where
       *: "square \<in> squares" "board square = None" "\<not> attacks_knight square board" "board' = board(square \<mapsto> Knight)"
        unfolding valid_horst_move_def valid_horst_move'_def
        by auto
      have "board (cycle_opposite square) \<noteq> Some Queen" "board (cycle_opposite square) \<noteq> Some Knight"
        using 1[rule_format, OF \<open>valid_game horst_strategy ?queenie_strategy k board\<close>, of square]
        using 1[rule_format, OF \<open>valid_game horst_strategy ?queenie_strategy k board\<close>, of "cycle_opposite square"]
        using \<open>square \<in> squares\<close> \<open>board square = None\<close>
        by auto
      then have "board (cycle_opposite square) = None"
        by (metis (full_types) option.exhaust_sel piece.exhaust)

      let ?board = "board' (cycle_opposite square := Some Queen)"
      have "?queenie_strategy board' ?board"
        using * \<open>board (cycle_opposite square) = None\<close> \<open>square \<in> squares\<close>
        by (rule_tac x=square in bexI, simp_all)

      moreover

      obtain f' r' where "cycle_opposite square = (f', r')"
        by (cases "cycle_opposite square")
      then have "valid_queenie_move board' ?board"
        using  \<open>board (cycle_opposite square) = None\<close> cycle_opposite_squares[of square]
        unfolding valid_queenie_move_def
        by (metis "*"(1) "*"(4) cycle_opposite_different fun_upd_other)

      ultimately
      show "\<exists> board''.
              valid_queenie_move board' board'' \<and>
              ?queenie_strategy board' board''"
        by blast
    qed

    then obtain board where **: "valid_game horst_strategy ?queenie_strategy k board"
      using *
      by auto

    have "card (knights board) > (files * ranks) div 4"
      using valid_game_knights_card[rule_format, OF **] \<open>k > (files * ranks) div 4\<close>
      by auto

    have "card (cycle ` (knights board)) > (files * ranks) div 4"
    proof-
      have "inj_on cycle (knights board)"
        unfolding inj_on_def
      proof (rule ballI, rule ballI, rule impI)
        fix square1 square2
        assume "square1 \<in> knights board" "square2 \<in> knights board" "cycle square1 = cycle square2"
        then show "square1 = square2"
          using 1[rule_format, OF \<open>valid_game horst_strategy ?queenie_strategy k board\<close>]
          using valid_game_not_attacks_knight[rule_format, OF \<open>valid_game horst_strategy ?queenie_strategy k board\<close>]
          using cycle_exhausted[of board]
          unfolding knights_def
          by blast
      qed
      then show ?thesis
        using \<open>card (knights board) > (files * ranks) div 4\<close>
        by (simp add: card_image)
    qed

    moreover

    have "cycle ` (knights board) \<subseteq> cycle ` squares"
      unfolding knights_def
      by auto

    moreover

    have "finite (cycle ` squares)"
      by simp

    ultimately

    have "card (cycle ` squares) > (files * ranks) div 4"
      using card_mono
      by (smt zle_int)

    then show False
      using cycles_card
      by simp
  qed
qed

lemma guaranteed_game_lengths_finite:
  shows "finite guaranteed_game_lengths"
proof (subst finite_nat_set_iff_bounded_le)
  show "\<exists>m. \<forall>n\<in>guaranteed_game_lengths. n \<le> m"
  proof (rule_tac x="nat ((files*ranks) div 4)" in exI)
    show "\<forall>n\<in>guaranteed_game_lengths. n \<le> nat (files * ranks div 4)"
      using guaranteed_game_lengths_leq pos
      by auto
  qed
qed

theorem IMO2018SL_C2:
  shows "Max guaranteed_game_lengths = nat ((files * ranks) div 4)"
proof (rule Max_eqI)
  show "nat ((files * ranks) div 4) \<in> guaranteed_game_lengths"
    using guaranteed_game_lengths_geq
    by auto
next
  fix k
  assume "k \<in> guaranteed_game_lengths"
  then show "k \<le> nat ((files * ranks) div 4)"
    using guaranteed_game_lengths_leq
    by auto
next
  show "finite guaranteed_game_lengths"
    using guaranteed_game_lengths_finite
    by auto
qed

end

end


(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step imports Com begin

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first paramenter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

text{* An automatic example: *}

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text {* This proof is automatic. *}

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

text {*
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
*}
text_raw{*\snip{BigStepDetLong}{0}{2}{% *}
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  -- "the only interesting case, @{text WhileTrue}:"
  fix b c s s\<^sub>1 t t'
  -- "The assumptions of the rule:"
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  -- {* Ind.Hyp; note the @{text"\<And>"} because of arbitrary: *}
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  -- "Premise of implication:"
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with `bval b s` obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ -- "prove the rest automatically"
text_raw{*}%endsnip*}

end


theory Pure_HOL
imports
  Pure
  "HOL-Eisbach.Eisbach"
  "HOL-Eisbach.Eisbach_Tools"

begin

text \<open>Extend the Pure logic itself with the usual HOL connectives.\<close>

section \<open>Constants, quantifiers, and connectives\<close>

abbreviation Equal (infix "=" 2)
  where "(x = y) \<equiv> (x \<equiv> y)"

definition "True \<equiv> (\<And>P :: prop. P = P)"
definition "False \<equiv> (\<And>P :: prop. P = True)"

definition All :: "('a \<Rightarrow> prop) \<Rightarrow> prop" (binder "\<forall>" [0] 0)
  where "(\<forall>x. PROP P x) \<equiv> (\<And>x. PROP P x)"

definition Ex :: "('a \<Rightarrow> prop) \<Rightarrow> prop" (binder "\<exists>" [0] 0)
  where "(\<exists>x. PROP P x) \<equiv> (\<And>Q::prop. (\<forall>x. PROP P x \<Longrightarrow> PROP Q) \<Longrightarrow> PROP Q)"

definition And (infix "\<and>" 4)
  where "P \<and> Q \<equiv> (PROP P &&& PROP Q)"

definition Ex1 :: "('a \<Rightarrow> prop) \<Rightarrow> prop" (binder "\<exists>!" [0] 0)
  where "(\<exists>!x. PROP P x) \<equiv> (\<exists>x. PROP P x \<and> (\<forall>y. PROP P y \<Longrightarrow> y = x))"

definition Or (infix "\<or>" 3)
  where "P \<or> Q \<equiv> (\<And>R::prop. \<lbrakk>PROP P \<Longrightarrow> PROP R; PROP Q \<Longrightarrow> PROP R\<rbrakk> \<Longrightarrow> PROP R)"

definition Not ("(\<not> _)" [5] 6)
  where "\<not>P \<equiv> (PROP P \<Longrightarrow> PROP False)"

definition Iff (infix "\<Longleftrightarrow>" 0)
  where "(P \<Longleftrightarrow> Q) \<equiv> (PROP P \<Longrightarrow> PROP Q) \<and> (PROP Q \<Longrightarrow> PROP P)"

section \<open>Methods\<close>

text \<open>We set up the basic logical solver following the Eisbach user manual.\<close>

ML_file "~~/src/Tools/misc_legacy.ML"
ML_file "~~/src/Tools/IsaPlanner/isand.ML"
ML_file "~~/src/Tools/IsaPlanner/rw_inst.ML"
ML_file "~~/src/Tools/IsaPlanner/zipper.ML"
ML_file "~~/src/Tools/eqsubst.ML"
\<comment> \<open>Import the @{method subst} method, used for substituting definitional equalities.\<close>

named_theorems intros
named_theorems elims
named_theorems dests
named_theorems simps
named_theorems subst
named_theorems refine

method logic declares intros elims dests subst refine = (
  assumption | unfold All_def | fold All_def |
  rule intros | erule elims | drule dests | frule dests |
  subst subst | subst (asm) subst |
  (erule refine; solves \<open>logic\<close>)
)+

method_setup move =
  \<open>Scan.succeed (METHOD o (ALLGOALS oo Method.insert_tac))\<close> "Move facts into the goal statements"

\<comment>\<open>Strangely, the move method can solve iterated modus ponens by moving the rule and all premises into the goal state, followed by a call to qed.\<close>
method mp = move

section \<open>Basic axioms and rules\<close>

lemmas mp = meta_mp

lemma TrueI [intros]: "PROP True"
  unfolding True_def .

lemmas tautology = TrueI

lemma FalseE [dest, dests]: "PROP False \<Longrightarrow> PROP P"
unfolding False_def proof -
  assume "\<And>P. P = True"
  hence "PROP P = True" by (rule meta_spec)
  thus "PROP P" using tautology by simp
qed

lemmas explosion = FalseE
method explosion = (rule explosion)

lemmas AllE = meta_spec[folded All_def]
lemmas AllE2 = meta_allE[folded All_def]

method instantiate for pred :: "'a \<Rightarrow> prop" and tm :: 'a = (elim AllE[where ?P=pred and ?x=tm])

lemma ExI:
  assumes "PROP P x"
  shows "\<exists>x. PROP P x"
unfolding Ex_def All_def proof -
  fix Q :: "prop"
  assume "\<And>x. PROP P x \<Longrightarrow> PROP Q"
  with assms show "PROP Q" by mp
qed

lemma ExE:
  assumes "\<exists>x. PROP P x" and "\<forall>x. PROP P x \<Longrightarrow> PROP Q"
  shows "PROP Q"
proof -
  have "(\<forall>x. PROP P x \<Longrightarrow> PROP Q) \<Longrightarrow> PROP Q"
    using
      AllE[where ?P="\<lambda>x. ((\<forall>y. PROP P y \<Longrightarrow> PROP x) \<Longrightarrow> PROP x)" and ?x="PROP Q"]
      assms(1)[unfolded Ex_def]
    by mp
  thus "PROP Q" using assms(2) by mp
qed

lemma AndI [intro, intros]:
  assumes "PROP P" and "PROP Q"
  shows "PROP P \<and> PROP Q"
  unfolding And_def by fact+

lemma AndD1 [dest, dests]:
  assumes "PROP P \<and> PROP Q"
  shows "PROP P"
  using assms unfolding And_def by (rule conjunctionD1)

lemma AndD2 [dest, dests]:
  assumes "PROP P \<and> PROP Q"
  shows "PROP Q"
  using assms unfolding And_def by (rule conjunctionD2)

lemma AndE [elim, elims]:
  assumes "PROP P \<and> PROP Q" and "PROP P \<Longrightarrow> PROP Q \<Longrightarrow> PROP R"
  shows "PROP R"
proof -
  from \<open>PROP P \<and> PROP Q\<close> have "PROP P" and "PROP Q" by logic
  thus "PROP R" using assms by mp
qed

lemma OrI1:
  assumes "PROP P"
  shows "PROP P \<or> PROP Q"
  unfolding Or_def using assms by move logic

lemma OrI2:
  assumes "PROP Q"
  shows "PROP P \<or> PROP Q"
  unfolding Or_def using assms by move logic

lemma OrE [elim, elims]:
  assumes "PROP P \<or> PROP Q" and "PROP P \<Longrightarrow> PROP R" and "PROP Q \<Longrightarrow> PROP R"
  shows "PROP R"
  apply (rule AllE[where ?P="\<lambda>R. (\<lbrakk>PROP P \<Longrightarrow> PROP R; PROP Q \<Longrightarrow> PROP R\<rbrakk> \<Longrightarrow> PROP R)"])
  by (unfold All_def, fold Or_def) fact+

lemma NotI [intro, intros]:
  assumes "PROP P \<Longrightarrow> PROP False"
  shows "\<not>PROP P"
  unfolding Not_def by fact

lemma NotE [refine]:
  assumes "\<not>PROP P" and "PROP P"
  shows "PROP Q"
  using assms unfolding Not_def by mp explosion

lemmas contradiction = NotE
method contradiction = (rule contradiction | rule contradiction[rotated])

lemma IffI [intro, intros]:
  assumes "PROP P \<Longrightarrow> PROP Q" and "PROP Q \<Longrightarrow> PROP P"
  shows "PROP P \<Longleftrightarrow> PROP Q"
  unfolding Iff_def by (rule AndI) fact+

lemma IffD1 [dest, dests]:
  assumes "PROP P \<Longleftrightarrow> PROP Q"
  shows "PROP P \<Longrightarrow> PROP Q"
  using assms unfolding Iff_def by (rule AndD1)

lemma IffD2 [dest, dests]:
  assumes "PROP P \<Longleftrightarrow> PROP Q"
  shows "PROP Q \<Longrightarrow> PROP P"
  using assms unfolding Iff_def by (rule AndD2)

lemmas forward_imp = IffD1
lemmas backward_imp = IffD2

text \<open>Logical equivalence is the equality relation on propositions.\<close>

axiomatization where
  Iff_imp_Equal [intros]: "(PROP P \<Longleftrightarrow> PROP Q) \<Longrightarrow> (PROP P = PROP Q)"

lemma Iff_iff_Equal:
  "(PROP P \<Longleftrightarrow> PROP Q) \<Longleftrightarrow> (PROP P = PROP Q)"
  by logic

lemma Iff_is_Equal [simps]:
  "(PROP P \<Longleftrightarrow> PROP Q) = (PROP P = PROP Q)"
  by logic

section \<open>Classical logic\<close>

axiomatization where LEM: "PROP P \<or> \<not>PROP P"

text \<open>Set up disjunctive case analysis:\<close>

thm OrE[OF LEM, where ?P="PROP Z"]

method cases for cs :: "prop" = (rule OrE[OF LEM[where ?P="PROP cs"]])

lemma double_negE:
  assumes "\<not>\<not>PROP P"
  shows "PROP P"
proof (cases "PROP P")
  show "PROP P \<Longrightarrow> PROP P" .
  show "\<not>PROP P \<Longrightarrow> PROP P" by (explosion, fold Not_def, fact)
qed

lemma de_Morgan_And:
  "\<not>(PROP A \<and> PROP B) = \<not>PROP A \<or> \<not>PROP B"
  apply logic
  apply (cases "PROP A")
  apply (cases "PROP B")
  apply logic
  apply (erule OrI1 OrI2)+
  apply logic
done

lemma de_Morgan_Or:
  "\<not>(PROP A \<or> PROP B) = \<not>PROP A \<and> \<not>PROP B"
apply logic defer
apply logic defer
apply logic
proof -
  assume *: "\<not>(PROP A \<or> PROP B)"
  { assume "PROP A"
    hence "PROP A \<or> PROP B" by (rule OrI1)
    thus "PROP False" using * by contradiction }
  { assume "PROP B"
    hence "PROP A \<or> PROP B" by (rule OrI2)
    thus "PROP False" using * by contradiction }
qed

end


theory Strict_Omega_Category
imports Globular_Set

begin

section \<open>Strict $\omega$-categories\<close>

text \<open>
  First, we define a locale \<open>pre_strict_omega_category\<close> that holds the data of a strict
  $\omega$-category without the associativity, unity and exchange axioms
  \cite[Def 1.4.8 (a) - (b)]{Leinster2004}. We do this in order to set up convenient notation
  before we state the remaining axioms.
\<close>

locale pre_strict_omega_category = globular_set +
  fixes comp :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
    and i :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes comp_fun: "is_composable_pair m n x' x \<Longrightarrow> comp m n x' x \<in> X m"
    and i_fun: "i n \<in> X n \<rightarrow> X (Suc n)"
    and s_comp_Suc: "is_composable_pair (Suc m) m x' x \<Longrightarrow> s m (comp (Suc m) m x' x) = s m x"
    and t_comp_Suc: "is_composable_pair (Suc m) m x' x \<Longrightarrow> t m (comp (Suc m) m x' x) = t m x'"
    and s_comp: "\<lbrakk>is_composable_pair (Suc m) n x' x; n < m\<rbrakk> \<Longrightarrow>
          s m (comp (Suc m) n x' x) = comp m n (s m x') (s m x)"
    and t_comp: "\<lbrakk>is_composable_pair (Suc m) n x' x; n < m\<rbrakk> \<Longrightarrow>
          t m (comp (Suc m) n x' x) = comp m n (t m x') (s m x)"
    and s_i: "x \<in> X n \<Longrightarrow> s n (i n x) = x"
    and t_i: "x \<in> X n \<Longrightarrow> t n (i n x) = x"
begin

text \<open>Similar to the generalised source and target maps in \<open>globular_set\<close>, we defined a generalised
identity map. The first argument gives the dimension of the resulting identity cell, while the
second gives the dimension of the input cell.\<close>

fun i' :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"i' 0 0 = id" |
"i' 0 (Suc n) = undefined" |
"i' (Suc m) n = (if Suc m < n then undefined
  else if Suc m = n then id
  else i m \<circ> i' m n)"

lemma i'_n_n [simp]: "i' n n = id"
  by (metis i'.elims i'.simps(1) less_irrefl_nat)

lemma i'_Suc_n_n [simp]: "i' (Suc n) n = i n"
  by simp

lemma i'_Suc [simp]: "n \<le> m \<Longrightarrow> i' (Suc m) n = i m \<circ> i' m n"
  by fastforce

lemma i'_Suc': "n < m \<Longrightarrow> i' m n = i' m (Suc n) \<circ> i n"
proof (induction m arbitrary: n)
  case 0
  then show ?case by blast
next
  case (Suc m)
  then show ?case by force
qed

lemma i'_fun: "n \<le> m \<Longrightarrow> i' m n \<in> X n \<rightarrow> X m"
proof (induction m arbitrary: n)
  case 0
  then show ?case by fastforce
next
  case (Suc m)
  thus ?case proof (cases "n = Suc m")
    case True
    then show ?thesis by auto
  next
    case False
    hence "n \<le> m" using `n \<le> Suc m` by force
    thus ?thesis using Suc.IH i_fun by auto
  qed
qed

end

text \<open>Now we may define a strict $\omega$-category including the composition, unity and exchange
  axioms \cite[Def 1.4.8 (c) - (f)]{Leinster2004}.\<close>

locale strict_omega_category = pre_strict_omega_category +
  assumes comp_assoc: "\<lbrakk>is_composable_pair m n x' x; is_composable_pair m n x'' x'\<rbrakk> \<Longrightarrow>
            comp m n (comp m n x'' x') x = comp m n x'' (comp m n x' x)"
    and i_comp: "\<lbrakk>n < m; x \<in> X m\<rbrakk> \<Longrightarrow> comp m n (i' m n (t' m n x)) x = x"
    and comp_i: "\<lbrakk>n < m; x \<in> X m\<rbrakk> \<Longrightarrow> comp m n x (i' m n (s' m n x)) = x"
    and bin_interchange: "\<lbrakk>q < p; p < m;
          is_composable_pair m p y' y; is_composable_pair m p x' x;
          is_composable_pair m q y' x'; is_composable_pair m q y x\<rbrakk> \<Longrightarrow>
          comp m q (comp m p y' y) (comp m p x' x) = comp m p (comp m q y' x') (comp m q y x)"
    and null_interchange: "\<lbrakk>q < p; is_composable_pair p q x' x\<rbrakk> \<Longrightarrow>
          comp (Suc p) q (i p x') (i p x) = i p (comp p q x' x)"

locale strict_omega_functor = globular_map +
  source: strict_omega_category X s\<^sub>X t\<^sub>X comp\<^sub>X i\<^sub>X +
  target: strict_omega_category Y s\<^sub>Y t\<^sub>Y comp\<^sub>Y i\<^sub>Y
  for comp\<^sub>X i\<^sub>X comp\<^sub>Y i\<^sub>Y +
  assumes commute_with_comp: "is_composable_pair m n x' x \<Longrightarrow>
      \<phi> m (comp\<^sub>X m n x' x) = comp\<^sub>Y m n (\<phi> m x') (\<phi> m x)"
    and commute_with_id: "x \<in> X n \<Longrightarrow> \<phi> (Suc n) (i\<^sub>X n x) = i\<^sub>Y n (\<phi> n x)"

end


theory ArcExt
imports SubRel
begin

section \<open>Extending rooted graphs with edges\<close>

text \<open>In this section, we formalize the operation of adding to a rooted graph an edge whose source
is already a vertex of the given graph but not its target. We call this operation an extension of the given graph by adding
an edge. This corresponds to an abstraction of
the act of adding an edge to the red part of a red\hyp{}black graph as a result of symbolic execution
of the corresponding transition in the LTS under analysis, where all details about symbolic
execution would have been abstracted.  We then state and prove a number of facts
describing the evolution of the set of paths of the given graph, first without considering
subsumption links then in the case of rooted graph equipped with a subsumption relation.\<close>

subsection \<open>Definition and Basic properties\<close>

text \<open>Extending a rooted graph with an edge consists in adding to its set of edges an edge whose
source is a vertex of this graph but whose target is not.\<close>

abbreviation extends ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v edge \<Rightarrow> ('v,'x) rgraph_scheme \<Rightarrow> bool"
where
  "extends g e g' \<equiv> src e \<in> Graph.vertices g
                  \<and> tgt e \<notin> Graph.vertices g
                  \<and> g' = (add_edge g e)"

text \<open>After such an extension, the set of out-edges of the target of the new edge is empty.\<close>

lemma extends_tgt_out_edges :
  assumes "extends g e g'"
  shows   "out_edges g' (tgt e) = {}"
using assms unfolding vertices_def image_def by force

text \<open>Consider a graph equipped with a sub-relation. This relation is also a sub-relation of any
extension of this graph.\<close>

lemma (in sub_rel_of)
  assumes "extends g e g'"
  shows   "sub_rel_of g' subs"
using assms sub_rel_of by (auto simp add : sub_rel_of_def vertices_def)

text \<open>Extending a graph with an edge preserves the existing sub-paths.\<close>

lemma sp_in_extends :
  assumes "extends g e g'"
  assumes "Graph.subpath g  v1 es v2"
  shows   "Graph.subpath g' v1 es v2"
using assms by (auto simp add : Graph.subpath_def vertices_def)

subsection \<open>Extending trees\<close>

text \<open>We show that extending a rooted graph that is already a tree yields a new tree. Since
the empty rooted graph is a tree, all graphs produced using only the extension by edge are trees.\<close>

lemma extends_is_tree :
  assumes "is_tree g"
  assumes "extends g e g'"
  shows   "is_tree g'"
unfolding is_tree_def Ball_def
proof (intro allI impI)
  fix v

  have "root g' = root g" using assms(2) by simp

  assume "v \<in> Graph.vertices g'"

  hence "v \<in> Graph.vertices g \<or> v = tgt e"
  using assms(2) by (auto simp add : vertices_def)

  thus "\<exists>!es. path g' es v"
  proof (elim disjE, goal_cases)
    case 1

    then obtain es
    where "Graph.path g es v"
    and   "\<forall> es'. Graph.path g es' v \<longrightarrow> es' = es"
    using assms(1) unfolding Ex1_def is_tree_def by blast

    hence "Graph.path g' es v"
    using assms(2) sp_in_extends[OF assms(2)]
    by (subst \<open>root g' = root g\<close>)

    moreover
    have "\<forall> es'. Graph.path g' es' v \<longrightarrow> es' =  es"
    proof (intro allI impI)
      fix es'

      assume "Graph.path g' es' v"

      thus "es' = es"
      proof (case_tac "e \<in> set es'", goal_cases)
        case 1

        then obtain es''
        where "es' = es'' @ [e]"
        and   "e \<notin> set es''"
        using \<open>Graph.path g' es' v\<close>
              Graph.sp_through_de_decomp[OF extends_tgt_out_edges[OF assms(2)]]
        by blast

        hence "v = tgt e"
        using \<open>Graph.path g' es' v\<close>
        by (simp add : Graph.sp_append_one)

        thus ?thesis
        using assms(2)
              Graph.lst_of_sp_is_vert[OF \<open>Graph.path g es v\<close>]
        by simp
      next
        case 2 thus ?thesis
        using assms
              \<open>\<forall> es'. Graph.path g es' v \<longrightarrow> es' = es\<close> \<open>Graph.path g' es' v\<close>
        by (auto simp add : Graph.subpath_def vertices_def)
      qed
    qed

    ultimately
    show ?thesis by auto

  next
    case 2

    then obtain es
    where "Graph.path g es (src e)"
    and   "\<forall> es'. Graph.path g es' (src e) \<longrightarrow> es' = es"
    using assms(1,2) unfolding is_tree_def by blast

    hence "Graph.path g' es (src e)"
    using sp_in_extends[OF assms(2)]
    by (subst \<open>root g' = root g\<close>)

    hence "Graph.path g' (es @ [e]) (tgt e)"
    using assms(2) by (auto simp add : Graph.sp_append_one)

    moreover
    have "\<forall> es'. Graph.path g' es' (tgt e) \<longrightarrow> es' = es @ [e]"
    proof (intro allI impI)
      fix es'

      assume "Graph.path g' es' (tgt e)"

      moreover
      hence "e \<in> set es'"
      using assms
            sp_ends_in_tgt_imp_mem[of e g "root g" es']
      by (auto simp add : Graph.subpath_def vertices_def)

      moreover
      have   "out_edges g' (tgt e) = {}"
      using assms
      by (intro extends_tgt_out_edges)

      ultimately
      have "\<exists> es''. es' = es'' @ [e] \<and> e \<notin> set es''"
      by (elim Graph.sp_through_de_decomp)

      then obtain es''
      where "es' = es'' @ [e]"
      and   "e \<notin> set es''"
      by blast

      hence "Graph.path g' es'' (src e)"
      using \<open>Graph.path g' es'  (tgt e)\<close>
      by (auto simp add : Graph.sp_append_one)

      hence "Graph.path g es'' (src e)"
      using assms(2) \<open>e \<notin> set es''\<close>
      by (auto simp add : Graph.subpath_def vertices_def)

      hence "es'' = es"
      using \<open>\<forall> as'. Graph.path g as' (src e) \<longrightarrow> as' = es\<close>
      by simp

      thus "es' = es @ [e]" using \<open>es' = es'' @ [e]\<close> by simp
    qed

    ultimately
    show ?thesis using 2 by auto
  qed
qed

subsection \<open>Properties of sub-paths in an extension\<close>

text \<open>Extending a graph by an edge preserves the existing sub-paths.\<close>

lemma sp_in_extends_w_subs :
  assumes "extends g a g'"
  assumes "subpath g  v1 es v2 subs"
  shows   "subpath g' v1 es v2 subs"
using assms by (auto simp add : subpath_def sub_rel_of_def vertices_def)

text \<open>In an extension, the target of the new edge has no out-edges. Thus sub-paths of the
extension starting and ending in old vertices are sub-paths of the graph prior to its extension.\<close>

lemma (in sub_rel_of) sp_from_old_verts_imp_sp_in_old :
  assumes "extends g e g'"
  assumes "v1 \<in> Graph.vertices g"
  assumes "v2 \<in> Graph.vertices g"
  assumes "subpath g' v1 es v2 subs"
  shows   "subpath g  v1 es v2 subs"
proof -
  have "e \<notin> set es"
  proof (intro notI)
    assume "e \<in> set es"

    have "v2 = tgt e"
    proof -
      have "tgt e \<notin> subsumees subs" using sub_rel_of assms(1) by fast

      moreover
      have  "out_edges g' (tgt e) = {}" using assms(1) by (rule extends_tgt_out_edges)

      ultimately
      have "\<exists> es'. es = es' @ [e] \<and> e \<notin> set es'"
      using  assms(4) \<open>e \<in> set es\<close>
      by (intro sp_through_de_decomp)

      then obtain es' where "es = es' @ [e]" "e \<notin> set es'" by blast

      hence "tgt e = v2 \<or> (tgt e,v2) \<in> subs\<^sup>+"
      using assms(4) by (simp add : sp_append_one)

      thus ?thesis using \<open>tgt e \<notin> subsumees subs\<close> tranclD[of "tgt e" v2 subs] by force
    qed

    thus False using assms(1,3) by simp
  qed

  thus ?thesis
  using sub_rel_of assms
  unfolding subpath_def sub_rel_of_def by auto
qed

text \<open>For the same reason, sub-paths starting at the target of the new edge are empty.\<close>

lemma (in sub_rel_of) sp_from_tgt_in_extends_is_Nil :
  assumes "extends g e g'"
  assumes "subpath g' (tgt e) es v subs"
  shows   "es = []"
using sub_rel_of assms
      extends_tgt_out_edges
      sp_from_de_empty[of "tgt e" subs g' es v]
by fast

text \<open>Moreover, a sub-path @{term es} starting in another vertex than the target of the new edge
@{term e} but ending in this target has @{term e} as last element. This occurrence of @{term e} is
unique among @{term es}. The prefix of @{term es} preceding @{term e} is a sub-path leading at the
source of @{term e} in the original graph.\<close>

lemma (in sub_rel_of) sp_to_new_edge_tgt_imp :
  assumes "extends g e g'"
  assumes "subpath g' v es (tgt e) subs"
  assumes "v \<noteq> tgt e"
  shows   "\<exists> es'. es = es' @ [e] \<and> e \<notin> set es' \<and> subpath g v es' (src e) subs"
proof -
  obtain es' where "es = es' @ [e]" and "e \<notin> set es'"
  using sub_rel_of assms(1,2,3)
        extends_tgt_out_edges[OF assms(1)]
        sp_through_de_decomp[of e subs g' v es "tgt e"]
        sp_ends_in_tgt_imp_mem[of e v es]
  by blast

  moreover
  have "subpath g v es' (src e) subs"
  proof -
    have "v \<in> Graph.vertices g"
    using assms(1,3) fst_of_sp_is_vert[OF assms(2)]
    by (auto simp add : vertices_def)

    moreover
    have "SubRel.subpath g' v es' (src e) subs"
    using assms(2) \<open>es = es' @ [e]\<close> by (simp add : sp_append_one)

    ultimately
    show ?thesis
    using assms(1) sub_rel_of \<open>e \<notin> set es'\<close>
    unfolding subpath_def by (auto simp add : sub_rel_of_def)
  qed

  ultimately
  show ?thesis by blast
qed

end


(*  Title:      CoW/Reverse_Symmetry.thy
    Author:     Martin Raška, Charles University

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)

theory Reverse_Symmetry
  imports Main
begin

chapter "Reverse symmetry"

text \<open>This theory deals with a mechanism which produces new facts on lists from already known facts
by the reverse symmetry of lists, induced by the mapping @{term rev}.
It constructs the rule attribute ``reversed'' which produces the symmetrical fact using so-called
reversal rules, which are rewriting rules that may be applied to obtain the symmetrical fact.
An example of such a reversal rule is the already existing @{thm rev_append[symmetric, no_vars]}.
Some additional reversal rules are given in this theory.

The symmetrical fact 'A[reversed]' is constructed from the fact 'A' in the following manner:
  1. each schematic variable @{term "xs::'a list"} of type @{typ "'a list"}
is instantiated by @{term "rev xs"};
  2. constant Nil is substituted by @{term "rev Nil"};
  3. each quantification of @{typ "'a list"} type variable @{term "\<And>(xs::'a list). P xs"}
is substituted by (logically equivalent) quantification @{term "\<And>xs. P (rev xs)"},
similarly for $\forall$, $\exists$ and $\exists!$ quantifiers; each bounded quantification of @{typ "'a list"} type
variable @{term "\<forall>(xs::'a list) \<in> A. P xs"} is substituted by (logically equivalent)
quantification @{term "\<forall>xs\<in>rev ` A. P (rev xs)"}, similarly for bounded $\exists$ quantifier;
  4. simultaneous rewrites according to a the current list of reversal rules are performed;
  5. final correctional rewrites related to reversion of @{const "Cons"} are performed.

List of reversal rules is maintained by declaration attribute ``reversal\_rule'' with standard
``add'' and ``del'' options.

See examples at the end of the file.
\<close>

section \<open>Quantifications and maps\<close>

lemma all_surj_conv: assumes "surj f" shows "(\<And>x. PROP P (f x)) \<equiv> (\<And>y. PROP P y)"
proof
  fix y assume "\<And>x. PROP P (f x)"
  then have "PROP P (f (inv f y))".
  then show "PROP P y" unfolding surj_f_inv_f[OF assms].
qed

lemma All_surj_conv: assumes "surj f" shows "(\<forall>x. P (f x)) \<longleftrightarrow> (\<forall>y. P y)"
proof (intro iffI allI)
  fix y assume "\<forall>x. P (f x)"
  then have "P (f (inv f y))"..
  then show "P y" unfolding surj_f_inv_f[OF assms].
qed simp

lemma Ex_surj_conv: assumes "surj f" shows "(\<exists>x. P (f x)) \<longleftrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain x where "P (f x)"..
  then show "\<exists>x. P x"..
next
  assume "\<exists>y. P y"
  then obtain y where "P y"..
  then have "P (f (inv f y))" unfolding surj_f_inv_f[OF assms].
  then show "\<exists>x. P (f x)"..
qed

lemma Ex1_bij_conv: assumes "bij f" shows "(\<exists>!x. P (f x)) \<longleftrightarrow> (\<exists>!y. P y)"
proof
  have imp: "\<exists>!y. Q y" if bij: "bij g" and ex1: "\<exists>!x. Q (g x)" for g Q
  proof -
    from ex1E[OF ex1, rule_format]
    obtain x where ex: "Q (g x)" and uniq: "\<And>x'. Q (g x') \<Longrightarrow> x' = x" by blast
    {
      fix y assume "Q y"
      then have "Q (g (inv g y))" unfolding surj_f_inv_f[OF bij_is_surj[OF bij]].
      from uniq[OF this] have "x = inv g y"..
      then have "y = g x" unfolding bij_inv_eq_iff[OF bij]..
    }
    with ex show "\<exists>!y. Q y"..
  qed
  show "\<exists>!x. P (f x) \<Longrightarrow> \<exists>!y. P y" using imp[OF assms].
  assume "\<exists>!y. P y"
  then have "\<exists>!y. P (f (inv f y))" unfolding surj_f_inv_f[OF bij_is_surj[OF assms]].
  from imp[OF bij_imp_bij_inv[OF assms] this]
  show "\<exists>!x. P (f x)".
qed

lemma Ball_inj_conv: assumes "inj f" shows "(\<forall>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<forall>x\<in>A. P x)"
  using ball_simps(9)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].

lemma Bex_inj_conv: assumes "inj f" shows "(\<exists>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<exists>x\<in>A. P x)"
  using bex_simps(7)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].

subsection \<open>Quantifications and reverse\<close>

lemma rev_involution': "rev \<circ> rev = id"
  by auto

lemma rev_inv: "inv rev = rev"
  using inv_unique_comp[OF rev_involution' rev_involution'].

section \<open>Attributes\<close>

context
begin

subsection \<open>Cons reversion\<close>

definition snocs :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "snocs xs ys  = xs @ ys"

subsection \<open>Final corrections\<close>

lemma snocs_snocs: "snocs (snocs xs (y # ys)) zs = snocs xs (y # snocs ys zs)"
  unfolding snocs_def by simp

lemma snocs_Nil: "snocs [] xs = xs"
  unfolding snocs_def by simp

lemma snocs_is_append: "snocs xs ys = xs @ ys"
  unfolding snocs_def..

private lemmas final_correct1 =
  snocs_snocs

private lemmas final_correct2 =
  snocs_Nil

private lemmas final_correct3 =
  snocs_is_append

subsection \<open>Declaration attribute \<open>reversal_rule\<close>\<close>

ML \<open>
structure Reversal_Rules =
  Named_Thms(
    val name = @{binding "reversal_rule"}
    val description = "Rules performing reverse-symmetry transformation on theorems on lists"
  )
\<close>

attribute_setup reversal_rule =
  \<open>Attrib.add_del
    (Thm.declaration_attribute Reversal_Rules.add_thm)
    (Thm.declaration_attribute Reversal_Rules.del_thm)\<close>
  "maintaining a list of reversal rules"

subsection \<open>Tracing attribute\<close>

ML \<open>
  val reversed_trace = Config.declare_bool ("reversed_trace", \<^here>) (K false);
  val enable_tracing = Config.put_generic reversed_trace true
  val tracing_attr = Thm.declaration_attribute (K enable_tracing)
  val tracing_parser : attribute context_parser = Scan.lift (Scan.succeed tracing_attr)
\<close>

attribute_setup reversed_trace = tracing_parser "reversed trace configuration"

subsection \<open>Rule attribute \<open>reversed\<close>\<close>

private lemma rev_Nil: "rev [] \<equiv> []"
  by simp

private lemma map_Nil: "map f [] \<equiv> []"
  by simp

private lemma image_empty: "f ` Set.empty \<equiv> Set.empty"
  by simp

definition COMP :: "('b \<Rightarrow> prop) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> prop" (infixl "oo" 55)
  where "F oo g \<equiv> (\<lambda>x. F (g x))"

lemma COMP_assoc: "F oo (f o g) \<equiv> (F oo f) oo g"
  unfolding COMP_def o_def.

private lemma image_comp_image: "(`) f \<circ> (`) g \<equiv> (`) (f \<circ> g)"
  unfolding comp_def image_comp.

private lemma rev_involution: "rev \<circ> rev \<equiv> id"
  unfolding comp_def rev_rev_ident id_def.

private lemma map_involution: assumes "f \<circ> f \<equiv> id" shows "(map f) \<circ> (map f) \<equiv> id"
  unfolding map_comp_map \<open>f \<circ> f \<equiv> id\<close> List.map.id.

private lemma image_involution: assumes "f \<circ> f \<equiv> id" shows "(image f) \<circ> (image f) \<equiv> id"
  unfolding image_comp_image \<open>f \<circ> f \<equiv> id\<close> image_id.

private lemma rev_map_comm: "rev \<circ> map f \<equiv> map f \<circ> rev"
  unfolding comp_def rev_map.

private lemma involut_comm_comp: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
  shows "(f \<circ> g) \<circ> (f \<circ> g) \<equiv> id"
  by (simp add: comp_assoc comp_assoc[symmetric] assms)

private lemma rev_map_involution: assumes "g o g \<equiv> id"
  shows "(rev \<circ> map g) \<circ> (rev \<circ> map g) \<equiv> id"
  using involut_comm_comp[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].

private lemma prop_abs_subst: assumes "f o f \<equiv> id" shows "(\<lambda>x. F (f x)) oo f \<equiv> (\<lambda>x. F x)"
  unfolding COMP_def o_apply[symmetric] unfolding \<open>f o f \<equiv> id\<close> id_def.

private lemma prop_abs_subst_comm: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
  shows "(\<lambda>x. F (f (g x))) oo (f o g) \<equiv> (\<lambda>x. F x)"
  unfolding \<open>f o g \<equiv> g o f\<close> unfolding COMP_assoc
  unfolding prop_abs_subst[OF \<open>g o g \<equiv> id\<close>, of "\<lambda>x. F (f x)"] prop_abs_subst[OF \<open>f o f \<equiv> id\<close>].

private lemma prop_abs_subst_rev_map: assumes "g o g \<equiv> id"
  shows "(\<lambda>x. F (rev (map g x))) oo (rev o map g) \<equiv> (\<lambda>x. F x)"
  using prop_abs_subst_comm[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].

private lemma obj_abs_subst: assumes "f o f \<equiv> id" shows "(\<lambda>x. F (f x)) o f \<equiv> (\<lambda>x. F x)"
  unfolding comp_def unfolding o_apply[of f, symmetric] \<open>f o f \<equiv> id\<close> id_def.

private lemma obj_abs_subst_comm: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
  shows "(\<lambda>x. F (f (g x))) o (f o g) \<equiv> (\<lambda>x. F x)"
  unfolding \<open>f o g \<equiv> g o f\<close> unfolding comp_assoc[symmetric]
  unfolding obj_abs_subst[OF \<open>g o g \<equiv> id\<close>, of "\<lambda>x. F (f x)"] obj_abs_subst[OF \<open>f o f \<equiv> id\<close>].

private lemma obj_abs_subst_rev_map: assumes "g o g \<equiv> id"
  shows "(\<lambda>x. F (rev (map g x))) o (rev o map g) \<equiv> (\<lambda>x. F x)"
  using obj_abs_subst_comm[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].

ML \<open>

local
  fun comp_const T = Const(\<^const_name>\<open>comp\<close>, (T --> T) --> (T --> T) --> T --> T)
  fun rev_const T = Const(\<^const_name>\<open>rev\<close>, T --> T)
  fun map_const S T = Const(\<^const_name>\<open>map\<close>, (S --> S) --> T --> T)
  fun image_const S T = Const(\<^const_name>\<open>image\<close>, (S --> S) --> T --> T)

  val rev_Nil_thm = @{thm rev_Nil}
  val map_Nil_thm = @{thm map_Nil}
  val image_empty_thm = @{thm image_empty}
  val rev_involut_thm = @{thm rev_involution}
  val map_involut_thm = @{thm map_involution}
  val image_involut_thm = @{thm image_involution}
  val rev_map_comm_thm = @{thm rev_map_comm}
  val involut_comm_comp_thm = @{thm involut_comm_comp}
  fun abs_subst_thm T =
    if T = propT then @{thm prop_abs_subst} else @{thm obj_abs_subst}
  fun abs_subst_rev_map_thm T =
    if T = propT then @{thm prop_abs_subst_rev_map} else @{thm obj_abs_subst_rev_map}

  fun comp T f gs = fold (fn f => fn g =>
        (comp_const T $ f $ g)) gs f
  fun app ctxt gs ct = fold_rev (fn g => fn ct' =>
        Thm.apply (Thm.cterm_of ctxt g) ct') gs ct
in

  fun subst ctxt T ct =
    let
      fun tr (T as Type(\<^type_name>\<open>list\<close>, [S])) = [rev_const T] @ (
          case tr S of
            [] => []
          | (g :: gs') => [map_const S T $ comp S g gs'])
        | tr (T as Type(\<^type_name>\<open>set\<close>, [S])) = (
          case tr S of
            [] => []
          | (g :: gs') => [image_const S T $ comp S g gs'])
        | tr _ = []
    in app ctxt (tr T) ct end

  fun abs_cv T U ct =
    let
      fun tr_eq (T as Type(\<^type_name>\<open>list\<close>, [S])) =
            rev_involut_thm :: (
            case tr_eq S of
              [] => []
            | [f_eq] => [f_eq RS map_involut_thm]
            | [f_eq, g_eq] =>
                [([f_eq, g_eq, rev_map_comm_thm] MRS involut_comm_comp_thm) RS map_involut_thm])
        | tr_eq (T as Type(\<^type_name>\<open>set\<close>, [S])) = (
            case tr_eq S of
              [] => []
            | [f_eq] => [f_eq RS image_involut_thm]
            | [f_eq, g_eq] =>
                [([f_eq, g_eq, rev_map_comm_thm] MRS involut_comm_comp_thm) RS image_involut_thm])
        | tr_eq _ = []
    in case tr_eq T of
      [] => Thm.reflexive ct
    | [f_inv] =>
        [Thm.reflexive ct, Thm.symmetric (f_inv RS abs_subst_thm U)] MRS transitive_thm
    | [f_inv, g_inv] =>
        [Thm.reflexive ct, Thm.symmetric (g_inv RS abs_subst_rev_map_thm U)] MRS transitive_thm
    end;

  fun Nil_cv ctxt T ct =
    ((Conv.try_conv o Conv.arg_conv o Conv.rewr_conv) map_Nil_thm
    then_conv (Conv.try_conv o Conv.rewr_conv) rev_Nil_thm) (subst ctxt T ct)
      |> Thm.symmetric

  fun empty_cv ctxt T ct =
    (Conv.try_conv o Conv.rewr_conv) image_empty_thm (subst ctxt T ct)
      |> Thm.symmetric

end

fun initiate_cv ctxt ct =
  case Thm.term_of ct of
    _ $ _ => Conv.comb_conv (initiate_cv ctxt) ct
  | Abs(_, T, b) => (Conv.abs_conv (initiate_cv o snd) ctxt then_conv abs_cv T (fastype_of b)) ct
  | Const(\<^const_name>\<open>Nil\<close>, T) => Nil_cv ctxt T ct
  | Const(\<^const_name>\<open>bot\<close>, T as Type(\<^type_name>\<open>set\<close>, _)) => empty_cv ctxt T ct
  | _ => Thm.reflexive ct
\<close>

ML \<open>

fun trace_rule_prems_proof ctxt rule goals rule_prems rule' =
  if not (Config.get ctxt reversed_trace) then () else
    let
      val ctxt_prems = Raw_Simplifier.prems_of ctxt
      val np = Thm.nprems_of rule
      val np' = Thm.nprems_of rule'
      val pretty_term = Syntax.pretty_term ctxt
      val pretty_thm = pretty_term o Thm.prop_of
      val success = rule_prems |> List.all is_some
      val sendback = Active.make_markup Markup.sendbackN
        {implicit = false, properties = [Markup.padding_command]}
      val _ = [
        [
          "Trying to use conditional reverse rule:" |> Pretty.para,
          rule |> pretty_thm
        ] |> Pretty.fbreaks |> Pretty.block,
        [(if null ctxt_prems
          then "No context premises."
          else "Context premises:"
         ) |> Pretty.para
        ] @ (
          ctxt_prems |> map (Pretty.item o single o pretty_thm)
        ) |> Pretty.fbreaks |> Pretty.block,
        ( if success then [
          "Successfully derived unconditional reverse rule:" |> Pretty.para,
          rule' |> pretty_thm
        ] else [
          "Unable to prove " ^ string_of_int np ^ " out of " ^ string_of_int np' ^ " rule premises:\n"
            |> Pretty.para
        ] @ (
          (goals ~~ rule_prems) |> map_filter (
            fn (goal, NONE) => SOME ([
                "lemma" |> Pretty.str, Pretty.brk 1,
                goal |> pretty_term |> Pretty.quote, Pretty.fbrk,
                "sorry" |> Pretty.str
              ] |> curry Pretty.blk 0 |> Pretty.mark sendback |> single |> Pretty.item)
            | _ => NONE
          )
        )) |> Pretty.fbreaks |> Pretty.block
      ] |> Pretty.chunks |> Pretty.string_of |> tracing
    in () end

fun full_resolve ctxt prem i =
  let
    val tac = resolve_tac ctxt [prem] THEN_ALL_NEW blast_tac ctxt
  in rule_by_tactic ctxt (tac i) end

fun prover method ss ctxt rule =
  let
    val ctxt_prems = Raw_Simplifier.prems_of ctxt
    val rule_prems' = Logic.strip_imp_prems (Thm.prop_of rule)
    val goals = rule_prems' |> map (fn prem =>
      Logic.list_implies (map Thm.prop_of ctxt_prems, prem));
    val ctxt' = ctxt |> put_simpset ss
    fun prove t = SOME (Goal.prove ctxt' [] [] t
      (fn {context = goal_ctxt, prems} => NO_CONTEXT_TACTIC goal_ctxt (method goal_ctxt prems)))
      handle ERROR _ =>  NONE
    val ths = goals |> map prove
    val gen_ctxt_prems = map (Variable.gen_all ctxt) ctxt_prems
    fun full_resolve1 prem = full_resolve ctxt prem 1
    val rule_prems = ths |> (map o Option.map) (fold full_resolve1 gen_ctxt_prems)
    val rule' = (fold o curry) (
      fn (SOME th, rule') => rule' |> full_resolve1 th
      | (NONE, rule') => Drule.rotate_prems 1 rule'
      ) rule_prems rule
    val nprems = Thm.nprems_of rule'
    val _ = trace_rule_prems_proof ctxt rule goals rule_prems rule'
  in if nprems = 0 then SOME rule' else NONE end

fun rewrite _ _ [] = Thm.reflexive
  | rewrite method ctxt thms =
      let
        val p = prover method (simpset_of ctxt)
        val ctxt' = Raw_Simplifier.init_simpset thms ctxt
      in
        Raw_Simplifier.rewrite_cterm (true, true, true) p ctxt'
      end

fun rewrite_rule method ctxt = Conv.fconv_rule o rewrite method ctxt;

fun meta_reversal_rules ctxt extra =
  map (Local_Defs.meta_rewrite_rule ctxt) (extra @ Reversal_Rules.get ctxt)

fun reverse method extra_rules context th =
  let
    val ctxt = Context.proof_of context
    val final_correct1 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct1}
    val final_correct2 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct2}
    val final_correct3 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct3}
    val rules = meta_reversal_rules ctxt extra_rules
    val cvars = Thm.add_vars th Vars.empty
    val cvars' = Vars.map ((subst ctxt o snd)) cvars
    val th_subst = Thm.instantiate (TVars.empty, cvars') th
    val ((_, [th_import]), ctxt') = Variable.import true [th_subst] ctxt
    val th_init = th_import |> Conv.fconv_rule (initiate_cv ctxt')
    val th_rev = th_init |> rewrite_rule method ctxt' rules
    val th_corr = th_rev
          |> Raw_Simplifier.rewrite_rule ctxt' final_correct1
          |> Raw_Simplifier.rewrite_rule ctxt' final_correct2
          |> Raw_Simplifier.rewrite_rule ctxt' final_correct3
    val th_export = th_corr |> singleton (Variable.export ctxt' ctxt)
  in
    Drule.zero_var_indexes th_export
  end

val default_method = SIMPLE_METHOD o CHANGED_PROP o auto_tac

val solve_arg = Args.$$$ "solve"

val extra_rules_parser = Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) []

val solve_parser = Scan.lift (Scan.optional
    (solve_arg -- Args.colon |-- Method.parse >> (fst #> Method.evaluate)) default_method
  )

val reversed = extra_rules_parser -- solve_parser
  >> (fn (ths, method) => Thm.rule_attribute [] (reverse method ths))
\<close>

attribute_setup reversed =
  \<open>reversed\<close>
  "Transforms the theorem on lists to reverse-symmetric version"

end

section \<open>Declaration of basic reversal rules\<close>

subsection \<open>Pure\<close>

  \<comment> \<open>\<^const>\<open>Pure.all\<close>\<close>
lemma all_surj_conv' [reversal_rule]: assumes "surj f" shows "Pure.all (P oo f) \<equiv> Pure.all P"
  unfolding COMP_def using all_surj_conv[OF assms].

subsection \<open>\<^theory>\<open>HOL.HOL\<close>\<close>

  \<comment> \<open>\<^const>\<open>HOL.eq\<close>\<close>
lemmas [reversal_rule] = rev_is_rev_conv inj_eq

  \<comment> \<open>\<^const>\<open>All\<close>\<close>
lemma All_surj_conv' [reversal_rule]: assumes "surj f" shows "All (P o f) = All P"
  unfolding comp_def using All_surj_conv[OF assms].

  \<comment> \<open>\<^const>\<open>Ex\<close>\<close>
lemma Ex_surj_conv' [reversal_rule]: assumes "surj f" shows "Ex (P o f) \<longleftrightarrow> Ex P"
  unfolding comp_def using Ex_surj_conv[OF assms].

  \<comment> \<open>\<^const>\<open>Ex1\<close>\<close>
lemma Ex1_bij_conv' [reversal_rule]: assumes "bij f" shows "Ex1 (P o f) \<longleftrightarrow> Ex1 P"
  unfolding comp_def using Ex1_bij_conv[OF assms].

  \<comment> \<open>\<^const>\<open>If\<close>\<close>
lemma if_image [reversal_rule]: "(if P then f u else f v) = f (if P then u else v)"
  by simp

subsection \<open>\<^theory>\<open>HOL.Set\<close>\<close>

  \<comment> \<open>\<^const>\<open>Collect\<close>\<close>
lemma collect_image: "Collect (P \<circ> f) = f -` (Collect P)"
  by fastforce

lemma collect_image' [reversal_rule]: assumes "f \<circ> f = id" shows "Collect (P \<circ> f) = f ` (Collect P)"
  unfolding collect_image
  unfolding bij_vimage_eq_inv_image[OF o_bij[OF assms assms]]
  unfolding inv_unique_comp[OF assms assms]..

  \<comment> \<open>\<^const>\<open>Ball\<close>\<close>
lemma Ball_image [reversal_rule]: assumes "(g \<circ> f) ` A = A" shows "Ball (f ` A) (P \<circ> g) = Ball A P"
  unfolding Ball_image_comp[symmetric] image_comp \<open>(g \<circ> f) ` A = A\<close>..

  \<comment> \<open>\<^const>\<open>Bex\<close>\<close>
lemma Bex_image_comp: "Bex (f ` A) g = Bex A (g \<circ> f)"
  by simp

lemma Bex_image [reversal_rule]: assumes "(g \<circ> f) ` A = A" shows "Bex (f ` A) (P \<circ> g) = Bex A P"
  unfolding Bex_image_comp[symmetric] image_comp \<open>(g \<circ> f) ` A = A\<close>..

  \<comment> \<open>\<^const>\<open>insert\<close>\<close>
lemma insert_image [reversal_rule]: "insert (f x) (f ` X) = f ` (insert x X)"
  by blast

  \<comment> \<open>\<^const>\<open>List.member\<close>\<close>
lemmas [reversal_rule] = inj_image_mem_iff

subsection \<open>\<^theory>\<open>HOL.List\<close>\<close>

  \<comment> \<open>\<^const>\<open>set\<close>\<close>
lemmas [reversal_rule] = set_rev set_map

  \<comment> \<open>\<^const>\<open>Cons\<close>\<close>
lemma Cons_rev: "a # rev u = rev (snocs u [a])"
  unfolding snocs_def by simp

lemma Cons_map: "(f x) # (map f xs) = map f (x # xs)"
  using list.simps(9)[symmetric].

lemmas [reversal_rule] = Cons_rev Cons_map

  \<comment> \<open>\<^const>\<open>hd\<close>\<close>
lemmas [reversal_rule] = hd_rev hd_map

  \<comment> \<open>\<^const>\<open>tl\<close>\<close>
lemma tl_rev: "tl (rev xs) = rev (butlast xs)"
  using butlast_rev[of "rev xs", symmetric] unfolding rev_swap rev_rev_ident.

lemmas [reversal_rule] = tl_rev map_tl[symmetric]

  \<comment> \<open>\<^const>\<open>last\<close>\<close>
lemmas [reversal_rule] = last_rev last_map

  \<comment> \<open>\<^const>\<open>butlast\<close>\<close>
lemmas [reversal_rule] = butlast_rev map_butlast[symmetric]

  \<comment> \<open>\<^const>\<open>List.coset\<close>\<close>
lemma coset_rev: "List.coset (rev xs) = List.coset xs"
  by simp

lemma coset_map: assumes "bij f" shows "List.coset (map f xs) =  f ` List.coset xs"
  using bij_image_Compl_eq[OF \<open>bij f\<close>, symmetric] unfolding coset_def set_map.

lemmas [reversal_rule] = coset_rev coset_map

  \<comment> \<open>\<^const>\<open>append\<close>\<close>
lemmas [reversal_rule] = rev_append[symmetric] map_append[symmetric]

  \<comment> \<open>\<^const>\<open>concat\<close>\<close>
lemma concat_rev_map_rev: "concat (rev (map rev xs)) = rev (concat xs)"
  using rev_concat[symmetric] unfolding rev_map.

lemma concat_rev_map_rev': "concat (rev (map (rev \<circ> f) xs)) = rev (concat (map f xs))"
  unfolding map_comp_map[symmetric] o_apply using concat_rev_map_rev.

lemmas [reversal_rule] = concat_rev_map_rev concat_rev_map_rev'

  \<comment> \<open>\<^const>\<open>drop\<close>\<close>
lemmas [reversal_rule] = drop_rev drop_map

  \<comment> \<open>\<^const>\<open>take\<close>\<close>
lemmas [reversal_rule] = take_rev take_map

  \<comment> \<open>\<^const>\<open>nth\<close>\<close>
lemmas [reversal_rule] = rev_nth nth_map

  \<comment> \<open>\<^const>\<open>List.insert\<close>\<close>
lemma list_insert_map [reversal_rule]:
  assumes "inj f" shows "List.insert (f  x) (map f xs) = map f (List.insert x xs)"
  unfolding List.insert_def set_map inj_image_mem_iff[OF \<open>inj f\<close>] Cons_map if_image..

  \<comment> \<open>\<^const>\<open>List.union\<close>\<close>
lemma list_union_map [reversal_rule]:
  assumes "inj f" shows "List.union (map f xs) (map f ys) = map f (List.union xs ys)"
proof (induction xs arbitrary: ys)
  case (Cons a xs)
  show ?case using Cons.IH unfolding List.union_def Cons_map[symmetric] fold.simps(2) o_apply
    unfolding list_insert_map[OF \<open>inj f\<close>].
qed (simp add: List.union_def)

  \<comment> \<open>\<^const>\<open>length\<close>\<close>
lemmas [reversal_rule] = length_rev length_map

  \<comment> \<open>\<^const>\<open>rotate\<close>\<close>
lemmas [reversal_rule] = rotate_rev rotate_map

  \<comment> \<open>\<^const>\<open>lists\<close>\<close>
lemma rev_in_lists: "rev u \<in> lists A \<longleftrightarrow> u \<in> lists A"
  by auto

lemma map_in_lists: "inj f \<Longrightarrow> map f u \<in> lists (f ` A) \<longleftrightarrow> u \<in> lists A"
  by (simp add: lists_image inj_image_mem_iff inj_mapI)

lemmas [reversal_rule] = rev_in_lists map_in_lists

subsection \<open>Reverse Symmetry\<close>

  \<comment> \<open>\<^const>\<open>snocs\<close>\<close>
lemma snocs_map [reversal_rule]: "snocs (map f u) [f a] = map f (snocs u [a])"
  unfolding snocs_def by simp

section \<open>\<close>

lemma bij_rev: "bij rev"
  using o_bij[OF rev_involution' rev_involution'].

lemma bij_map: "bij f \<Longrightarrow> bij (map f)"
  using bij_betw_def inj_mapI lists_UNIV lists_image by metis

lemma surj_map: "surj f \<Longrightarrow> surj (map f)"
  using lists_UNIV lists_image by metis

lemma bij_image: "bij f \<Longrightarrow> bij (image f)"
  using bij_betw_Pow by force

lemma inj_image: "inj f \<Longrightarrow> inj (image f)"
  by (simp add: inj_on_image)

lemma surj_image: "surj f \<Longrightarrow> surj (image f)"
  using Pow_UNIV image_Pow_surj by metis

lemmas [simp] =
  bij_rev
  bij_is_inj
  bij_is_surj
  bij_comp
  inj_compose
  comp_surj
  bij_map
  inj_mapI
  surj_map
  bij_image
  inj_image
  surj_image

section \<open>Examples\<close>

context
begin

subsection \<open>Cons and append\<close>

private lemma example_Cons_append:
  assumes "xs = [a, b]" and "ys = [b, a, b]"
  shows "xs @ xs @ xs = a # b # a # ys"
using assms by simp

thm
  example_Cons_append
  example_Cons_append[reversed]
  example_Cons_append[reversed, reversed]

thm
  not_Cons_self
  not_Cons_self[reversed]

thm
  neq_Nil_conv
  neq_Nil_conv[reversed]

subsection \<open>Induction rules\<close>

thm
  list_nonempty_induct
  list_nonempty_induct[reversed] (* needs work *)
  list_nonempty_induct[reversed, where P="\<lambda>x. P (rev x)" for P, unfolded rev_rev_ident]

thm
  list_induct2
  list_induct2[reversed] (* needs work *)
  list_induct2[reversed, where P="\<lambda>x y. P (rev x) (rev y)" for P, unfolded rev_rev_ident]

subsection \<open>hd, tl, last, butlast\<close>

thm
  hd_append
  hd_append[reversed]
  last_append

thm
  length_tl
  length_tl[reversed]
  length_butlast

thm
  hd_Cons_tl
  hd_Cons_tl[reversed]
  append_butlast_last_id
  append_butlast_last_id[reversed]

subsection \<open>set\<close>

thm
  hd_in_set
  hd_in_set[reversed]
  last_in_set

thm
  set_ConsD
  set_ConsD[reversed]

thm
  split_list_first
  split_list_first[reversed]

thm
  split_list_first_prop
  split_list_first_prop[reversed]
  split_list_first_prop[reversed, unfolded append_assoc append_Cons append_Nil]
  split_list_last_prop

thm
  split_list_first_propE
  split_list_first_propE[reversed]
  split_list_first_propE[reversed, unfolded append_assoc append_Cons append_Nil]
  split_list_last_propE

subsection \<open>rotate\<close>

private lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate 1 xs = tl xs @ [hd xs]"
  by (cases xs) simp_all

thm
  rotate1_hd_tl
  rotate1_hd_tl[reversed]

end

end